diff --git a/src/Data/Language/Ruby/AST.hs b/src/Data/Language/Ruby/AST.hs index 3bac700..64a82ea 100644 --- a/src/Data/Language/Ruby/AST.hs +++ b/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 Ord Block -deriving stock instance Eq Block -deriving stock instance Generic Block -instance ToJSON Block where +deriving stock instance Show Begin +deriving stock instance Ord Begin +deriving stock instance Eq Begin +deriving stock instance Generic Begin +instance ToJSON Begin where toEncoding = Aeson.genericToEncoding aesonOptions -deriving newtype instance Semigroup Block -deriving newtype instance Monoid Block +deriving newtype instance Semigroup Begin +deriving newtype instance Monoid Begin -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) +instance FromJSON Begin where + parseJSON = withArray "Begin" $ \as -> case Vector.toList as of + (String "begin":xs) -> Begin <$> traverse parseJSON xs + _ -> 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 Ord RBlock -deriving stock instance Eq RBlock -deriving stock instance Generic RBlock -instance ToJSON RBlock where +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 -instance FromJSON RBlock where - parseJSON = withArray "RBlock" $ \as -> case Vector.toList as of - (String "block":send:args:block:[]) - -> RBlock +instance FromJSON Block where + parseJSON = withArray "Block" $ \as -> case Vector.toList as of + (String "block":send:args:begin:[]) + -> 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 - , block :: Block + { name :: Name + , 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 - [String "class", name, _, block] + <*> parseMaybe begin + [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 - , args :: Args - , block :: Block + { name :: Name + , args :: RArgs + , 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 diff --git a/src/Rubyhs.hs b/src/Rubyhs.hs index 698ed63..6696186 100644 --- a/src/Rubyhs.hs +++ b/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, diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index 37e0c9b..43afc35 100644 --- a/src/Rubyhs/References.hs +++ b/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 - entries :: forall m . MyMonad m => Block -> m () - entries (Block defs) = traverse_ (locally . entries) defs +instance References Begin where + entries :: forall m . MyMonad m => Begin -> m () + 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 - entries RBlock{send,args,block} = do +instance References Ruby.Block where + 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 - namespace <- getContext >>= \case - Context (NodeModule c) -> pure c - Context NodeFunction{} -> error "Cannot have a function declaration in a function context" - declaration $ NodeFunction $ qual namespace name + entries Function{name, begin} = do + node <- nameToNode name + declaration node locally $ do - writeContext (Context $ NodeFunction $ qual namespace name) - entries block + writeContext (Context node) + entries begin qual :: Namespace -> Name -> FQN qual namespace (Name o) = case o of