Rename Block->Begin RBlock->Block

src/Data/Language/Ruby/AST.hs

@@ -2,18 +2,19 @@
 {-# OPTIONS_GHC -Wall #-}
 module Data.Language.Ruby.AST
   ( Args(..)
-  , Block(..)
+  , Begin(..)
   , Statement(..)
   , Function(..)
   , Module(..)
   , Name(..)
   , Send(..)
   , Namespace(..)
-  , RBlock(..)
+  , Block(..)
   , Casgn(..)
   , RArray(..)
   , RArgs(..)
   , Anything(..)
+  , Sym(..)
   ) where
 
 import Data.Aeson (parseJSON, Value(..), withArray)
@@ -32,31 +33,32 @@ aesonOptions = Aeson.defaultOptions
   , Aeson.constructorTagModifier = kebabCase
   }
 
-newtype Block = Block [Statement]
+newtype Begin = Begin [Statement]
 
-deriving stock instance Show Block
+deriving stock instance Show Begin
-deriving stock instance Ord Block
+deriving stock instance Ord Begin
-deriving stock instance Eq Block
+deriving stock instance Eq Begin
-deriving stock instance Generic Block
+deriving stock instance Generic Begin
-instance ToJSON Block where
+instance ToJSON Begin where
   toEncoding = Aeson.genericToEncoding aesonOptions
-deriving newtype instance Semigroup Block
+deriving newtype instance Semigroup Begin
-deriving newtype instance Monoid Block
+deriving newtype instance Monoid Begin
 
-instance FromJSON Block where
+instance FromJSON Begin where
-  parseJSON = withArray "Block" $ \as -> case Vector.toList as of
+  parseJSON = withArray "Begin" $ \as -> case Vector.toList as of
-    (String "begin":xs) -> Block <$> traverse parseJSON xs
+    (String "begin":xs) -> Begin <$> traverse parseJSON xs
-    _ -> Block . pure <$> parseJSON (Array as)
+    _ -> Begin . pure <$> parseJSON (Array as)
 
 -- Should be 'expression'
 data Statement
   = StmtModule Module
   | StmtFunction Function
   | StmtSend Send
-  | StmtRBlock RBlock
+  | StmtBlock Block
   | StmtConst Namespace
   | StmtCasgn Casgn
   | StmtArray RArray
+  | StmtSym Sym
   -- TODO Get rid of this
   | StmtAnything Anything
 
@@ -72,16 +74,19 @@ instance ToJSON Statement where
       "StmtModule"   -> "module"
       "StmtFunction" -> "function"
       "StmtSend"     -> "send"
-      "StmtRBlock"   -> "block"
+      "StmtBlock"    -> "block"
       "StmtConst"    -> "const"
-      x             -> x
+      "StmtCasgn"    -> "casgn"
+      "StmtArray"    -> "array"
+      "StmtSym"      -> "sym"
+      x              -> x
 
 instance FromJSON Statement where
   parseJSON v
     =   (StmtModule   <$> parseJSON v)
     <|> (StmtFunction <$> parseJSON v)
     <|> (StmtSend     <$> parseJSON v)
-    <|> (StmtRBlock   <$> parseJSON v)
+    <|> (StmtBlock   <$> parseJSON v)
     <|> (StmtConst    <$> parseJSON v)
     <|> (StmtCasgn    <$> parseJSON v)
     <|> (StmtArray    <$> parseJSON v)
@@ -136,31 +141,31 @@ deriving newtype instance FromJSON Anything
 -- f do |x|
 --   expr
 -- end
-data RBlock = RBlock
+data Block = Block
   { send  :: Send
   , args  :: RArgs
-  , block :: Block
+  , begin :: Begin
   }
 
-deriving stock instance Show RBlock
+deriving stock instance Show Block
-deriving stock instance Ord RBlock
+deriving stock instance Ord Block
-deriving stock instance Eq RBlock
+deriving stock instance Eq Block
-deriving stock instance Generic RBlock
+deriving stock instance Generic Block
-instance ToJSON RBlock where
+instance ToJSON Block where
   toEncoding = Aeson.genericToEncoding aesonOptions
-instance FromJSON RBlock where
+instance FromJSON Block where
-  parseJSON = withArray "RBlock" $ \as -> case Vector.toList as of
+  parseJSON = withArray "Block" $ \as -> case Vector.toList as of
-    (String "block":send:args:block:[])
+    (String "block":send:args:begin:[])
-      ->  RBlock
+      ->  Block
       <$> parseJSON send
       <*> parseJSON args
-      <*> parseJSON block
+      <*> parseJSON begin
     _ -> empty
 
 -- | It's super confusing that I've already defined a node in my AST
 -- called args.  This one correspond to the AST node with the label
 -- "args" as reported by `ruby-parse`.
-newtype RArgs = RArgs Anything
+newtype RArgs = RArgs [Arg]
 
 deriving stock instance Show RArgs
 deriving stock instance Ord RArgs
@@ -168,7 +173,45 @@ deriving stock instance Eq RArgs
 deriving stock instance Generic RArgs
 instance ToJSON RArgs where
   toEncoding = Aeson.genericToEncoding aesonOptions
