Major overhaul

Can now parse a much larger part of the language.  The reference
finding mechanism now seems more robust / less hacky.  Bugs remain, however!
This commit is contained in:
Frederik Hanghøj Iversen 2019-10-17 23:28:40 +02:00
parent a0c574b53a
commit f8163f99c7
3 changed files with 369 additions and 208 deletions

View file

@ -9,7 +9,8 @@ module Data.Language.Ruby
import Data.Aeson (eitherDecode)
import Data.ByteString.Lazy (ByteString)
import Data.Language.Ruby.AST
import Frelude
import Frelude hiding (String)
import qualified Frelude
import System.IO (hFlush)
import System.IO.Temp (withSystemTempFile)
import System.Process (readProcess)
@ -20,16 +21,16 @@ decodeFail s = case eitherDecode s of
Left err -> Frelude.fail err
Right a -> pure a
runRubyParseFile :: FilePath -> IO String
runRubyParseFile :: FilePath -> IO Frelude.String
runRubyParseFile p = sh "ruby-parse" ["--emit-json", "--25", p]
runRubyParse :: ByteString -> IO String
runRubyParse :: ByteString -> IO Frelude.String
runRubyParse s = withSystemTempFile "rubyhs" $ \p h -> do
ByteString.hPut h s
hFlush h
runRubyParseFile p
sh :: String -> [String] -> IO String
sh :: Frelude.String -> [Frelude.String] -> IO Frelude.String
sh cmd a = readProcess cmd a mempty
parseFile :: FromJSON a => FilePath -> IO a

View file

