JSON serialization

lib/Bril.hs

@@ -5,7 +5,7 @@ module Bril (
     parseBrilFromPath, parseBrilJSON,
     )where
 
-import Data.Aeson (FromJSON, parseJSON, withObject, withText, withScientific, (.:), (.:?), eitherDecode)
+import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON, object, withObject, withText, withBool, withScientific, (.:), (.:?), (.=), (.?=), eitherDecode)
 import Data.Aeson.Types (Parser, modifyFailure)
 import qualified Data.Aeson (Value, Object, Key)
 import Data.Aeson.KeyMap
@@ -66,7 +66,7 @@ data Instruction =
 data InstrOperation =
     Add | Mul | Sub | Div | Eq | Lt | Gt | Le | Ge | Not | And | Or |
     Jmp | Br | Call | Ret | Id | Print | Nop | Phi
-   deriving (Eq, Show)
+   deriving (Eq)
 
 data Arity =
     Arity Int Int Int -- min, max, labels arity
@@ -74,11 +74,11 @@ data Arity =
    deriving (Eq, Show)
 
 valueOps = toSortedList ([
-        "add", "mul", "sub", "div", "eq", "lt", "gt", "le", "ge", "not", "and", "or"
+        "add", "mul", "sub", "div", "eq", "lt", "gt", "le", "ge", "not", "and", "or", "id"
     ] :: [T.Text])
 
 effectOps = toSortedList ([
-        "nop", "call", "jmp", "br", "print", "lt", "gt", "le", "ge", "not", "and", "or"
+        "nop", "call", "jmp", "br", "print", "ret"
     ] :: [T.Text])
 
 arity instr
@@ -118,6 +118,28 @@ instrFromString s
     | s == "nop" = Nop
     | otherwise = error "wrong instruction name"
 
+instance Show InstrOperation where
+    show op = case op of
+        Nop   -> "add"
+        Add   -> "sub"
+        Sub   -> "mul"
+        Mul   -> "eq"
+        Eq    -> "lt"
+        Lt    -> "gt"
+        Gt    -> "le"
+        Le    -> "ge"
+        Ge    -> "not"
+        Not   -> "and"
+        And   -> "or"
+        Or    -> "jmp"
+        Jmp   -> "br"
+        Br    -> "ret"
+        Ret   -> "call"
+        Call  -> "print"
+        Print -> "id"
+        Id    -> "nop"
+
+
 optionalArrayField :: FromJSON a => Data.Aeson.Object -> Data.Aeson.Key -> Parser [a]
 optionalArrayField v field =
     ((v .:? field) >>= (return . fromMaybe []))
@@ -203,19 +225,8 @@ instance FromJSON Type where
 
 parseValue :: Type -> Data.Aeson.Value -> Parser Value
 parseValue Bool =
-    withText "BoolValue" $ \v ->
-        case v of
-             "true" -> return $ BoolValue True
-             "false" -> return $ BoolValue False
-             _ -> fail $ "invalid bool literal: " ++ (T.unpack v)
---parseValue Int =
---    withText "IntValue" $ \v ->
---        case ((signed decimal :: Reader Int64) v) of
---            Left x -> fail $ "invalid int literal: " ++ x
---            Right (val, t) ->
---                if (T.null t)
---                    then return $ IntValue val
---                    else fail $ "invalid int literal: " ++ (T.unpack v)
+    withBool "BoolValue" (return . BoolValue)
+
 parseValue Int =
     withScientific "IntValue" $ \v ->
         if (not (isInteger v))
@@ -233,3 +244,54 @@ parseBrilJSON text = (eitherDecode text :: Either String Program)
 parseBrilFromPath path = do
     contents <- LB.readFile path
     return $ parseBrilJSON contents
+
+instance ToJSON Type where
+    toJSON Bool = toJSON ("bool" :: T.Text)
+    toJSON Int = toJSON ("int" :: T.Text)
+
+instance ToJSON FunctionArg  where
+    toJSON (FunctionArg argName argType) = object [
+            "name" .= argName,
+            "type" .= argType
+        ]
+
+instance ToJSON Value  where
+    toJSON (IntValue val) = toJSON val
+    toJSON (BoolValue val) = toJSON val
+
+instance ToJSON Instruction where
+    toJSON (Label name) = object [ "label" .= name ]
+    toJSON (LiteralInstr value dest) = object [
+            "op" .= ("const" :: T.Text),
+            "dest" .= dest,
+            "type" .= case value of
+                (IntValue _) -> Int
+                (BoolValue _) -> Bool,
+            "value" .= value
+        ]
+    toJSON (EffectInstr op args funcs labels) = object [
+            "op" .= (show op),
+            "args" .= args,
+            "funcs" .= funcs,
+            "labels" .= labels
+        ]
+    toJSON (ValueInstr op type_ dest args funcs labels) = object [
+            "op" .= (show op),
+            "dest" .= dest,
+            "type" .= type_,
+            "args" .= args,
+            "funcs" .= funcs,
+            "labels" .= labels
+        ]
+
+instance ToJSON Function where
+    toJSON (Function name type_ args instrs) = object $ [
+            "name" .= name,
+            "args" .= args,
+            "instrs" .= instrs
+        ] ++ case type_ of
+            Nothing -> []
+            (Just t) -> ["type" .= t]
+
+instance ToJSON Program where
+    toJSON (Program functions) = object [ "functions" .= functions ]

tests/Main.hs

@@ -20,11 +20,9 @@ testTypes = TestCase $ do
 testLiterals :: Test
 testLiterals = TestCase $ do
     assertEqual "true literal"
-        (parseLiteral B.Bool ("true"::Text)) (Success $ B.BoolValue True)
+        (parseLiteral B.Bool True) (Success $ B.BoolValue True)
     assertEqual "false literal"
-        (parseLiteral B.Bool ("false"::Text)) (Success $ B.BoolValue False)
-    assertEqual "wrong bool literal"
-        (parseLiteral B.Bool ("xxx"::Text)) (Error "invalid bool literal: xxx")
+        (parseLiteral B.Bool False) (Success $ B.BoolValue False)
 
     assertEqual "int literal"
         (parseLiteral B.Int (1434 :: Int)) (Success $ B.IntValue 1434)
@@ -79,6 +77,10 @@ testInstrs = TestCase $ do
         (eitherDecode "{\"op\": \"br\", \"labels\": [\"a\", \"b\"], \"args\": [\"z\"]}")
         (Right $ B.EffectInstr B.Br ["z"] [] ["a", "b"])
 
+    assertEqual "parse id"
+        (eitherDecode "{\"op\": \"id\", \"dest\": \"a\", \"type\": \"bool\", \"args\": [\"b\"]}")
+        (Right $ B.ValueInstr B.Id B.Bool "a" ["b"] [] [])
+
 testProgramFromFiles :: Test
 testProgramFromFiles = TestCase $ do
     res <- try $ (B.parseBrilFromPath "bril-sources/add.json") :: IO (Either IOError (Either String B.Program))