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

More tests and some refactoring

This commit is contained in:
Enrico Lumetti 2024-10-05 17:02:03 +02:00
parent 5c7e330af1
commit 031b812c51
2 changed files with 22 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
lib/Bril.hs
View File

@ -6,7 +6,7 @@ module Bril (
import Data.Aeson (FromJSON, parseJSON, withObject, withText, (.:), (.:?), decode)
import Data.Aeson.Types (Parser, modifyFailure)
import qualified Data.Aeson (Value)
import qualified Data.Aeson (Value, Object, Key)
import Data.Aeson.KeyMap
import Data.Int (Int64)
import qualified Data.Text as T
@ -115,6 +115,11 @@ instrFromString s
| s == "nop" = Nop
| otherwise = error "wrong instruction name"
optionalArrayField :: FromJSON a => Data.Aeson.Object -> Data.Aeson.Key -> Parser [a]
optionalArrayField v field =
((v .:? field) >>= (return . fromMaybe []))
instance FromJSON Program where
parseJSON = withObject "Program" $ \v -> Program
<$> v .: "functions"
@ -122,8 +127,8 @@ instance FromJSON Program where
instance FromJSON Function where
parseJSON = withObject "Function" $ \v -> Function
<$> v .: "name"
<*> v .: "type"
<*> v .: "args"
<*> v .:? "type"
<*> v `optionalArrayField` "args"
<*> v .: "instrs"
instance FromJSON Instruction where
@ -146,9 +151,9 @@ instance FromJSON Instruction where
<*> 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]
args <- (v `optionalArrayField` "args") :: Parser [VarName]
labels <- (v `optionalArrayField` "labels") :: Parser [VarName]
funcs <- (v `optionalArrayField` "funcs") :: Parser [VarName]
let instr = instrFromString op
if not (checkArity instr args labels)
then fail $ unexpectedArityError op args labels
@ -160,9 +165,9 @@ instance FromJSON Instruction where
<*> 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]
args <- (v `optionalArrayField` "args") :: Parser [VarName]
labels <- (v `optionalArrayField` "labels") :: Parser [VarName]
funcs <- (v `optionalArrayField` "funcs") :: 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\""

8
tests/Main.hs
View File

@ -72,6 +72,14 @@ testInstrs = TestCase $ do
(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)
assertEqual "parse jmp"
(eitherDecode "{\"op\": \"jmp\", \"labels\": [\"a\"]}")
(Right $ B.EffectInstr B.Jmp [] [] ["a"])
assertEqual "parse br"
(eitherDecode "{\"op\": \"br\", \"labels\": [\"a\", \"b\"], \"args\": [\"z\"]}")
(Right $ B.EffectInstr B.Br ["z"] [] ["a", "b"])
tests :: Test
tests = TestList [
TestLabel "bril parser: type" testTypes,