enrico
/
eoc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Parsing and validation of instructions

This commit is contained in:
Enrico Lumetti 2024-10-05 16:46:10 +02:00
parent 570ca0cb75
commit 5c7e330af1
3 changed files with 154 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
eoc.cabal
View File

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

137
lib/Bril.hs
View File

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

39
tests/Main.hs
View File

@ -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
@ -38,10 +38,45 @@ 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 ()