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

Major overhaul

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

9
src/Data/Language/Ruby.hs
View file

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

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

@ -1,30 +1,39 @@
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-} {-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wall #-}
module Data.Language.Ruby.AST module Data.Language.Ruby.AST
( Args(..) ( Begin(..)
, Begin(..)
, Statement(..) , Statement(..)
, Function(..) , Def(..)
, Module(..) , Module(..)
, Name(..)
, Send(..) , Send(..)
, Namespace(..) , Const(..)
, Block(..) , Block(..)
, Casgn(..) , Casgn(..)
, RArray(..) , Array(..)
, RArgs(..) , Args(..)
, Anything(..) , Anything(..)
, Sym(..) , Sym(..)
, String(..)
, Str(..)
, Lvasgn(..)
, Lvar(..)
, Ivar(..)
, Atom(..)
, Defs(..)
, Self(..)
, Nil(..)
, Cbase
) where ) where
import Data.Aeson (parseJSON, Value(..), withArray) import Data.Aeson (parseJSON, Value(Null,Object,Number,Bool), withArray)
import Frelude import Frelude hiding (String)
import qualified Frelude
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
import Data.Coerce import Data.Coerce
import Data.Word import Data.Word
kebabCase :: String -> String kebabCase :: Frelude.String -> Frelude.String
kebabCase = Aeson.camelTo2 '-' kebabCase = Aeson.camelTo2 '-'
aesonOptions :: Aeson.Options aesonOptions :: Aeson.Options
@ -46,19 +55,27 @@ deriving newtype instance Monoid Begin
instance FromJSON Begin where instance FromJSON Begin where
parseJSON = withArray "Begin" $ \as -> case Vector.toList as of parseJSON = withArray "Begin" $ \as -> case Vector.toList as of
(String "begin":xs) -> Begin <$> traverse parseJSON xs (Aeson.String "begin":xs) -> Begin <$> traverse parseJSON xs
_ -> Begin . pure <$> parseJSON (Array as) _ -> Begin . pure <$> parseJSON (Aeson.Array as)
-- Should be 'expression' -- Should be 'expression'
data Statement data Statement
= StmtModule Module = StmtModule Module
| StmtFunction Function | StmtDef Def
| StmtDefs Defs
| StmtSend Send | StmtSend Send
| StmtBlock Block | StmtBlock Block
| StmtConst Namespace | StmtConst Const
| StmtCasgn Casgn | StmtCasgn Casgn
| StmtArray RArray | StmtArray Array
| StmtSym Sym | StmtSym Sym
| StmtStr Str
| StmtLvasgn Lvasgn
| StmtLvar Lvar
| StmtIvar Ivar
| StmtSelf Self
| StmtNil Nil
| StmtCbase Cbase
-- TODO Get rid of this -- TODO Get rid of this
| StmtAnything Anything | StmtAnything Anything
@ -72,29 +89,47 @@ instance ToJSON Statement where
opts = aesonOptions { Aeson.constructorTagModifier = go } opts = aesonOptions { Aeson.constructorTagModifier = go }
go = \case go = \case
"StmtModule" -> "module" "StmtModule" -> "module"
"StmtFunction" -> "function" "StmtDef" -> "def"
"StmtDefs" -> "defs"
"StmtSend" -> "send" "StmtSend" -> "send"
"StmtBlock" -> "block" "StmtBlock" -> "block"
"StmtConst" -> "const" "StmtConst" -> "const"
"StmtCasgn" -> "casgn" "StmtCasgn" -> "casgn"
"StmtArray" -> "array" "StmtArray" -> "array"
"StmtSym" -> "sym" "StmtSym" -> "sym"
"StmtStr" -> "str"
"StmtLvasgn" -> "lvasgn"
"StmtLvar" -> "lvar"
"StmtIvar" -> "ivar"
"StmtSelf" -> "self"
"StmtNil" -> "nil"
"StmtCbase" -> "cbase"
x -> x x -> x
instance FromJSON Statement where instance FromJSON Statement where
parseJSON v parseJSON v
= (StmtModule <$> parseJSON v) = (StmtModule <$> parseJSON v)
<|> (StmtFunction <$> parseJSON v) <|> (StmtDef <$> parseJSON v)
<|> (StmtDefs <$> parseJSON v)
<|> (StmtSend <$> parseJSON v) <|> (StmtSend <$> parseJSON v)
<|> (StmtBlock <$> parseJSON v) <|> (StmtBlock <$> parseJSON v)
<|> (StmtConst <$> parseJSON v) <|> (StmtConst <$> parseJSON v)
<|> (StmtCasgn <$> parseJSON v) <|> (StmtCasgn <$> parseJSON v)
<|> (StmtArray <$> 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) <|> (StmtAnything <$> parseJSON v)
data Casgn = Casgn data Casgn = Casgn
{ name :: Name { context :: Statement
, statement :: Statement , atom :: Atom
, rhs :: Statement
} }
deriving stock instance Show Casgn deriving stock instance Show Casgn
deriving stock instance Ord Casgn deriving stock instance Ord Casgn
@ -104,26 +139,27 @@ instance ToJSON Casgn where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Casgn where instance FromJSON Casgn where
parseJSON = withArray "Module" $ \case parseJSON = withArray "Module" $ \case
[String "casgn", _, name, statement] [Aeson.String "casgn", context, atom, rhs]
-> Casgn -> Casgn
<$> parseJSON name <$> parseJSON context
<*> parseJSON statement <*> parseJSON atom
<*> parseJSON rhs
_ -> empty _ -> empty
data RArray = RArray data Array = Array
{ statements :: [Statement] { statements :: [Statement]
} }
deriving stock instance Show RArray deriving stock instance Show Array
deriving stock instance Ord RArray deriving stock instance Ord Array
deriving stock instance Eq RArray deriving stock instance Eq Array
deriving stock instance Generic RArray deriving stock instance Generic Array
instance ToJSON RArray where instance ToJSON Array where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON RArray where instance FromJSON Array where
parseJSON = withArray "RArray" $ \as -> case Vector.toList as of parseJSON = withArray "Array" $ \as -> case Vector.toList as of
String "array":xs Aeson.String "array":xs
-> RArray -> Array
<$> traverse parseJSON xs <$> traverse parseJSON xs
_ -> empty _ -> empty
@ -143,7 +179,7 @@ deriving newtype instance FromJSON Anything
-- end -- end
data Block = Block data Block = Block
{ send :: Send { send :: Send
, args :: RArgs , args :: Args
, begin :: Begin , begin :: Begin
} }
@ -155,7 +191,7 @@ instance ToJSON Block where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Block where instance FromJSON Block where
parseJSON = withArray "Block" $ \as -> case Vector.toList as of parseJSON = withArray "Block" $ \as -> case Vector.toList as of
(String "block":send:args:begin:[]) [Aeson.String "block",send,args,begin]
-> Block -> Block
<$> parseJSON send <$> parseJSON send
<*> parseJSON args <*> parseJSON args
@ -165,17 +201,17 @@ instance FromJSON Block where
-- | It's super confusing that I've already defined a node in my AST -- | 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 -- called args. This one correspond to the AST node with the label
-- "args" as reported by `ruby-parse`. -- "args" as reported by `ruby-parse`.
newtype RArgs = RArgs [Arg] newtype Args = Args [Arg]
deriving stock instance Show RArgs deriving stock instance Show Args
deriving stock instance Ord RArgs deriving stock instance Ord Args
deriving stock instance Eq RArgs deriving stock instance Eq Args
deriving stock instance Generic RArgs deriving stock instance Generic Args
instance ToJSON RArgs where instance ToJSON Args where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON RArgs where instance FromJSON Args where
parseJSON = withArray "RArgs" $ \as -> case Vector.toList as of parseJSON = withArray "Args" $ \as -> case Vector.toList as of
(String "args":xs) -> RArgs <$> traverse parseJSON xs (Aeson.String "args":xs) -> Args <$> traverse parseJSON xs
_ -> empty _ -> empty
data Arg = Arg Atom | KWArg Atom data Arg = Arg Atom | KWArg Atom
@ -195,8 +231,8 @@ instance ToJSON Arg where
instance FromJSON Arg where instance FromJSON Arg where
parseJSON = withArray "Arg" $ \as -> case Vector.toList as of parseJSON = withArray "Arg" $ \as -> case Vector.toList as of
[String "arg" , symbol] -> Arg <$> parseJSON symbol [Aeson.String "arg" , symbol] -> Arg <$> parseJSON symbol
[String "kwarg" , symbol] -> KWArg <$> parseJSON symbol [Aeson.String "kwarg" , symbol] -> KWArg <$> parseJSON symbol
_ -> empty _ -> empty
newtype Atom = Atom Text newtype Atom = Atom Text
@ -210,30 +246,30 @@ instance ToJSON Atom where
instance FromJSON Atom where instance FromJSON Atom where
parseJSON = \case parseJSON = \case
String s -> pure $ Atom s Aeson.String s -> pure $ Atom s
_ -> empty _ -> empty
newtype Namespace = Namespace [Name] data Const = Const
{ context :: Statement
, atom :: Atom
}
deriving newtype instance Semigroup Namespace deriving stock instance Show Const
deriving newtype instance Monoid Namespace deriving stock instance Ord Const
deriving stock instance Show Namespace deriving stock instance Eq Const
deriving stock instance Ord Namespace deriving stock instance Generic Const
deriving stock instance Eq Namespace instance ToJSON Const where
deriving stock instance Generic Namespace
instance ToJSON Namespace where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Namespace where instance FromJSON Const where
parseJSON = \case parseJSON = withArray "Send" $ \case -- \ as -> case Vector.toList as of
Null -> pure mempty [Aeson.String "const", context, atom] -> Const <$> parseJSON context <*> parseJSON atom
Array [String "const", namespace, String name] -> (<> Namespace [Name $ String name]) <$> parseJSON namespace
_ -> empty _ -> empty
data Send = Send data Send = Send
{ args :: Args { context :: Statement
, namespace :: Namespace , atom :: Atom
, name :: Name , args :: [Statement]
} }
deriving stock instance Show Send deriving stock instance Show Send
@ -245,15 +281,15 @@ instance ToJSON Send where
instance FromJSON Send where instance FromJSON Send where
parseJSON = withArray "Send" $ \ as -> case Vector.toList as of parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
(String "send" : namespace : name : args) (Aeson.String "send" : context : atom : args)
-> Send -> Send
<$> parseJSON (Array $ Vector.fromList args) <$> parseJSON context
<*> parseJSON namespace <*> parseJSON atom
<*> parseJSON name <*> parseJSON (Aeson.Array $ Vector.fromList args)
_ -> empty _ -> empty
data Module = Module data Module = Module
{ name :: Name { name :: Const
, begin :: Begin , begin :: Begin
} }
@ -266,11 +302,11 @@ instance ToJSON Module where
instance FromJSON Module where instance FromJSON Module where
parseJSON = withArray "Module" $ \case parseJSON = withArray "Module" $ \case
[String "module", name, begin] [Aeson.String "module", name, begin]
-> Module -> Module
<$> parseJSON name <$> parseJSON name
<*> parseMaybe begin <*> parseMaybe begin
[String "class", name, _, begin] [Aeson.String "class", name, _, begin]
-> Module -> Module
<$> parseJSON name <$> parseJSON name
<*> parseMaybe begin <*> parseMaybe begin
@ -281,55 +317,67 @@ parseMaybe = \case
Null -> pure mempty Null -> pure mempty
x -> parseJSON x x -> parseJSON x
data Function = Function data Def = Def
{ name :: Name { atom :: Atom
, args :: RArgs , args :: Args
, begin :: Begin , begin :: Begin
} }
deriving stock instance Show Function deriving stock instance Show Def
deriving stock instance Ord Function deriving stock instance Ord Def
deriving stock instance Eq Function deriving stock instance Eq Def
deriving stock instance Generic Function deriving stock instance Generic Def
instance ToJSON Function where instance ToJSON Def where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
data Args = Args [Statement] instance FromJSON Def where
parseJSON = withArray "Def" $ \case
deriving stock instance Show Args [Aeson.String "def", name, args, begin]
deriving stock instance Ord Args -> Def
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
<$> parseJSON name <$> parseJSON name
<*> parseJSON args <*> parseJSON args
<*> parseMaybe begin <*> parseMaybe begin
_ -> empty _ -> 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 deriving stock instance Show Defs
instance Ord Name where deriving stock instance Ord Defs
compare = coerce compareValue deriving stock instance Eq Defs
deriving stock instance Eq Name deriving stock instance Generic Defs
deriving newtype instance ToJSON Name instance ToJSON Defs where
deriving newtype instance FromJSON Name 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 :: Aeson.Value -> Aeson.Value -> Ordering
compareValue v0 v1 = case (v0, v1) of compareValue v0 v1 = case (v0, v1) of
-- This case is buggy: -- This case is buggy:
(Object o0, Object o1) -> compare (fst <$> toList o0) (fst <$> toList o1) (Object o0, Object o1) -> compare (fst <$> toList o0) (fst <$> toList o1)
(Array a0, Array a1) -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1) (Aeson.Array a0, Aeson.Array a1) -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
(String s0, String s1) -> compare s0 s1 (Aeson.String s0, Aeson.String s1) -> compare s0 s1
(Number n0, Number n1) -> compare n0 n1 (Number n0, Number n1) -> compare n0 n1
(Bool b0, Bool b1) -> compare b0 b1 (Bool b0, Bool b1) -> compare b0 b1
(Null, Null) -> EQ (Null, Null) -> EQ
@ -339,8 +387,8 @@ compareValue v0 v1 = case (v0, v1) of
cons :: Aeson.Value -> Word8 cons :: Aeson.Value -> Word8
cons = \case cons = \case
Object{} -> 0 Object{} -> 0
Array{} -> 1 Aeson.Array{} -> 1
String{} -> 2 Aeson.String{} -> 2
Number{} -> 3 Number{} -> 3
Bool{} -> 4 Bool{} -> 4
Null{} -> 5 Null{} -> 5
@ -355,5 +403,113 @@ instance ToJSON Sym where
toEncoding = Aeson.genericToEncoding aesonOptions toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Sym where instance FromJSON Sym where
parseJSON = withArray "Sym" $ \case 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 _ -> empty

