From f8163f99c7f32f5300f79108b57fa82de21c716d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 17 Oct 2019 23:28:40 +0200 Subject: [PATCH] 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! --- src/Data/Language/Ruby.hs | 9 +- src/Data/Language/Ruby/AST.hs | 366 ++++++++++++++++++++++++---------- src/Rubyhs/References.hs | 202 ++++++++++--------- 3 files changed, 369 insertions(+), 208 deletions(-) diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs index ffec1bd..452fffd 100644 --- a/src/Data/Language/Ruby.hs +++ b/src/Data/Language/Ruby.hs @@ -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 diff --git a/src/Data/Language/Ruby/AST.hs b/src/Data/Language/Ruby/AST.hs index 64a82ea..3ef7beb 100644 --- a/src/Data/Language/Ruby/AST.hs +++ b/src/Data/Language/Ruby/AST.hs @@ -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 diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index 43afc35..36e3b22 100644 --- a/src/Rubyhs/References.hs +++ b/src/Rubyhs/References.hs @@ -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