Move AST to separate module

src/Data/Language/Ruby.hs

@@ -1,248 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
 {-# OPTIONS_GHC -Wall #-}
 module Data.Language.Ruby
-  ( Args(..)
+  ( module Data.Language.Ruby.AST
-  , Block(..)
-  , Statement(..)
-  , Function(..)
-  , Module(..)
-  , Name(..)
-  , Send(..)
-  , Namespace(..)
   ) where
 
-import Data.Aeson (parseJSON, Value(..), withArray)
+import Data.Language.Ruby.AST
-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

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