-deriving newtype instance FromJSON RArgs
+instance FromJSON RArgs where
+  parseJSON = withArray "RArgs" $ \as -> case Vector.toList as of
+    (String "args":xs) -> RArgs <$> traverse parseJSON xs
+    _ -> empty
+
+data Arg = Arg Atom | KWArg Atom
+
+deriving stock instance Show Arg
+deriving stock instance Ord Arg
+deriving stock instance Eq Arg
+deriving stock instance Generic Arg
+instance ToJSON Arg where
+  toEncoding = Aeson.genericToEncoding opts
+    where
+    opts = aesonOptions { Aeson.constructorTagModifier = go }
+    go = \case
+      "KWArg" -> "kwarg"
+      "Arg"   -> "arg"
+      x       -> x
+
+instance FromJSON Arg where
+  parseJSON = withArray "Arg" $ \as -> case Vector.toList as of
+    [String "arg"   , symbol] -> Arg   <$> parseJSON symbol
+    [String "kwarg" , symbol] -> KWArg <$> parseJSON symbol
+    _ -> empty
+
+newtype Atom = Atom Text
+
+deriving stock instance Show Atom
+deriving stock instance Ord Atom
+deriving stock instance Eq Atom
+deriving stock instance Generic Atom
+instance ToJSON Atom where
+  toEncoding = Aeson.genericToEncoding aesonOptions
+
+instance FromJSON Atom where
+  parseJSON = \case
+    String s -> pure $ Atom s
+    _ -> empty
 
 newtype Namespace = Namespace [Name]
 
@@ -210,8 +253,8 @@ instance FromJSON Send where
     _ -> empty
 
 data Module = Module
