(Partially) handle "blocks"
Also include a catch-all bucket for definitions.
This commit is contained in:
parent
38098122f3
commit
eb93747b2c
|
@ -35,16 +35,21 @@ deriving stock instance Eq Block
|
|||
deriving stock instance Generic Block
|
||||
instance ToJSON Block where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
deriving newtype instance Semigroup Block
|
||||
deriving newtype instance Monoid Block
|
||||
|
||||
instance FromJSON Block where
|
||||
parseJSON = withArray "Block" $ \as -> case Vector.toList as of
|
||||
(String "begin":xs) -> Block <$> traverse parseJSON xs
|
||||
_ -> Block . pure <$> parseJSON (Array as)
|
||||
|
||||
-- Should be 'expression'
|
||||
data Definition
|
||||
= DefModule Module
|
||||
| DefFunction Function
|
||||
| DefSend Send
|
||||
| DefRBlock RBlock
|
||||
| DefAnything Anything
|
||||
|
||||
deriving stock instance Show Definition
|
||||
deriving stock instance Ord Definition
|
||||
|
@ -55,16 +60,54 @@ instance ToJSON Definition where
|
|||
where
|
||||
opts = aesonOptions { Aeson.constructorTagModifier = go }
|
||||
go = \case
|
||||
"DefModule" -> "module"
|
||||
"DefModule" -> "module"
|
||||
"DefFunction" -> "function"
|
||||
"DefSend" -> "send"
|
||||
x -> x
|
||||
"DefSend" -> "send"
|
||||
"DefRBlock" -> "block"
|
||||
x -> x
|
||||
|
||||
instance FromJSON Definition where
|
||||
parseJSON v
|
||||
= (DefModule <$> parseJSON v)
|
||||
= (DefModule <$> parseJSON v)
|
||||
<|> (DefFunction <$> parseJSON v)
|
||||
<|> (DefSend <$> parseJSON v)
|
||||
<|> (DefSend <$> parseJSON v)
|
||||
<|> (DefRBlock <$> parseJSON v)
|
||||
<|> (DefAnything <$> parseJSON v)
|
||||
|
||||
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 RBlock = RBlock
|
||||
{ send :: Send
|
||||
, args :: Args
|
||||
, block :: Block
|
||||
}
|
||||
|
||||
deriving stock instance Show RBlock
|
||||
deriving stock instance Ord RBlock
|
||||
deriving stock instance Eq RBlock
|
||||
deriving stock instance Generic RBlock
|
||||
instance ToJSON RBlock where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
instance FromJSON RBlock where
|
||||
parseJSON = withArray "RBlock" $ \as -> case Vector.toList as of
|
||||
(String "block":send:args:block:[])
|
||||
-> RBlock
|
||||
<$> parseJSON send
|
||||
<*> parseJSON args
|
||||
<*> parseJSON block
|
||||
_ -> empty
|
||||
|
||||
newtype Namespace = Namespace [Name]
|
||||
|
||||
|
@ -81,7 +124,7 @@ instance FromJSON Namespace where
|
|||
parseJSON = \case
|
||||
Null -> pure mempty
|
||||
Array [String "const", namespace, String name] -> (<> Namespace [Name $ String name]) <$> parseJSON namespace
|
||||
x -> error $ show x
|
||||
_ -> empty
|
||||
|
||||
data Send = Send
|
||||
{ args :: Args
|
||||
|
@ -122,12 +165,16 @@ instance FromJSON Module where
|
|||
[String "module", name, block]
|
||||
-> Module
|
||||
<$> parseJSON name
|
||||
<*> parseMaybeBlock block
|
||||
<*> parseMaybe block
|
||||
[String "class", name, _, block]
|
||||
-> Module
|
||||
<$> parseJSON name
|
||||
<*> parseMaybe block
|
||||
_ -> empty
|
||||
|
||||
parseMaybeBlock :: Value -> Aeson.Parser Block
|
||||
parseMaybeBlock = \case
|
||||
Null -> pure (Block mempty)
|
||||
parseMaybe :: FromJSON m => Monoid m => Value -> Aeson.Parser m
|
||||
parseMaybe = \case
|
||||
Null -> pure mempty
|
||||
x -> parseJSON x
|
||||
|
||||
data Function = Function
|
||||
|
@ -143,7 +190,7 @@ deriving stock instance Generic Function
|
|||
instance ToJSON Function where
|
||||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
newtype Args = Args Value
|
||||
newtype Args = Args Anything
|
||||
|
||||
deriving stock instance Show Args
|
||||
instance Ord Args where
|
||||
|
@ -154,7 +201,7 @@ instance ToJSON Args where
|
|||
toEncoding = Aeson.genericToEncoding aesonOptions
|
||||
|
||||
instance FromJSON Args where
|
||||
parseJSON = pure . Args
|
||||
parseJSON = pure . coerce
|
||||
|
||||
instance FromJSON Function where
|
||||
parseJSON = withArray "Function" $ \case
|
||||
|
@ -162,7 +209,7 @@ instance FromJSON Function where
|
|||
-> Function
|
||||
<$> parseJSON name
|
||||
<*> parseJSON args
|
||||
<*> parseMaybeBlock block
|
||||
<*> parseMaybe block
|
||||
_ -> empty
|
||||
|
||||
newtype Name = Name Value
|
||||
|
|
|
@ -20,7 +20,7 @@ run :: FilePath -> IO ()
|
|||
run p = do
|
||||
json <- runParser p
|
||||
block <- decodeFail @_ @Block $ ByteString.pack json
|
||||
-- ByteString.putStrLn $ encode block
|
||||
ByteString.putStrLn $ encode block
|
||||
ByteString.putStrLn $ encode $ references block
|
||||
|
||||
decodeFail :: MonadFail m => FromJSON a => ByteString -> m a
|
||||
|
|
|
@ -160,6 +160,9 @@ instance References Definition where
|
|||
DefModule m -> entries m
|
||||
DefFunction f -> entries f
|
||||
DefSend s -> entries s
|
||||
-- TODO:
|
||||
DefRBlock{} -> pure ()
|
||||
DefAnything{} -> pure ()
|
||||
|
||||
instance References Module where
|
||||
entries Module{name, block} = do
|
||||
|
|
Loading…
Reference in a new issue