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:
parent
a0c574b53a
commit
f8163f99c7
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue