Parsing and validation of instructions

eoc.cabal

@@ -22,7 +22,8 @@ library eoc-lib
     build-depends:
         base >=4.13 && <4.18,
         text >= 2.0,
-        aeson >= 2.2
+        aeson >= 2.2,
+        sorted-list ^>= 0.2
     default-language: Haskell2010
   default-extensions: DeriveGeneric, OverloadedStrings
 

lib/Bril.hs

@@ -1,15 +1,18 @@
 module Bril (
-    Function (..), Type (..), Value (..), FunctionArg (..), Program (..),
+    Function (..), Type (..), Value (..), InstrOperation (..), FunctionArg (..), Program (..),
+    Instruction (..),
     parseValue,
     )where
 
-import Data.Aeson (FromJSON, parseJSON, withObject, withText, (.:), decode)
+import Data.Aeson (FromJSON, parseJSON, withObject, withText, (.:), (.:?), decode)
 import Data.Aeson.Types (Parser, modifyFailure)
 import qualified Data.Aeson (Value)
 import Data.Aeson.KeyMap
 import Data.Int (Int64)
 import qualified Data.Text as T
 import Data.Text.Read (Reader, signed, decimal)
+import Data.SortedList
+import Data.Maybe (fromMaybe, isJust)
 
 
 data Program = Program { programFns :: [Function] }
@@ -36,26 +39,25 @@ data FunctionArg = FunctionArg {
     } deriving (Show, Eq)
 
 data Instruction =
-    Label { name :: String }
+    Label String
   | LiteralInstr {
         value :: Value,
         dest :: VarName
     }
   | ValueInstr {
+       op :: InstrOperation,
+       type_ :: Type,
+       dest :: VarName,
+       args :: [VarName],
+       funcs :: [FuncName],
+       labels :: [String]
+     }
+   | EffectInstr {
         op :: InstrOperation,
-        value :: Value,
         args :: [VarName],
-        dest :: VarName,
         funcs :: [FuncName],
         labels :: [String]
-    }
+     }
-  | EffectInstr {
-        op :: InstrOperation,
-        value :: Value,
-        dest :: VarName,
-        funcs :: [FuncName],
-        labels :: [String]
-    }
    deriving (Show, Eq)
 
 data InstrOperation =
@@ -63,6 +65,56 @@ data InstrOperation =
     Jmp | Br | Call | Ret | Id | Print | Nop | Phi
    deriving (Eq, Show)
 
+data Arity =
+    Arity Int Int Int -- min, max, labels arity
+  | VarArgs
+   deriving (Eq, Show)
+
+valueOps = toSortedList ([
+        "add", "mul", "sub", "div", "eq", "lt", "gt", "le", "ge", "not", "and", "or"
+    ] :: [T.Text])
+
+effectOps = toSortedList ([
+        "nop", "call", "jmp", "br", "print", "lt", "gt", "le", "ge", "not", "and", "or"
+    ] :: [T.Text])
+
+arity instr
+    | instr `elem` [Add, Mul, Sub, Div, Eq, Lt, Gt, Le, Ge, And, Or] = Arity 2 2 0
+    | instr `elem` [Id, Not] = Arity 1 1 0
+    | instr == Ret  = Arity 0 1 0
+    | instr == Jmp = Arity 0 0 1
+    | instr == Br = Arity 1 1 2
+    | instr == Nop = Arity 0 0 0
+    | otherwise = VarArgs
+
+checkArity :: InstrOperation -> [b] -> [c] -> Bool
+checkArity instr args labels =
+    case arity instr of
+        Arity n m l ->
+            (((length args) >= n) && ((length args) <= m)) && ((length labels) == l)
+        VarArgs -> True
+
+instrFromString s
+    | s == "add" = Add
+    | s == "sub" = Sub
+    | s == "mul" = Mul
+    | s == "eq" = Eq
+    | s == "lt" = Lt
+    | s == "gt" = Gt
+    | s == "le" = Le
+    | s == "ge" = Ge
+    | s == "not" = Not
+    | s == "and" = And
+    | s == "or" = Or
+    | s == "jmp" = Jmp
+    | s == "br" = Br
+    | s == "ret" = Ret
+    | s == "call" = Call
+    | s == "print" = Print
+    | s == "id" = Id
+    | s == "nop" = Nop
+    | otherwise = error "wrong instruction name"
+
 instance FromJSON Program  where
     parseJSON = withObject "Program" $ \v -> Program
         <$> v .: "functions"
@@ -78,17 +130,56 @@ instance FromJSON Instruction where
     parseJSON = withObject "Instruction" $ \v ->
         if (Data.Aeson.KeyMap.member "label" v)
             then Label <$> v .: "label"
-            else
+            else do
-                do
+                op <- (v .: "op") :: Parser T.Text
-                    op <- (v .: "op") :: Parser T.Text
+                parseInstr op v
-                    type_ <- (v .: "type") :: Parser Type
+     where
-                    case op of
+        parseInstr op
-                        "const" -> LiteralInstr
+            | op == "const" = parseLiteralInstr
-                                   <$> ((v .: "value") >>= (parseValue type_))
+            | op `elemOrd` valueOps = parseValueInstr op
-                                   <*> v .: "dest"
+            | op `elemOrd` effectOps = parseEffectInstr op
+            | otherwise = const $ fail ("Invalid op: " ++ (T.unpack op))
+        parseLiteralInstr v = do
+            type_ <- (v .: "type") :: Parser Type
+            LiteralInstr
+                <$> ((v .: "value") >>= (parseValue type_))
+                <*> v .: "dest"
+        parseValueInstr op v = do
+            dest  <- (v .: "dest") :: Parser VarName
+            args  <- ((v .:? "args") >>= (return . fromMaybe [])) :: Parser [VarName]
+            labels  <- ((v .:? "labels") >>= (return . fromMaybe [])) :: Parser [VarName]
+            funcs  <- ((v .:? "funcs") >>= (return . fromMaybe [])) :: Parser [VarName]
+            let instr = instrFromString op
+            if not (checkArity instr args labels)
+                then fail $ unexpectedArityError op args labels
+                else ValueInstr
+                    <$> return instr
+                    <*> v .: "type"
+                    <*> v .: "dest"
+                    <*> return args
+                    <*> return funcs
+                    <*> return labels
+        parseEffectInstr op v = do
+            args <- ((v .:? "args") >>= (return . fromMaybe [])) :: Parser [VarName]
+            labels  <- ((v .:? "labels") >>= (return . fromMaybe [])) :: Parser [VarName]
+            funcs  <- ((v .:? "funcs") >>= (return . fromMaybe [])) :: Parser [VarName]
+            dest <- (v .:? "dest") :: Parser (Maybe VarName)
+            if (op == "call") && ((length funcs) /= 1)
+                then fail $ "call op must have exactly one entry in \"funcs\""
+                else if (isJust dest) && (op == "call")
+                    then parseValueInstr op v
+                    else do
+                        let instr = instrFromString op
+                        if not (checkArity instr args labels)
+                            then fail $ unexpectedArityError op args labels
+                            else EffectInstr
+                                <$> return instr
+                                <*> return args
+                                <*> return funcs
+                                <*> return labels
 
-                        "add" -> undefined
+        unexpectedArityError op args labels =
-                        _ -> fail "Wrong op for instruction"
+            "wrong arity for " ++ (T.unpack op) ++ ": got " ++ (show (length args)) ++ ", " ++ (show (length labels))
 
 instance FromJSON FunctionArg where
     parseJSON = withObject "FunctionArg" $ \v -> FunctionArg

tests/Main.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import qualified Bril as B
-import Data.Aeson (decode, toJSON, parseJSON, Result(..))
+import Data.Aeson (eitherDecode, decode, toJSON, parseJSON, Result(..))
 import Data.Aeson.Types (parse)
 import Data.Text
 import Data.Maybe
@@ -37,11 +37,46 @@ testLiterals = TestCase $ do
 
     where
         parseLiteral type_ x = (parse (B.parseValue type_) (toJSON (x::Text)))
- 
+
+testInstrs :: Test
+testInstrs = TestCase $ do
+    assertEqual "add instr"
+        (eitherDecode "{\"op\": \"add\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"]}")
+        (Right $ B.ValueInstr B.Add B.Int "x" ["a", "b"] [] [])
+
+    assertEqual "sub instr"
+        (decode "{\"op\": \"sub\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"]}")
+        (Just $ B.ValueInstr B.Sub B.Int "x" ["a", "b"] [] [])
+
+    assertEqual "wrong instr"
+        (eitherDecode "{\"op\": \"wrnog\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"]}")
+        (Left "Error in $: Invalid op: wrnog" :: Either String B.Instruction)
+
+    assertEqual "wrong arity"
+        (eitherDecode "{\"op\": \"add\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"b\"]}")
+        (Left "Error in $: wrong arity for add: got 1, 0" :: Either String B.Instruction)
+
+    assertEqual "wrong label arity"
+        (eitherDecode "{\"op\": \"add\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"], \"labels\": [\"a\"]}")
+        (Left "Error in $: wrong arity for add: got 2, 1" :: Either String B.Instruction)
+
+    assertEqual "parse effect call"
+        (eitherDecode "{\"op\": \"call\", \"args\": [\"a\", \"b\"], \"funcs\": [\"a\"]}")
+        (Right $ B.EffectInstr B.Call ["a", "b"] ["a"] [])
+
+    assertEqual "parse value call"
+        (eitherDecode "{\"op\": \"call\", \"type\": \"bool\", \"dest\": \"z\", \"args\": [\"a\", \"b\"], \"funcs\": [\"a\"]}")
+        (Right $ B.ValueInstr B.Call B.Bool "z" ["a", "b"] ["a"] [])
+
+    assertEqual "parse invalid call"
+        (eitherDecode "{\"op\": \"call\", \"type\": \"bool\", \"dest\": \"z\", \"args\": [\"a\", \"b\"], \"funcs\": []}")
+        (Left "Error in $: call op must have exactly one entry in \"funcs\"" :: Either String B.Instruction)
+
 tests :: Test
 tests = TestList [
         TestLabel "bril parser: type" testTypes,
-        TestLabel "bril parser: literal" testLiterals
+        TestLabel "bril parser: literal" testLiterals,
+        TestLabel "bril parser: instruction" testInstrs
     ]
  
 main :: IO ()