From 33d7c2a26ae34f3bedf834c9635a8eb97d27b065 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 16 Oct 2019 20:14:48 +0200 Subject: [PATCH] Move AST to separate module --- src/Data/Language/Ruby.hs | 245 +-------------------------------- src/Data/Language/Ruby/AST.hs | 248 ++++++++++++++++++++++++++++++++++ 2 files changed, 250 insertions(+), 243 deletions(-) create mode 100644 src/Data/Language/Ruby/AST.hs diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs index b265928..4bee141 100644 --- a/src/Data/Language/Ruby.hs +++ b/src/Data/Language/Ruby.hs @@ -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 diff --git a/src/Data/Language/Ruby/AST.hs b/src/Data/Language/Ruby/AST.hs new file mode 100644 index 0000000..7bda1f1 --- /dev/null +++ b/src/Data/Language/Ruby/AST.hs @@ -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