516 lines
14 KiB
Haskell
516 lines
14 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
module Data.Language.Ruby.AST
|
|
( Begin(..)
|
|
, Statement(..)
|
|
, Def(..)
|
|
, Module(..)
|
|
, Send(..)
|
|
, Const(..)
|
|
, Block(..)
|
|
, Casgn(..)
|
|
, Array(..)
|
|
, Args(..)
|
|
, Anything(..)
|
|
, Sym(..)
|
|
, String(..)
|
|
, Str(..)
|
|
, Lvasgn(..)
|
|
, Lvar(..)
|
|
, Ivar(..)
|
|
, Atom(..)
|
|
, Defs(..)
|
|
, Self(..)
|
|
, Nil(..)
|
|
, Cbase
|
|
) where
|
|
|
|
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 :: Frelude.String -> Frelude.String
|
|
kebabCase = Aeson.camelTo2 '-'
|
|
|
|
aesonOptions :: Aeson.Options
|
|
aesonOptions = Aeson.defaultOptions
|
|
{ Aeson.sumEncoding = Aeson.ObjectWithSingleField
|
|
, Aeson.constructorTagModifier = kebabCase
|
|
}
|
|
|
|
newtype Begin = Begin [Statement]
|
|
|
|
deriving stock instance Show Begin
|
|
deriving stock instance Ord Begin
|
|
deriving stock instance Eq Begin
|
|
deriving stock instance Generic Begin
|
|
instance ToJSON Begin where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
deriving newtype instance Semigroup Begin
|
|
deriving newtype instance Monoid Begin
|
|
|
|
instance FromJSON Begin where
|
|
parseJSON = withArray "Begin" $ \as -> case Vector.toList as of
|
|
(Aeson.String "begin":xs) -> Begin <$> traverse parseJSON xs
|
|
_ -> Begin . pure <$> parseJSON (Aeson.Array as)
|
|
|
|
-- Should be 'expression'
|
|
data Statement
|
|
= StmtModule Module
|
|
| 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
|
|
-- TODO Get rid of this
|
|
| StmtAnything Anything
|
|
|
|
deriving stock instance Show Statement
|
|
deriving stock instance Ord Statement
|
|
deriving stock instance Eq Statement
|
|
deriving stock instance Generic Statement
|
|
instance ToJSON Statement where
|
|
toEncoding = Aeson.genericToEncoding opts
|
|
where
|
|
opts = aesonOptions { Aeson.constructorTagModifier = go }
|
|
go = \case
|
|
"StmtModule" -> "module"
|
|
"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)
|
|
<|> (StmtDef <$> parseJSON v)
|
|
<|> (StmtDefs <$> parseJSON v)
|
|
<|> (StmtSend <$> 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
|
|
{ context :: Statement
|
|
, atom :: Atom
|
|
, rhs :: Statement
|
|
}
|
|
deriving stock instance Show Casgn
|
|
deriving stock instance Ord Casgn
|
|
deriving stock instance Eq Casgn
|
|
deriving stock instance Generic Casgn
|
|
instance ToJSON Casgn where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
instance FromJSON Casgn where
|
|
parseJSON = withArray "Module" $ \case
|
|
[Aeson.String "casgn", context, atom, rhs]
|
|
-> Casgn
|
|
<$> parseJSON context
|
|
<*> parseJSON atom
|
|
<*> parseJSON rhs
|
|
_ -> empty
|
|
|
|
|
|
newtype Array = Array
|
|
{ statements :: [Statement]
|
|
}
|
|
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 Array where
|
|
parseJSON = withArray "Array" $ \as -> case Vector.toList as of
|
|
Aeson.String "array":xs
|
|
-> Array
|
|
<$> traverse parseJSON xs
|
|
_ -> empty
|
|
|
|
newtype Anything = Anything Value
|
|
|
|
deriving stock instance Show Anything
|
|
instance Ord Anything where
|
|
compare = coerce compareValue
|
|
deriving stock instance Eq Anything
|
|
deriving stock instance Generic Anything
|
|
instance ToJSON Anything where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
deriving newtype instance FromJSON Anything
|
|
|
|
-- f do |x|
|
|
-- expr
|
|
-- end
|
|
data Block = Block
|
|
{ send :: Send
|
|
, args :: Args
|
|
, begin :: Begin
|
|
}
|
|
|
|
deriving stock instance Show Block
|
|
deriving stock instance Ord Block
|
|
deriving stock instance Eq Block
|
|
deriving stock instance Generic Block
|
|
instance ToJSON Block where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
instance FromJSON Block where
|
|
parseJSON = withArray "Block" $ \as -> case Vector.toList as of
|
|
[Aeson.String "block",send,args,begin]
|
|
-> Block
|
|
<$> parseJSON send
|
|
<*> parseJSON args
|
|
<*> parseJSON begin
|
|
_ -> empty
|
|
|
|
-- | It's super confusing that I've already defined a node in my AST
|
|
-- called args. This one correspond to the AST node with the label
|
|
-- "args" as reported by `ruby-parse`.
|
|
newtype Args = Args [Arg]
|
|
|
|
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" $ \as -> case Vector.toList as of
|
|
(Aeson.String "args":xs) -> Args <$> traverse parseJSON xs
|
|
_ -> empty
|
|
|
|
data Arg = Arg Atom | KWArg Atom
|
|
|
|
deriving stock instance Show Arg
|
|
deriving stock instance Ord Arg
|
|
deriving stock instance Eq Arg
|
|
deriving stock instance Generic Arg
|
|
instance ToJSON Arg where
|
|
toEncoding = Aeson.genericToEncoding opts
|
|
where
|
|
opts = aesonOptions { Aeson.constructorTagModifier = go }
|
|
go = \case
|
|
"KWArg" -> "kwarg"
|
|
"Arg" -> "arg"
|
|
x -> x
|
|
|
|
instance FromJSON Arg where
|
|
parseJSON = withArray "Arg" $ \as -> case Vector.toList as of
|
|
[Aeson.String "arg" , symbol] -> Arg <$> parseJSON symbol
|
|
[Aeson.String "kwarg" , symbol] -> KWArg <$> parseJSON symbol
|
|
_ -> empty
|
|
|
|
newtype Atom = Atom Text
|
|
|
|
deriving stock instance Show Atom
|
|
deriving stock instance Ord Atom
|
|
deriving stock instance Eq Atom
|
|
deriving stock instance Generic Atom
|
|
instance ToJSON Atom where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Atom where
|
|
parseJSON = \case
|
|
Aeson.String s -> pure $ Atom s
|
|
_ -> empty
|
|
|
|
data Const = Const
|
|
{ context :: Statement
|
|
, atom :: Atom
|
|
}
|
|
|
|
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 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
|
|
{ context :: Statement
|
|
, atom :: Atom
|
|
, args :: [Statement]
|
|
}
|
|
|
|
deriving stock instance Show Send
|
|
deriving stock instance Ord Send
|
|
deriving stock instance Eq Send
|
|
deriving stock instance Generic Send
|
|
instance ToJSON Send where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Send where
|
|
parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
|
|
(Aeson.String "send" : context : atom : args)
|
|
-> Send
|
|
<$> parseJSON context
|
|
<*> parseJSON atom
|
|
<*> parseJSON (Aeson.Array $ Vector.fromList args)
|
|
_ -> empty
|
|
|
|
data Module = Module
|
|
{ name :: Const
|
|
, begin :: Begin
|
|
}
|
|
|
|
deriving stock instance Show Module
|
|
deriving stock instance Ord Module
|
|
deriving stock instance Eq Module
|
|
deriving stock instance Generic Module
|
|
instance ToJSON Module where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Module where
|
|
parseJSON = withArray "Module" $ \case
|
|
[Aeson.String "module", name, begin]
|
|
-> Module
|
|
<$> parseJSON name
|
|
<*> parseMaybe begin
|
|
[Aeson.String "class", name, _, begin]
|
|
-> Module
|
|
<$> parseJSON name
|
|
<*> parseMaybe begin
|
|
_ -> empty
|
|
|
|
parseMaybe :: FromJSON m => Monoid m => Value -> Aeson.Parser m
|
|
parseMaybe = \case
|
|
Null -> pure mempty
|
|
x -> parseJSON x
|
|
|
|
data Def = Def
|
|
{ atom :: Atom
|
|
, args :: Args
|
|
, begin :: Begin
|
|
}
|
|
|
|
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
|
|
|
|
instance FromJSON Def where
|
|
parseJSON = withArray "Def" $ \case
|
|
[Aeson.String "def", name, args, begin]
|
|
-> Def
|
|
<$> parseJSON name
|
|
<*> parseJSON args
|
|
<*> parseMaybe begin
|
|
_ -> empty
|
|
|
|
-- | 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 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)
|
|
(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
|
|
_ -> (compare `on` cons) v0 v1
|
|
where
|
|
-- Enumerate constructors.
|
|
cons :: Aeson.Value -> Word8
|
|
cons = \case
|
|
Object{} -> 0
|
|
Aeson.Array{} -> 1
|
|
Aeson.String{} -> 2
|
|
Number{} -> 3
|
|
Bool{} -> 4
|
|
Null{} -> 5
|
|
|
|
newtype Sym = Sym Atom
|
|
|
|
deriving stock instance Show Sym
|
|
deriving newtype instance Ord Sym
|
|
deriving stock instance Eq Sym
|
|
deriving stock instance Generic Sym
|
|
instance ToJSON Sym where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
instance FromJSON Sym where
|
|
parseJSON = withArray "Sym" $ \case
|
|
[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
|
|
|
|
newtype 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
|
|
|
|
newtype 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
|