Move AST to separate module
This commit is contained in:
parent
7a5cda2533
commit
33d7c2a26a
|
|
@ -1,248 +1,7 @@
|
|||
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
module Data.Language.Ruby
|
||||
( Args(..)
|
||||
, Block(..)
|
||||
, Statement(..)
|
||||
, Function(..)
|
||||
, Module(..)
|
||||
, Name(..)
|
||||
, Send(..)
|
||||
, Namespace(..)
|
||||
( module Data.Language.Ruby.AST
|
||||
) where
|
||||
|
||||
import Data.Aeson (parseJSON, Value(..), withArray)
|
||||
import Frelude
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Coerce
|
||||
import Data.Word
|
||||
|
||||
kebabCase :: String -> String
|
||||
kebabCase = Aeson.camelTo2 '-'
|
||||
|
||||
aesonOptions :: Aeson.Options
|
||||
aesonOptions = Aeson.defaultOptions
|
||||
{ Aeson.sumEncoding = Aeson.ObjectWithSingleField
|
||||
, Aeson.constructorTagModifier = kebabCase
|
||||
}
|
||||
|
||||
newtype Block = Block [Statement]
|
||||
|
||||
deriving stock instance Show Block
|
||||
deriving stock instance Ord Block
|
||||
deriving stock instance Eq Block
|
||||
deriving stock instance Generic Block
|
||||
instance ToJSON Block where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
deriving newtype instance Semigroup Block
|
||||
deriving newtype instance Monoid Block
|
||||
|
||||
instance FromJSON Block where
|
||||
parseJSON = withArray "Block" $ \as -> case Vector.toList as of
|
||||
(String "begin":xs) -> Block <$> traverse parseJSON xs
|
||||
_ -> Block . pure <$> parseJSON (Array as)
|
||||
|
||||
-- Should be 'expression'
|
||||
data Statement
|
||||
= StmtModule Module
|
||||
| StmtFunction Function
|
||||
| StmtSend Send
|
||||
| StmtRBlock RBlock
|
||||
-- TODO: We should also handle modules here. Otherwise we cannot
|
||||
-- cover the case where a function references a module.
|
||||
| StmtConst Namespace
|
||||
| StmtAnything Anything
|
||||
|
||||
deriving stock instance Show Statement
|
||||
deriving stock instance Ord Statement
|
||||
deriving stock instance Eq Statement
|
||||
deriving stock instance Generic Statement
|
||||
instance ToJSON Statement where
|
||||
toEncoding = Aeson.genericToEncoding opts
|
||||
where
|
||||
opts = aesonOptions { Aeson.constructorTagModifier = go }
|
||||
go = \case
|
||||
"StmtModule" -> "module"
|
||||
"StmtFunction" -> "function"
|
||||
"StmtSend" -> "send"
|
||||
"StmtRBlock" -> "block"
|
||||
"StmtConst" -> "const"
|
||||
x -> x
|
||||
|
||||
instance FromJSON Statement where
|
||||
parseJSON v
|
||||
= (StmtModule <$> parseJSON v)
|
||||
<|> (StmtFunction <$> parseJSON v)
|
||||
<|> (StmtSend <$> parseJSON v)
|
||||
<|> (StmtRBlock <$> parseJSON v)
|
||||
<|> (StmtConst <$> parseJSON v)
|
||||
<|> (StmtAnything <$> parseJSON v)
|
||||
|
||||
newtype Anything = Anything Value
|
||||
|
||||
deriving stock instance Show Anything
|
||||
instance Ord Anything where
|
||||
compare = coerce compareValue
|
||||
deriving stock instance Eq Anything
|
||||
deriving stock instance Generic Anything
|
||||
instance ToJSON Anything where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
deriving newtype instance FromJSON Anything
|
||||
|
||||
-- f do |x|
|
||||
-- expr
|
||||
-- end
|
||||
data RBlock = RBlock
|
||||
{ send :: Send
|
||||
, args :: Args
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show RBlock
|
||||
deriving stock instance Ord RBlock
|
||||
deriving stock instance Eq RBlock
|
||||
deriving stock instance Generic RBlock
|
||||
instance ToJSON RBlock where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
instance FromJSON RBlock where
|
||||
parseJSON = withArray "RBlock" $ \as -> case Vector.toList as of
|
||||
(String "block":send:args:block:[])
|
||||
-> RBlock
|
||||
<$> parseJSON send
|
||||
<*> parseJSON args
|
||||
<*> parseJSON block
|
||||
_ -> empty
|
||||
|
||||
newtype Namespace = Namespace [Name]
|
||||
|
||||
deriving newtype instance Semigroup Namespace
|
||||
deriving newtype instance Monoid Namespace
|
||||
deriving stock instance Show Namespace
|
||||
deriving stock instance Ord Namespace
|
||||
deriving stock instance Eq Namespace
|
||||
deriving stock instance Generic Namespace
|
||||
instance ToJSON Namespace where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Namespace where
|
||||
parseJSON = \case
|
||||
Null -> pure mempty
|
||||
Array [String "const", namespace, String name] -> (<> Namespace [Name $ String name]) <$> parseJSON namespace
|
||||
_ -> empty
|
||||
|
||||
data Send = Send
|
||||
{ args :: Args
|
||||
, namespace :: Namespace
|
||||
, name :: Name
|
||||
}
|
||||
|
||||
deriving stock instance Show Send
|
||||
deriving stock instance Ord Send
|
||||
deriving stock instance Eq Send
|
||||
deriving stock instance Generic Send
|
||||
instance ToJSON Send where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Send where
|
||||
parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
|
||||
(String "send" : namespace : name : args)
|
||||
-> Send
|
||||
<$> parseJSON (Array $ Vector.fromList args)
|
||||
<*> parseJSON namespace
|
||||
<*> parseJSON name
|
||||
_ -> empty
|
||||
|
||||
data Module = Module
|
||||
{ name :: Name
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show Module
|
||||
deriving stock instance Ord Module
|
||||
deriving stock instance Eq Module
|
||||
deriving stock instance Generic Module
|
||||
instance ToJSON Module where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Module where
|
||||
parseJSON = withArray "Module" $ \case
|
||||
[String "module", name, block]
|
||||
-> Module
|
||||
<$> parseJSON name
|
||||
<*> parseMaybe block
|
||||
[String "class", name, _, block]
|
||||
-> Module
|
||||
<$> parseJSON name
|
||||
<*> parseMaybe block
|
||||
_ -> empty
|
||||
|
||||
parseMaybe :: FromJSON m => Monoid m => Value -> Aeson.Parser m
|
||||
parseMaybe = \case
|
||||
Null -> pure mempty
|
||||
x -> parseJSON x
|
||||
|
||||
data Function = Function
|
||||
{ name :: Name
|
||||
, args :: Args
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show Function
|
||||
deriving stock instance Ord Function
|
||||
deriving stock instance Eq Function
|
||||
deriving stock instance Generic Function
|
||||
instance ToJSON Function where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
newtype Args = Args Anything
|
||||
|
||||
deriving stock instance Show Args
|
||||
instance Ord Args where
|
||||
compare = coerce compareValue
|
||||
deriving stock instance Eq Args
|
||||
deriving stock instance Generic Args
|
||||
instance ToJSON Args where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Args where
|
||||
parseJSON = pure . coerce
|
||||
|
||||
instance FromJSON Function where
|
||||
parseJSON = withArray "Function" $ \case
|
||||
[String "def", name, args, block]
|
||||
-> Function
|
||||
<$> parseJSON name
|
||||
<*> parseJSON args
|
||||
<*> parseMaybe block
|
||||
_ -> empty
|
||||
|
||||
newtype Name = Name Value
|
||||
|
||||
deriving stock instance Show Name
|
||||
instance Ord Name where
|
||||
compare = coerce compareValue
|
||||
deriving stock instance Eq Name
|
||||
deriving newtype instance ToJSON Name
|
||||
deriving newtype instance FromJSON Name
|
||||
|
||||
compareValue :: Aeson.Value -> Aeson.Value -> Ordering
|
||||
compareValue v0 v1 = case (v0, v1) of
|
||||
-- This case is buggy:
|
||||
(Object o0, Object o1) -> compare (fst <$> toList o0) (fst <$> toList o1)
|
||||
(Array a0, Array a1) -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
|
||||
(String s0, String s1) -> compare s0 s1
|
||||
(Number n0, Number n1) -> compare n0 n1
|
||||
(Bool b0, Bool b1) -> compare b0 b1
|
||||
(Null, Null) -> EQ
|
||||
_ -> (compare `on` cons) v0 v1
|
||||
where
|
||||
-- Enumerate constructors.
|
||||
cons :: Aeson.Value -> Word8
|
||||
cons = \case
|
||||
Object{} -> 0
|
||||
Array{} -> 1
|
||||
String{} -> 2
|
||||
Number{} -> 3
|
||||
Bool{} -> 4
|
||||
Null{} -> 5
|
||||
import Data.Language.Ruby.AST
|
||||
|
|
|
|||
248
src/Data/Language/Ruby/AST.hs
Normal file
248
src/Data/Language/Ruby/AST.hs
Normal file
|
|
@ -0,0 +1,248 @@
|
|||
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
module Data.Language.Ruby.AST
|
||||
( Args(..)
|
||||
, Block(..)
|
||||
, Statement(..)
|
||||
, Function(..)
|
||||
, Module(..)
|
||||
, Name(..)
|
||||
, Send(..)
|
||||
, Namespace(..)
|
||||
) where
|
||||
|
||||
import Data.Aeson (parseJSON, Value(..), withArray)
|
||||
import Frelude
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Coerce
|
||||
import Data.Word
|
||||
|
||||
kebabCase :: String -> String
|
||||
kebabCase = Aeson.camelTo2 '-'
|
||||
|
||||
aesonOptions :: Aeson.Options
|
||||
aesonOptions = Aeson.defaultOptions
|
||||
{ Aeson.sumEncoding = Aeson.ObjectWithSingleField
|
||||
, Aeson.constructorTagModifier = kebabCase
|
||||
}
|
||||
|
||||
newtype Block = Block [Statement]
|
||||
|
||||
deriving stock instance Show Block
|
||||
deriving stock instance Ord Block
|
||||
deriving stock instance Eq Block
|
||||
deriving stock instance Generic Block
|
||||
instance ToJSON Block where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
deriving newtype instance Semigroup Block
|
||||
deriving newtype instance Monoid Block
|
||||
|
||||
instance FromJSON Block where
|
||||
parseJSON = withArray "Block" $ \as -> case Vector.toList as of
|
||||
(String "begin":xs) -> Block <$> traverse parseJSON xs
|
||||
_ -> Block . pure <$> parseJSON (Array as)
|
||||
|
||||
-- Should be 'expression'
|
||||
data Statement
|
||||
= StmtModule Module
|
||||
| StmtFunction Function
|
||||
| StmtSend Send
|
||||
| StmtRBlock RBlock
|
||||
-- TODO: We should also handle modules here. Otherwise we cannot
|
||||
-- cover the case where a function references a module.
|
||||
| StmtConst Namespace
|
||||
| StmtAnything Anything
|
||||
|
||||
deriving stock instance Show Statement
|
||||
deriving stock instance Ord Statement
|
||||
deriving stock instance Eq Statement
|
||||
deriving stock instance Generic Statement
|
||||
instance ToJSON Statement where
|
||||
toEncoding = Aeson.genericToEncoding opts
|
||||
where
|
||||
opts = aesonOptions { Aeson.constructorTagModifier = go }
|
||||
go = \case
|
||||
"StmtModule" -> "module"
|
||||
"StmtFunction" -> "function"
|
||||
"StmtSend" -> "send"
|
||||
"StmtRBlock" -> "block"
|
||||
"StmtConst" -> "const"
|
||||
x -> x
|
||||
|
||||
instance FromJSON Statement where
|
||||
parseJSON v
|
||||
= (StmtModule <$> parseJSON v)
|
||||
<|> (StmtFunction <$> parseJSON v)
|
||||
<|> (StmtSend <$> parseJSON v)
|
||||
<|> (StmtRBlock <$> parseJSON v)
|
||||
<|> (StmtConst <$> parseJSON v)
|
||||
<|> (StmtAnything <$> parseJSON v)
|
||||
|
||||
newtype Anything = Anything Value
|
||||
|
||||
deriving stock instance Show Anything
|
||||
instance Ord Anything where
|
||||
compare = coerce compareValue
|
||||
deriving stock instance Eq Anything
|
||||
deriving stock instance Generic Anything
|
||||
instance ToJSON Anything where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
deriving newtype instance FromJSON Anything
|
||||
|
||||
-- f do |x|
|
||||
-- expr
|
||||
-- end
|
||||
data RBlock = RBlock
|
||||
{ send :: Send
|
||||
, args :: Args
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show RBlock
|
||||
deriving stock instance Ord RBlock
|
||||
deriving stock instance Eq RBlock
|
||||
deriving stock instance Generic RBlock
|
||||
instance ToJSON RBlock where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
instance FromJSON RBlock where
|
||||
parseJSON = withArray "RBlock" $ \as -> case Vector.toList as of
|
||||
(String "block":send:args:block:[])
|
||||
-> RBlock
|
||||
<$> parseJSON send
|
||||
<*> parseJSON args
|
||||
<*> parseJSON block
|
||||
_ -> empty
|
||||
|
||||
newtype Namespace = Namespace [Name]
|
||||
|
||||
deriving newtype instance Semigroup Namespace
|
||||
deriving newtype instance Monoid Namespace
|
||||
deriving stock instance Show Namespace
|
||||
deriving stock instance Ord Namespace
|
||||
deriving stock instance Eq Namespace
|
||||
deriving stock instance Generic Namespace
|
||||
instance ToJSON Namespace where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Namespace where
|
||||
parseJSON = \case
|
||||
Null -> pure mempty
|
||||
Array [String "const", namespace, String name] -> (<> Namespace [Name $ String name]) <$> parseJSON namespace
|
||||
_ -> empty
|
||||
|
||||
data Send = Send
|
||||
{ args :: Args
|
||||
, namespace :: Namespace
|
||||
, name :: Name
|
||||
}
|
||||
|
||||
deriving stock instance Show Send
|
||||
deriving stock instance Ord Send
|
||||
deriving stock instance Eq Send
|
||||
deriving stock instance Generic Send
|
||||
instance ToJSON Send where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Send where
|
||||
parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
|
||||
(String "send" : namespace : name : args)
|
||||
-> Send
|
||||
<$> parseJSON (Array $ Vector.fromList args)
|
||||
<*> parseJSON namespace
|
||||
<*> parseJSON name
|
||||
_ -> empty
|
||||
|
||||
data Module = Module
|
||||
{ name :: Name
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show Module
|
||||
deriving stock instance Ord Module
|
||||
deriving stock instance Eq Module
|
||||
deriving stock instance Generic Module
|
||||
instance ToJSON Module where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Module where
|
||||
parseJSON = withArray "Module" $ \case
|
||||
[String "module", name, block]
|
||||
-> Module
|
||||
<$> parseJSON name
|
||||
<*> parseMaybe block
|
||||
[String "class", name, _, block]
|
||||
-> Module
|
||||
<$> parseJSON name
|
||||
<*> parseMaybe block
|
||||
_ -> empty
|
||||
|
||||
parseMaybe :: FromJSON m => Monoid m => Value -> Aeson.Parser m
|
||||
parseMaybe = \case
|
||||
Null -> pure mempty
|
||||
x -> parseJSON x
|
||||
|
||||
data Function = Function
|
||||
{ name :: Name
|
||||
, args :: Args
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show Function
|
||||
deriving stock instance Ord Function
|
||||
deriving stock instance Eq Function
|
||||
deriving stock instance Generic Function
|
||||
instance ToJSON Function where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
newtype Args = Args Anything
|
||||
|
||||
deriving stock instance Show Args
|
||||
instance Ord Args where
|
||||
compare = coerce compareValue
|
||||
deriving stock instance Eq Args
|
||||
deriving stock instance Generic Args
|
||||
instance ToJSON Args where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Args where
|
||||
parseJSON = pure . coerce
|
||||
|
||||
instance FromJSON Function where
|
||||
parseJSON = withArray "Function" $ \case
|
||||
[String "def", name, args, block]
|
||||
-> Function
|
||||
<$> parseJSON name
|
||||
<*> parseJSON args
|
||||
<*> parseMaybe block
|
||||
_ -> empty
|
||||
|
||||
newtype Name = Name Value
|
||||
|
||||
deriving stock instance Show Name
|
||||
instance Ord Name where
|
||||
compare = coerce compareValue
|
||||
deriving stock instance Eq Name
|
||||
deriving newtype instance ToJSON Name
|
||||
deriving newtype instance FromJSON Name
|
||||
|
||||
compareValue :: Aeson.Value -> Aeson.Value -> Ordering
|
||||
compareValue v0 v1 = case (v0, v1) of
|
||||
-- This case is buggy:
|
||||
(Object o0, Object o1) -> compare (fst <$> toList o0) (fst <$> toList o1)
|
||||
(Array a0, Array a1) -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
|
||||
(String s0, String s1) -> compare s0 s1
|
||||
(Number n0, Number n1) -> compare n0 n1
|
||||
(Bool b0, Bool b1) -> compare b0 b1
|
||||
(Null, Null) -> EQ
|
||||
_ -> (compare `on` cons) v0 v1
|
||||
where
|
||||
-- Enumerate constructors.
|
||||
cons :: Aeson.Value -> Word8
|
||||
cons = \case
|
||||
Object{} -> 0
|
||||
Array{} -> 1
|
||||
String{} -> 2
|
||||
Number{} -> 3
|
||||
Bool{} -> 4
|
||||
Null{} -> 5
|
||||
Loading…
Reference in a new issue