diff --git a/eoc.cabal b/eoc.cabal index b4d30e4..8e72702 100644 --- a/eoc.cabal +++ b/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 diff --git a/lib/Bril.hs b/lib/Bril.hs index 53cf580..17a9ac0 100644 --- a/lib/Bril.hs +++ b/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 - do - op <- (v .: "op") :: Parser T.Text - type_ <- (v .: "type") :: Parser Type - case op of - "const" -> LiteralInstr - <$> ((v .: "value") >>= (parseValue type_)) - <*> v .: "dest" + else do + op <- (v .: "op") :: Parser T.Text + parseInstr op v + where + parseInstr op + | op == "const" = parseLiteralInstr + | op `elemOrd` valueOps = parseValueInstr op + | 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 - _ -> fail "Wrong op for instruction" + unexpectedArityError op args labels = + "wrong arity for " ++ (T.unpack op) ++ ": got " ++ (show (length args)) ++ ", " ++ (show (length labels)) instance FromJSON FunctionArg where parseJSON = withObject "FunctionArg" $ \v -> FunctionArg diff --git a/tests/Main.hs b/tests/Main.hs index c106d55..748ab7e 100644 --- a/tests/Main.hs +++ b/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 ()