@ -1,30 +1,39 @@
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
{-# OPTIONS_GHC -Wall #-}
module Data.Language.Ruby.AST
( Args(..)
, Begin(..)
( Begin(..)
, Statement(..)
, Function(..)
, Def(..)
, Module(..)
, Name(..)
, Send(..)
, Namespace(..)
, Const(..)
, Block(..)
, Casgn(..)
, RArray(..)
, RArgs(..)
, Array(..)
, Args(..)
, Anything(..)
, Sym(..)
, String(..)
, Str(..)
, Lvasgn(..)
, Lvar(..)
, Ivar(..)
, Atom(..)
, Defs(..)
, Self(..)
, Nil(..)
, Cbase
) where
import Data.Aeson (parseJSON, Value(..), withArray)
import Frelude
import Data.Aeson (parseJSON, Value(Null,Object,Number,Bool), withArray)
import Frelude hiding (String)
import qualified Frelude
import qualified Data.Aeson.Types as Aeson
import qualified Data.Vector as Vector
import Data.Coerce
import Data.Word
kebabCase :: String -> String
kebabCase :: Frelude.String -> Frelude.String
kebabCase = Aeson.camelTo2 '-'
aesonOptions :: Aeson.Options
@ -46,19 +55,27 @@ deriving newtype instance Monoid Begin
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)
(Aeson.String "begin":xs) -> Begin <$> traverse parseJSON xs
_ -> Begin . pure <$> parseJSON (Aeson.Array as)
-- Should be 'expression'
data Statement
= StmtModule Module
| StmtFunction Function
| StmtDef Def
| StmtDefs Defs
| StmtSend Send
| StmtBlock Block
| StmtConst Namespace
| StmtConst Const
| StmtCasgn Casgn
| StmtArray RArray
| StmtArray Array
| StmtSym Sym
| StmtStr Str
| StmtLvasgn Lvasgn
| StmtLvar Lvar
| StmtIvar Ivar
| StmtSelf Self
| StmtNil Nil
| StmtCbase Cbase
-- TODO Get rid of this
| StmtAnything Anything
@ -72,29 +89,47 @@ instance ToJSON Statement where
opts = aesonOptions { Aeson.constructorTagModifier = go }
go = \case
"StmtModule" -> "module"
"StmtFunction" -> "function"
"StmtDef" -> "def"
"StmtDefs" -> "defs"
"StmtSend" -> "send"
"StmtBlock" -> "block"
"StmtConst" -> "const"
"StmtCasgn" -> "casgn"
"StmtArray" -> "array"
"StmtSym" -> "sym"
"StmtStr" -> "str"
"StmtLvasgn" -> "lvasgn"
"StmtLvar" -> "lvar"
"StmtIvar" -> "ivar"
"StmtSelf" -> "self"
"StmtNil" -> "nil"
"StmtCbase" -> "cbase"
x -> x
instance FromJSON Statement where
parseJSON v
= (StmtModule <$> parseJSON v)
<|> (StmtFunction <$> parseJSON v)
<|> (StmtDef <$> parseJSON v)
<|> (StmtDefs <$> parseJSON v)
<|> (StmtSend <$> parseJSON v)
<|> (StmtBlock <$> parseJSON v)
<|> (StmtBlock <$> parseJSON v)
<|> (StmtConst <$> parseJSON v)
<|> (StmtCasgn <$> parseJSON v)
<|> (StmtArray <$> parseJSON v)
<|> (StmtSym <$> parseJSON v)
<|> (StmtStr <$> parseJSON v)
<|> (StmtLvasgn <$> parseJSON v)
<|> (StmtLvar <$> parseJSON v)
<|> (StmtIvar <$> parseJSON v)
<|> (StmtSelf <$> parseJSON v)
<|> (StmtNil <$> parseJSON v)
<|> (StmtCbase <$> parseJSON v)
<|> (StmtAnything <$> parseJSON v)
data Casgn = Casgn
{ name :: Name
, statement :: Statement
{ context :: Statement
, atom :: Atom
, rhs :: Statement
}
deriving stock instance Show Casgn
deriving stock instance Ord Casgn
@ -104,26 +139,27 @@ instance ToJSON Casgn where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Casgn where
parseJSON = withArray "Module" $ \case
[String "casgn", _, name, statement]
[Aeson.String "casgn", context, atom, rhs]
-> Casgn
<$> parseJSON name
<*> parseJSON statement
<$> parseJSON context
<*> parseJSON atom
<*> parseJSON rhs
_ -> empty
data RArray = RArray
data Array = Array
{ statements :: [Statement]
}
deriving stock instance Show RArray
deriving stock instance Ord RArray
deriving stock instance Eq RArray
deriving stock instance Generic RArray
instance ToJSON RArray where
deriving stock instance Show Array
deriving stock instance Ord Array
deriving stock instance Eq Array
deriving stock instance Generic Array
instance ToJSON Array where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON RArray where
parseJSON = withArray "RArray" $ \as -> case Vector.toList as of
String "array":xs
-> RArray
instance FromJSON Array where
parseJSON = withArray "Array" $ \as -> case Vector.toList as of
Aeson.String "array":xs
-> Array
<$> traverse parseJSON xs
_ -> empty
@ -143,7 +179,7 @@ deriving newtype instance FromJSON Anything
-- end
data Block = Block
{ send :: Send
, args :: RArgs
, args :: Args
, begin :: Begin
}
@ -155,7 +191,7 @@ instance ToJSON Block where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Block where
parseJSON = withArray "Block" $ \as -> case Vector.toList as of
(String "block":send:args:begin:[])
[Aeson.String "block",send,args,begin]
-> Block
<$> parseJSON send
<*> parseJSON args
@ -165,17 +201,17 @@ instance FromJSON Block where
-- | 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 [Arg]
newtype Args = Args [Arg]
deriving stock instance Show RArgs
deriving stock instance Ord RArgs
deriving stock instance Eq RArgs
deriving stock instance Generic RArgs
instance ToJSON RArgs where
deriving stock instance Show Args
deriving stock instance Ord Args
deriving stock instance Eq Args
deriving stock instance Generic Args
instance ToJSON Args where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON RArgs where
parseJSON = withArray "RArgs" $ \as -> case Vector.toList as of
(String "args":xs) -> RArgs <$> traverse parseJSON xs
instance FromJSON Args where
parseJSON = withArray "Args" $ \as -> case Vector.toList as of
(Aeson.String "args":xs) -> Args <$> traverse parseJSON xs
_ -> empty
data Arg = Arg Atom | KWArg Atom
@ -195,8 +231,8 @@ instance ToJSON Arg where
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
[Aeson.String "arg" , symbol] -> Arg <$> parseJSON symbol
[Aeson.String "kwarg" , symbol] -> KWArg <$> parseJSON symbol
_ -> empty
newtype Atom = Atom Text
@ -210,30 +246,30 @@ instance ToJSON Atom where
instance FromJSON Atom where
parseJSON = \case
String s -> pure $ Atom s
Aeson.String s -> pure $ Atom s
_ -> empty
newtype Namespace = Namespace [Name]
data Const = Const
{ context :: Statement
, atom :: Atom
}
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
deriving stock instance Show Const
deriving stock instance Ord Const
deriving stock instance Eq Const
deriving stock instance Generic Const
instance ToJSON Const 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
instance FromJSON Const where
parseJSON = withArray "Send" $ \case -- \ as -> case Vector.toList as of
[Aeson.String "const", context, atom] -> Const <$> parseJSON context <*> parseJSON atom
_ -> empty
data Send = Send
{ args :: Args
, namespace :: Namespace
, name :: Name
{ context :: Statement
, atom :: Atom
, args :: [Statement]
}
deriving stock instance Show Send
@ -245,15 +281,15 @@ instance ToJSON Send where
instance FromJSON Send where
parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
(String "send" : namespace : name : args)
(Aeson.String "send" : context : atom : args)
-> Send
<$> parseJSON (Array $ Vector.fromList args)
<*> parseJSON namespace
<*> parseJSON name
<$> parseJSON context
<*> parseJSON atom
<*> parseJSON (Aeson.Array $ Vector.fromList args)
_ -> empty
data Module = Module
{ name :: Name
{ name :: Const
, begin :: Begin
}
@ -266,11 +302,11 @@ instance ToJSON Module where
instance FromJSON Module where
parseJSON = withArray "Module" $ \case
[String "module", name, begin]
[Aeson.String "module", name, begin]
-> Module
<$> parseJSON name
<*> parseMaybe begin
[String "class", name, _, begin]
[Aeson.String "class", name, _, begin]
-> Module
<$> parseJSON name
<*> parseMaybe begin
@ -281,55 +317,67 @@ parseMaybe = \case
Null -> pure mempty
x -> parseJSON x
data Function = Function
{ name :: Name
, args :: RArgs
data Def = Def
{ atom :: Atom
, args :: Args
, begin :: Begin
}
deriving stock instance Show Function
deriving stock instance Ord Function
deriving stock instance Eq Function
deriving stock instance Generic Function
instance ToJSON Function where
deriving stock instance Show Def
deriving stock instance Ord Def
deriving stock instance Eq Def
deriving stock instance Generic Def
instance ToJSON Def where
toEncoding = Aeson.genericToEncoding aesonOptions
data Args = Args [Statement]
deriving stock instance Show Args
deriving stock instance Ord Args
deriving stock instance Eq Args
deriving stock instance Generic Args
instance ToJSON Args where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Args where
parseJSON = withArray "Args" $ \xs -> Args <$> traverse parseJSON (toList xs)
instance FromJSON Function where
parseJSON = withArray "Function" $ \case
[String "def", name, args, begin]
-> Function
instance FromJSON Def where
parseJSON = withArray "Def" $ \case
[Aeson.String "def", name, args, begin]
-> Def
<$> parseJSON name
<*> parseJSON args
<*> parseMaybe begin
_ -> empty
newtype Name = Name Value
-- | N.B.: 'Defs' is not meant to be the plural form of 'Def'!
data Defs = Defs
-- Is it really possible to put an arbitrary expression here? The
-- parser certainly allows it. E.g. defining
--
-- def (2+2).f
-- end
--
-- Raises the error "can't define singleton (TypeError)". We'll
-- permit it in the parser and kick the puck down the road.
{ context :: Statement
, atom :: Atom
, args :: Args
, begin :: Begin
}
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
deriving stock instance Show Defs
deriving stock instance Ord Defs
deriving stock instance Eq Defs
deriving stock instance Generic Defs
instance ToJSON Defs where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Defs where
parseJSON = withArray "Defs" $ \case
[Aeson.String "defs", ctxt, atom, args, begin]
-> Defs
<$> parseJSON ctxt
<*> parseJSON atom
<*> parseJSON args
<*> parseMaybe begin
_ -> empty
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
(Aeson.Array a0, Aeson.Array a1) -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
(Aeson.String s0, Aeson.String s1) -> compare s0 s1
(Number n0, Number n1) -> compare n0 n1
(Bool b0, Bool b1) -> compare b0 b1
(Null, Null) -> EQ
@ -339,8 +387,8 @@ compareValue v0 v1 = case (v0, v1) of
cons :: Aeson.Value -> Word8
cons = \case
Object{} -> 0
Array{} -> 1
String{} -> 2
Aeson.Array{} -> 1
Aeson.String{} -> 2
Number{} -> 3
Bool{} -> 4
Null{} -> 5
@ -355,5 +403,113 @@ instance ToJSON Sym where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Sym where
parseJSON = withArray "Sym" $ \case
[String "sym", atom] -> Sym <$> parseJSON atom
[Aeson.String "sym", atom] -> Sym <$> parseJSON atom
_ -> empty
newtype String = String Text
deriving stock instance Show String
deriving newtype instance Ord String
deriving stock instance Eq String
deriving stock instance Generic String
deriving newtype instance ToJSON String
deriving newtype instance FromJSON String
newtype Str = Str String
deriving stock instance Show Str
deriving newtype instance Ord Str
deriving stock instance Eq Str
deriving stock instance Generic Str
instance ToJSON Str where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Str where
parseJSON = withArray "Str" $ \case
[Aeson.String "str", atom] -> Str <$> parseJSON atom
_ -> empty
data Lvasgn = Lvasgn
{ atom :: Atom
, statement :: Statement
}
deriving stock instance Show Lvasgn
deriving stock instance Ord Lvasgn
deriving stock instance Eq Lvasgn
deriving stock instance Generic Lvasgn
instance ToJSON Lvasgn where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Lvasgn where
parseJSON = withArray "Lvasgn" $ \case
[Aeson.String "lvasgn", atom, statement] -> Lvasgn <$> parseJSON atom <*> parseJSON statement
_ -> empty
data Lvar = Lvar
{ atom :: Atom
}
deriving stock instance Show Lvar
deriving stock instance Ord Lvar
deriving stock instance Eq Lvar
deriving stock instance Generic Lvar
instance ToJSON Lvar where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Lvar where
parseJSON = withArray "Lvar" $ \case
[Aeson.String "lvar", atom] -> Lvar <$> parseJSON atom
_ -> empty
data Ivar = Ivar
{ atom :: Atom
}
deriving stock instance Show Ivar
deriving stock instance Ord Ivar
deriving stock instance Eq Ivar
deriving stock instance Generic Ivar
instance ToJSON Ivar where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Ivar where
parseJSON = withArray "Ivar" $ \case
[Aeson.String "ivar", atom] -> Ivar <$> parseJSON atom
_ -> empty
data Self = Self
deriving stock instance Show Self
deriving stock instance Ord Self
deriving stock instance Eq Self
deriving stock instance Generic Self
instance ToJSON Self where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Self where
parseJSON = withArray "Self" $ \case
[Aeson.String "self"] -> pure Self
_ -> empty
data Cbase = Cbase
deriving stock instance Show Cbase
deriving stock instance Ord Cbase
deriving stock instance Eq Cbase
deriving stock instance Generic Cbase
instance ToJSON Cbase where
toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Cbase where
parseJSON = withArray "Cbase" $ \case
[Aeson.String "cbase"] -> pure Cbase
_ -> empty
data Nil = Nil
deriving stock instance Show Nil
deriving stock instance Ord Nil
deriving stock instance Eq Nil
deriving stock instance Generic Nil
instance ToJSON Nil where
toJSON = pure Aeson.Null
instance FromJSON Nil where
parseJSON = \case
Aeson.Null -> pure Nil
_ -> empty

View file

@ -1,13 +1,11 @@
{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-}
-- {-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wall #-}
module Rubyhs.References
( References(entries)
, Entry(..)
, FQN(..)
, references
, Env(..)
, Result(..)
, Namespace(..)
, Context(..)
, graph
, prettyContext
@ -15,7 +13,7 @@ module Rubyhs.References
) where
import Frelude
import Data.Language.Ruby hiding (Namespace)
-- import Data.Language.Ruby hiding (context)
import qualified Data.Language.Ruby as Ruby
import Data.Map (Map)
import qualified Data.Map as Map
@ -34,18 +32,13 @@ span (g, f, _) = fmap ((\(x, _, _) -> x) . f) <$> Graph.dff g
type G node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graph :: Begin -> Forest Node
graph :: Ruby.Begin -> Forest Node
graph b = span $ Graph.graphFromEdges $ go <$> toList ys
where
go :: (Node, Set Node) -> (Node, Text, [Text])
go (x, xs) = (x, prettyContext x, prettyContext <$> toList xs)
Result ys = references b
data Entry a = Entry
{ node :: a
, fqn :: FQN
}
newtype Namespace = Namespace [Text]
deriving stock instance Show Namespace
deriving stock instance Eq Namespace
@ -68,7 +61,7 @@ data FQN = FQN
, name :: Text
}
data Node = NodeFunction FQN | NodeModule Namespace
data Node = NodeDef FQN | NodeModule Namespace
deriving stock instance Show Node
deriving stock instance Eq Node
@ -76,7 +69,7 @@ deriving stock instance Ord Node
instance ToJSON Node where
toJSON = \case
NodeFunction q -> Aeson.toJSON q
NodeDef q -> Aeson.toJSON q
NodeModule m -> Aeson.toJSON m
deriving stock instance Show FQN
@ -101,6 +94,13 @@ newtype Context = Context Node
deriving stock instance Eq Context
deriving stock instance Ord Context
deriving newtype instance ToJSON Context
-- HACK: Not really a semigroup as is evident from the implementation.
instance Semigroup Context where
Context c0 <> Context c1 = case (c0, c1) of
(NodeModule n0, NodeModule n1) -> Context $ NodeModule $ n0 <> n1
(NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n0 <> n1) f
(NodeDef{}, NodeModule{}) -> error "Cannot append module to function context."
(NodeDef{}, NodeDef{}) -> error "Cannot append function to function context."
class Monad m => MyMonad (m :: Type -> Type) where
declaration :: Node -> m ()
@ -123,7 +123,7 @@ instance ToJSON Result where
prettyContext :: Node -> Text
prettyContext = \case
NodeFunction fun -> prettyFQN fun
NodeDef fun -> prettyFQN fun
NodeModule ns -> showNamespace ns
instance MyMonad (State Env) where
@ -137,13 +137,10 @@ instance MyMonad (State Env) where
go env@Env{applications}
= env { applications = Map.insertWith mappend c (Set.singleton n) applications }
modify go
getContext = gets context
getContext = gets Rubyhs.References.context
writeContext q = modify go
where
go env = env { context = q }
updateContext :: MyMonad m => (Context -> Context) -> m ()
updateContext f = getContext >>= \c -> writeContext (f c)
go env = env { Rubyhs.References.context = q }
locally :: MyMonad m => m a -> m a
locally act = do
@ -152,128 +149,135 @@ locally act = do
writeContext old
pure res
appendToContext :: MyMonad m => Name -> m ()
appendToContext n = updateContext go
where
go (Context (NodeModule q)) = Context $ NodeModule $ name2ns n <> q
go (Context NodeFunction{}) = error "Cannot append module to context in function context"
name2ns :: Name -> Namespace
name2ns (Name o) = go o
where
go :: Aeson.Value -> Namespace
go = \case
Aeson.Array [Aeson.String "const", x, Aeson.String s] -> case x of
Aeson.Null -> [s]
_ -> go x <> [s]
_ -> error $ show o
class References a where
entries :: MyMonad m => a -> m ()
references :: Begin -> Result
references :: Ruby.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 Begin where
entries :: forall m . MyMonad m => Begin -> m ()
entries (Begin defs) = traverse_ (locally . entries) defs
instance References Ruby.Begin where
entries :: forall m . MyMonad m => Ruby.Begin -> m ()
entries (Ruby.Begin defs) = traverse_ (locally . entries) defs
instance References Statement where
instance References Ruby.Statement where
entries = \case
StmtModule m -> entries m
StmtFunction f -> entries f
StmtSend s -> entries s
StmtConst c -> entries c
StmtBlock b -> entries b
StmtCasgn c -> entries c
StmtArray a -> entries a
StmtSym s -> entries s
StmtAnything a -> entries a
Ruby.StmtModule m -> entries m
Ruby.StmtDef f -> entries f
Ruby.StmtDefs f -> entries f
Ruby.StmtSend s -> entries s
Ruby.StmtConst c -> entries c
Ruby.StmtBlock b -> entries b
Ruby.StmtCasgn c -> entries c
Ruby.StmtArray a -> entries a
Ruby.StmtSym s -> entries s
Ruby.StmtStr s -> entries s
Ruby.StmtLvasgn a -> entries a
Ruby.StmtLvar a -> entries a
Ruby.StmtIvar a -> entries a
Ruby.StmtSelf s -> entries s
Ruby.StmtCbase s -> entries s
Ruby.StmtNil n -> entries n
Ruby.StmtAnything a -> entries a
instance References Ruby.Block where
entries Block{send,args,begin} = do
entries Ruby.Block{send,args,begin} = do
entries send
entries args
entries begin
instance References Ruby.RArgs where
instance References Ruby.Args 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
entries Ruby.Casgn{rhs} = entries rhs
instance References Ruby.Sym where
entries _ = pure ()
instance References Ruby.RArray where
entries RArray{statements} = traverse_ entries statements
instance References Ruby.Str where
entries _ = pure ()
instance References Ruby.Lvasgn where
entries _ = pure ()
instance References Ruby.Lvar where
entries _ = pure ()
instance References Ruby.Ivar where
entries _ = pure ()
instance References Ruby.Self where
entries _ = pure ()
instance References Ruby.Cbase where
entries _ = pure ()
instance References Ruby.Nil where
entries _ = pure ()
instance References Ruby.Array where
entries Ruby.Array{statements} = traverse_ entries statements
instance References Ruby.Anything where
entries = const $ pure ()
instance References Ruby.Namespace where
entries (Ruby.Namespace xs) = do
Context c <- getContext
let
ctxt = case c of
NodeFunction FQN{namespace} -> namespace
NodeModule namespace -> namespace
-- TODO Hacky:
ns = Namespace ((\(Name (Aeson.String t)) -> t) <$> xs)
-- TODO: Broken
-- application c (NodeModule $ ctxt `onTop` ns)
application (NodeModule $ ns)
instance References Ruby.Const where
entries con = application $ NodeModule $ constToNamespace con
instance References Module where
entries Module{name, begin} = do
appendToContext name
updateContext :: MyMonad m => (Context -> Context) -> m ()
updateContext f = getContext >>= \c -> writeContext (f c)
instance References Ruby.Module where
entries Ruby.Module{name, begin} = do
updateContext $ (<>) $ Context $ NodeModule $ constToNamespace name
c <- getContext >>= \case
Context (NodeModule c) -> pure c
_ -> error "..."
declaration $ NodeModule c
entries begin
nameToNode :: MyMonad m => Name -> m Node
nameToNode name = do
atomToNode :: MyMonad m => Ruby.Atom -> m Node
atomToNode (Ruby.Atom 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
-- We could allow this and just say that the function defined in
-- another function sits in the same context as the surrounding
-- function.
Context NodeDef{} -> error "Cannot have a function declaration in a function context"
pure $ NodeDef $ FQN namespace name
instance References Function where
entries Function{name, begin} = do
node <- nameToNode name
instance References Ruby.Def where
entries Ruby.Def{atom, begin} = do
node <- atomToNode atom
declaration node
locally $ do
writeContext (Context node)
entries begin
qual :: Namespace -> Name -> FQN
qual namespace (Name o) = case o of
Aeson.String name -> FQN { namespace , name }
_ -> error $ show o
instance References Ruby.Defs where
-- TODO: The field `context` is also relevant here!
entries Ruby.Defs{atom, begin}
= entries $ Ruby.Def{atom,begin,args=error "hack"}
qual :: Namespace -> Ruby.Atom -> FQN
qual namespace (Ruby.Atom name) = FQN { namespace , name }
onTop' :: Eq a => [a] -> [a] -> [a]
onTop' [] y = y
onTop' x [] = x
onTop' (x:xss) ys@(y:yss) = if
| x == y -> pure x <> yss
| otherwise -> pure x <> xss `onTop'` ys
instance References Ruby.Send where
entries Ruby.Send{context, atom, args} = do
application $ NodeDef $ qual (statementToNamespace context) atom
traverse_ entries args
onTop :: Namespace -> Namespace -> Namespace
onTop (Namespace xs) (Namespace ys) = Namespace $ reverse $ reverse xs `onTop'` reverse ys
statementToNamespace :: Ruby.Statement -> Namespace
statementToNamespace = go mempty
where
go acc = \case
Ruby.StmtConst c -> acc <> constToNamespace c
-- The nil-case and cbase-case should produce different results,
-- surely. `Namespace` may not be a good representation.
Ruby.StmtNil{} -> acc
Ruby.StmtCbase{} -> acc
-- The send-, ivar- and lvar- case cannot be handled because of the way
-- we've defined `Namespace`.
Ruby.StmtSend{} -> acc
Ruby.StmtIvar{} -> acc
Ruby.StmtLvar{} -> acc
_ -> error "Can only build namespaces from sequences of `const` statements"
instance References Send where
entries Send{namespace, name} = do
-- TODO: Broken
-- application c $ NodeFunction $ qual (ctxt `onTop` fromNS namespace) name
application $ NodeFunction $ qual (fromNS namespace) name
where
fromNS :: Ruby.Namespace -> Namespace
fromNS (Ruby.Namespace l) = Namespace $ go <$> l
go :: Name -> Text
go (Name o) = case o of
Aeson.String s -> s
_ -> error $ show o
constToNamespace :: Ruby.Const -> Namespace
constToNamespace Ruby.Const{context, atom} = statementToNamespace context <> [k]
where
Ruby.Atom k = atom