-  { name :: Name
+  { name  :: Name
-  , block :: Block
+  , begin :: Begin
   }
 
 deriving stock instance Show Module
@@ -223,14 +266,14 @@ instance ToJSON Module where
 
 instance FromJSON Module where
   parseJSON = withArray "Module" $ \case
-    [String "module", name, block]
+    [String "module", name, begin]
       ->  Module
       <$> parseJSON name
-      <*> parseMaybe block
+      <*> parseMaybe begin
-    [String "class", name, _, block]
+    [String "class", name, _, begin]
       ->  Module
       <$> parseJSON name
-      <*> parseMaybe block
+      <*> parseMaybe begin
     _ -> empty
 
 parseMaybe :: FromJSON m => Monoid m => Value -> Aeson.Parser m
@@ -239,9 +282,9 @@ parseMaybe = \case
   x -> parseJSON x
 
 data Function = Function
-  { name :: Name
+  { name  :: Name
-  , args :: Args
+  , args  :: RArgs
-  , block :: Block
+  , begin :: Begin
   }
 
 deriving stock instance Show Function
@@ -265,11 +308,11 @@ instance FromJSON Args where
 
 instance FromJSON Function where
   parseJSON = withArray "Function" $ \case
-    [String "def", name, args, block]
+    [String "def", name, args, begin]
       ->  Function
       <$> parseJSON name
       <*> parseJSON args
-      <*> parseMaybe block
+      <*> parseMaybe begin
     _ -> empty
 
 newtype Name = Name Value
@@ -301,3 +344,16 @@ compareValue v0 v1 = case (v0, v1) of
       Number{} -> 3
       Bool{}   -> 4
       Null{}   -> 5
+
+newtype Sym = Sym Atom
+
+deriving stock instance Show Sym
+deriving newtype instance Ord Sym
+deriving stock instance Eq Sym
+deriving stock instance Generic Sym
+instance ToJSON Sym where
+  toEncoding = Aeson.genericToEncoding aesonOptions
+instance FromJSON Sym where
+  parseJSON = withArray "Sym" $ \case
+    [String "sym", atom] -> Sym <$> parseJSON atom
+    _ -> empty

src/Rubyhs.hs

@@ -3,7 +3,6 @@
 module Rubyhs (main) where
 
 import Data.Foldable (traverse_)
-import Data.Language.Ruby (Block)
 import Data.Map (Map)
 import Data.Set (Set)
 import Data.Tree (Tree(Node), Forest)
@@ -15,17 +14,17 @@ import qualified Data.Graphviz as Graphviz
 import qualified Data.Language.Ruby as Ruby
 import qualified Data.Text.IO as Text
 import qualified Options.Applicative as Options
-import qualified Rubyhs.References
+import qualified Rubyhs.References as Ruby
 
 main :: IO ()
 main = do
   Command{targets, printAST, maybeDotPath} <- getCommand
-  blocks <- parseInput @Block targets
+  blocks <- parseInput @Ruby.Begin targets
   let
     act block = do
-      let res@(Rubyhs.References.Result x) = Rubyhs.References.references $ block
+      let res@(Ruby.Result x) = Ruby.references $ block
       putEncoded res
-      ByteString.putStrLn . Aeson.encode . toJSONForest . Rubyhs.References.graph $ block
+      ByteString.putStrLn . Aeson.encode . toJSONForest . Ruby.graph $ block
       case maybeDotPath of
         Nothing -> pure ()
         Just dotPath -> drawDot dotPath x
@@ -33,20 +32,20 @@ main = do
   then traverse_ @[] putEncoded blocks
   else traverse_ act blocks
 
-drawDot :: FilePath -> Map Rubyhs.References.Node (Set Rubyhs.References.Node)  -> IO ()
+drawDot :: FilePath -> Map Ruby.Node (Set Ruby.Node)  -> IO ()
 drawDot p
   = Text.writeFile p
   . Graphviz.digraph
-  . fmap (fmap (qoutes . Rubyhs.References.prettyContext) . \(x, xs) -> x :| toList xs)
+  . fmap (fmap (qoutes . Ruby.prettyContext) . \(x, xs) -> x :| toList xs)
   . toList
 
 qoutes :: Text -> Text
 qoutes x = "\"" <> x <> "\""
 
-toJSONForest :: Forest Rubyhs.References.Node -> Aeson.Value
+toJSONForest :: Forest Ruby.Node -> Aeson.Value
 toJSONForest = Aeson.Object . fromList . fmap go
   where
-  go (Node x xs) = (Rubyhs.References.prettyContext x, toJSONForest xs)
+  go (Node x xs) = (Ruby.prettyContext x, toJSONForest xs)
 
 -- | If arguments is non-empty treat all arguments as filepaths and
 -- parse the modules at those locations.  If there are no arguments,

src/Rubyhs/References.hs

@@ -34,7 +34,7 @@ span (g, f, _) = fmap ((\(x, _, _) -> x) . f) <$> Graph.dff g
 
 type G node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
 
-graph :: Block -> Forest Node
+graph :: Begin -> Forest Node
 graph b = span $ Graph.graphFromEdges $ go <$> toList ys
   where
   go :: (Node, Set Node) -> (Node, Text, [Text])
@@ -171,16 +171,16 @@ name2ns (Name o) = go o
 class References a where
   entries :: MyMonad m => a -> m ()
 
-references :: Block -> Result
+references :: Begin -> Result
 references q = Result $ Map.unionWith mappend applications declarations'
   where
   Env{declarations,applications} = execState (entries @_ @(State Env) q) emptyEnv
   emptyEnv = Env mempty mempty (Context $ NodeModule mempty)
   declarations' = fromList $ (\x -> (x, mempty)) <$> toList declarations
 
-instance References Block where
+instance References Begin where
-  entries :: forall m . MyMonad m => Block -> m ()
+  entries :: forall m . MyMonad m => Begin -> m ()
-  entries (Block defs) = traverse_ (locally . entries) defs
+  entries (Begin defs) = traverse_ (locally . entries) defs
 
 instance References Statement where
   entries = \case
@@ -188,22 +188,25 @@ instance References Statement where
     StmtFunction f -> entries f
     StmtSend s     -> entries s
     StmtConst c    -> entries c
-    StmtRBlock b   -> entries b
+    StmtBlock b   -> entries b
     StmtCasgn c    -> entries c
     StmtArray a    -> entries a
+    StmtSym s      -> entries s
     StmtAnything a -> entries a
 
-instance References Ruby.RBlock where
+instance References Ruby.Block where
-  entries RBlock{send,args,block} = do
+  entries Block{send,args,begin} = do
     entries send
     entries args
-    entries block
+    entries begin
 instance References Ruby.RArgs where
   entries = const $ pure ()
 -- TODO: We have to make a "declaration" for the constant here as
 -- well!
 instance References Ruby.Casgn where
   entries Casgn{name, statement} = entries statement
+instance References Ruby.Sym where
+  entries _ = pure ()
 instance References Ruby.RArray where
   entries RArray{statements} = traverse_ entries statements
 instance References Ruby.Anything where
@@ -223,23 +226,28 @@ instance References Ruby.Namespace where
     application (NodeModule $ ns)
 
 instance References Module where
-  entries Module{name, block} = do
+  entries Module{name, begin} = do
     appendToContext name
     c <- getContext >>= \case
       Context (NodeModule c) -> pure c
       _ -> error "..."
     declaration $ NodeModule c
-    entries block
+    entries begin
+
+nameToNode :: MyMonad m => Name -> m Node
+nameToNode name = do
+  namespace <- getContext >>= \case
+    Context (NodeModule c) -> pure c
+    Context NodeFunction{} -> error "Cannot have a function declaration in a function context"
+  pure $ NodeFunction $ qual namespace name
 
 instance References Function where
-  entries Function{name, block} = do
+  entries Function{name, begin} = do
-    namespace <- getContext >>= \case
+    node <- nameToNode name
-      Context (NodeModule c) -> pure c
+    declaration node
-      Context NodeFunction{} -> error "Cannot have a function declaration in a function context"
-    declaration $ NodeFunction $ qual namespace name
     locally $ do
-      writeContext (Context $ NodeFunction $ qual namespace name)
+      writeContext (Context node)
-      entries block
+      entries begin
 
 qual :: Namespace -> Name -> FQN
 qual namespace (Name o) = case o of