Move AST to separate module

This commit is contained in:
Frederik Hanghøj Iversen 2019-10-16 20:14:48 +02:00
parent 7a5cda2533
commit 33d7c2a26a
2 changed files with 250 additions and 243 deletions

View file

@ -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

View 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