fredefox/rubyhs
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Rename Block->Begin RBlock->Block

Browse source
This commit is contained in:
Frederik Hanghøj Iversen 2019-10-17 20:08:25 +02:00
parent 01c7503c05
commit a0c574b53a
3 changed files with 133 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

136
src/Data/Language/Ruby/AST.hs
View file

@ -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,8 +74,11 @@ instance ToJSON Statement where
"StmtModule" -> "module"
"StmtFunction" -> "function"
"StmtSend" -> "send"
"StmtRBlock" -> "block"
"StmtBlock" -> "block"
"StmtConst" -> "const"
"StmtCasgn" -> "casgn"
"StmtArray" -> "array"
"StmtSym" -> "sym"
x -> x
instance FromJSON Statement where
@ -81,7 +86,7 @@ instance FromJSON Statement where
= (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]
@ -211,7 +254,7 @@ instance FromJSON Send where
data Module = Module
{ 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
[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
@ -240,8 +283,8 @@ parseMaybe = \case
data Function = Function
{ name :: Name
, args :: Args
, block :: Block
, 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

17
src/Rubyhs.hs
View file

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

40
src/Rubyhs/References.hs
View file

@ -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
instance References Function where
entries Function{name, block} = do
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"
declaration $ NodeFunction $ qual namespace name
pure $ NodeFunction $ qual namespace name
instance References Function where
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