202
src/Rubyhs/References.hs
View file

@ -1,13 +1,11 @@
{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-} {-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-}
-- {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wall #-}
module Rubyhs.References module Rubyhs.References
( References(entries) ( References(entries)
, Entry(..)
, FQN(..) , FQN(..)
, references , references
, Env(..) , Env(..)
, Result(..) , Result(..)
, Namespace(..)
, Context(..) , Context(..)
, graph , graph
, prettyContext , prettyContext
@ -15,7 +13,7 @@ module Rubyhs.References
) where ) where
import Frelude import Frelude
import Data.Language.Ruby hiding (Namespace) -- import Data.Language.Ruby hiding (context)
import qualified Data.Language.Ruby as Ruby import qualified Data.Language.Ruby as Ruby
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as 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) 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 graph b = span $ Graph.graphFromEdges $ go <$> toList ys
where where
go :: (Node, Set Node) -> (Node, Text, [Text]) go :: (Node, Set Node) -> (Node, Text, [Text])
go (x, xs) = (x, prettyContext x, prettyContext <$> toList xs) go (x, xs) = (x, prettyContext x, prettyContext <$> toList xs)
Result ys = references b Result ys = references b
data Entry a = Entry
{ node :: a
, fqn :: FQN
}
newtype Namespace = Namespace [Text] newtype Namespace = Namespace [Text]
deriving stock instance Show Namespace deriving stock instance Show Namespace
deriving stock instance Eq Namespace deriving stock instance Eq Namespace
@ -68,7 +61,7 @@ data FQN = FQN
, name :: Text , name :: Text
} }
data Node = NodeFunction FQN | NodeModule Namespace data Node = NodeDef FQN | NodeModule Namespace
deriving stock instance Show Node deriving stock instance Show Node
deriving stock instance Eq Node deriving stock instance Eq Node
@ -76,7 +69,7 @@ deriving stock instance Ord Node
instance ToJSON Node where instance ToJSON Node where
toJSON = \case toJSON = \case
NodeFunction q -> Aeson.toJSON q NodeDef q -> Aeson.toJSON q
NodeModule m -> Aeson.toJSON m NodeModule m -> Aeson.toJSON m
deriving stock instance Show FQN deriving stock instance Show FQN
@ -101,6 +94,13 @@ newtype Context = Context Node
deriving stock instance Eq Context deriving stock instance Eq Context
deriving stock instance Ord Context deriving stock instance Ord Context
deriving newtype instance ToJSON 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 class Monad m => MyMonad (m :: Type -> Type) where
declaration :: Node -> m () declaration :: Node -> m ()
@ -123,7 +123,7 @@ instance ToJSON Result where
prettyContext :: Node -> Text prettyContext :: Node -> Text
prettyContext = \case prettyContext = \case
NodeFunction fun -> prettyFQN fun NodeDef fun -> prettyFQN fun
NodeModule ns -> showNamespace ns NodeModule ns -> showNamespace ns
instance MyMonad (State Env) where instance MyMonad (State Env) where
@ -137,13 +137,10 @@ instance MyMonad (State Env) where
go env@Env{applications} go env@Env{applications}
= env { applications = Map.insertWith mappend c (Set.singleton n) applications } = env { applications = Map.insertWith mappend c (Set.singleton n) applications }
modify go modify go
getContext = gets context getContext = gets Rubyhs.References.context
writeContext q = modify go writeContext q = modify go
where where
go env = env { context = q } go env = env { Rubyhs.References.context = q }
updateContext :: MyMonad m => (Context -> Context) -> m ()
updateContext f = getContext >>= \c -> writeContext (f c)
locally :: MyMonad m => m a -> m a locally :: MyMonad m => m a -> m a
locally act = do locally act = do
@ -152,128 +149,135 @@ locally act = do
writeContext old writeContext old
pure res 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 class References a where
entries :: MyMonad m => a -> m () entries :: MyMonad m => a -> m ()
references :: Begin -> Result references :: Ruby.Begin -> Result
references q = Result $ Map.unionWith mappend applications declarations' references q = Result $ Map.unionWith mappend applications declarations'
where where
Env{declarations,applications} = execState (entries @_ @(State Env) q) emptyEnv Env{declarations,applications} = execState (entries @_ @(State Env) q) emptyEnv
emptyEnv = Env mempty mempty (Context $ NodeModule mempty) emptyEnv = Env mempty mempty (Context $ NodeModule mempty)
declarations' = fromList $ (\x -> (x, mempty)) <$> toList declarations declarations' = fromList $ (\x -> (x, mempty)) <$> toList declarations
instance References Begin where instance References Ruby.Begin where
entries :: forall m . MyMonad m => Begin -> m () entries :: forall m . MyMonad m => Ruby.Begin -> m ()
entries (Begin defs) = traverse_ (locally . entries) defs entries (Ruby.Begin defs) = traverse_ (locally . entries) defs
instance References Statement where instance References Ruby.Statement where
entries = \case entries = \case
StmtModule m -> entries m Ruby.StmtModule m -> entries m
StmtFunction f -> entries f Ruby.StmtDef f -> entries f
StmtSend s -> entries s Ruby.StmtDefs f -> entries f
StmtConst c -> entries c Ruby.StmtSend s -> entries s
StmtBlock b -> entries b Ruby.StmtConst c -> entries c
StmtCasgn c -> entries c Ruby.StmtBlock b -> entries b
StmtArray a -> entries a Ruby.StmtCasgn c -> entries c
StmtSym s -> entries s Ruby.StmtArray a -> entries a
StmtAnything 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 instance References Ruby.Block where
entries Block{send,args,begin} = do entries Ruby.Block{send,args,begin} = do
entries send entries send
entries args entries args
entries begin entries begin
instance References Ruby.RArgs where instance References Ruby.Args where
entries = const $ pure () entries = const $ pure ()
-- TODO: We have to make a "declaration" for the constant here as -- TODO: We have to make a "declaration" for the constant here as
-- well! -- well!
instance References Ruby.Casgn where instance References Ruby.Casgn where
entries Casgn{name, statement} = entries statement entries Ruby.Casgn{rhs} = entries rhs
instance References Ruby.Sym where instance References Ruby.Sym where
entries _ = pure () entries _ = pure ()
instance References Ruby.RArray where instance References Ruby.Str where
entries RArray{statements} = traverse_ entries statements 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 instance References Ruby.Anything where
entries = const $ pure () entries = const $ pure ()
instance References Ruby.Namespace where instance References Ruby.Const where
entries (Ruby.Namespace xs) = do entries con = application $ NodeModule $ constToNamespace con
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 Module where updateContext :: MyMonad m => (Context -> Context) -> m ()
entries Module{name, begin} = do updateContext f = getContext >>= \c -> writeContext (f c)
appendToContext name
instance References Ruby.Module where
entries Ruby.Module{name, begin} = do
updateContext $ (<>) $ Context $ NodeModule $ constToNamespace name
c <- getContext >>= \case c <- getContext >>= \case
Context (NodeModule c) -> pure c Context (NodeModule c) -> pure c
_ -> error "..." _ -> error "..."
declaration $ NodeModule c declaration $ NodeModule c
entries begin entries begin
nameToNode :: MyMonad m => Name -> m Node atomToNode :: MyMonad m => Ruby.Atom -> m Node
nameToNode name = do atomToNode (Ruby.Atom name) = do
namespace <- getContext >>= \case namespace <- getContext >>= \case
Context (NodeModule c) -> pure c Context (NodeModule c) -> pure c
Context NodeFunction{} -> error "Cannot have a function declaration in a function context" -- We could allow this and just say that the function defined in
pure $ NodeFunction $ qual namespace name -- 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 instance References Ruby.Def where
entries Function{name, begin} = do entries Ruby.Def{atom, begin} = do
node <- nameToNode name node <- atomToNode atom
declaration node declaration node
locally $ do locally $ do
writeContext (Context node) writeContext (Context node)
entries begin entries begin
qual :: Namespace -> Name -> FQN instance References Ruby.Defs where
qual namespace (Name o) = case o of -- TODO: The field `context` is also relevant here!
Aeson.String name -> FQN { namespace , name } entries Ruby.Defs{atom, begin}
_ -> error $ show o = 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] instance References Ruby.Send where
onTop' [] y = y entries Ruby.Send{context, atom, args} = do
onTop' x [] = x application $ NodeDef $ qual (statementToNamespace context) atom
onTop' (x:xss) ys@(y:yss) = if traverse_ entries args
| x == y -> pure x <> yss
| otherwise -> pure x <> xss `onTop'` ys
onTop :: Namespace -> Namespace -> Namespace statementToNamespace :: Ruby.Statement -> Namespace
onTop (Namespace xs) (Namespace ys) = Namespace $ reverse $ reverse xs `onTop'` reverse ys 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 constToNamespace :: Ruby.Const -> Namespace
entries Send{namespace, name} = do constToNamespace Ruby.Const{context, atom} = statementToNamespace context <> [k]
-- TODO: Broken where
-- application c $ NodeFunction $ qual (ctxt `onTop` fromNS namespace) name Ruby.Atom k = atom
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