(Partially) handle "blocks"

Also include a catch-all bucket for definitions.
This commit is contained in:
Frederik Hanghøj Iversen 2019-10-14 19:47:57 +02:00 committed by Frederik Hanghøj Iversen
parent 38098122f3
commit eb93747b2c
3 changed files with 64 additions and 14 deletions

View file

@ -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
@ -58,6 +63,7 @@ instance ToJSON Definition where
"DefModule" -> "module"
"DefFunction" -> "function"
"DefSend" -> "send"
"DefRBlock" -> "block"
x -> x
instance FromJSON Definition where
@ -65,6 +71,43 @@ instance FromJSON Definition where
= (DefModule <$> parseJSON v)
<|> (DefFunction <$> 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

View file

@ -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

View file

@ -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