module Bril ( Function (..), Type (..), Value (..), InstrOperation (..), FunctionArg (..), Program (..), Instruction (..), parseValue, parseBrilFromPath, parseBrilJSON, )where 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 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) import Data.Scientific (isInteger, toBoundedInteger) import qualified Data.ByteString.Lazy as LB data Program = Program { programFns :: [Function] } deriving (Show, Eq) type VarName = String type FuncName = String data Function = Function { functionName :: FuncName, returnType :: Maybe Type, functionArgs :: [FunctionArg], instructions :: [Instruction] } deriving (Show, Eq) data Type = Int | Bool deriving (Show, Eq) data Value = IntValue Int64 | BoolValue Bool deriving (Eq, Show) data FunctionArg = FunctionArg { argName :: VarName, argType :: Type } deriving (Show, Eq) data Instruction = Label String | LiteralInstr { value :: Value, dest :: VarName } | ValueInstr { op :: InstrOperation, type_ :: Type, dest :: VarName, args :: [VarName], funcs :: [FuncName], labels :: [String] } | EffectInstr { op :: InstrOperation, args :: [VarName], funcs :: [FuncName], labels :: [String] } deriving (Show, Eq) data InstrOperation = Add | Mul | Sub | Div | Eq | Lt | Gt | Le | Ge | Not | And | Or | Jmp | Br | Call | Ret | Id | Print | Nop | Phi deriving (Eq) 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", "id" ] :: [T.Text]) effectOps = toSortedList ([ "nop", "call", "jmp", "br", "print", "ret" ] :: [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 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 [])) instance FromJSON Program where parseJSON = withObject "Program" $ \v -> Program <$> v .: "functions" instance FromJSON Function where parseJSON = withObject "Function" $ \v -> Function <$> v .: "name" <*> v .:? "type" <*> v `optionalArrayField` "args" <*> v .: "instrs" 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 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 `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 else ValueInstr <$> return instr <*> v .: "type" <*> v .: "dest" <*> return args <*> return funcs <*> return labels parseEffectInstr op v = do 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\"" 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 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 <$> v .: "name" <*> v .: "type" instance FromJSON Type where parseJSON = withText "Type" $ \v -> case v of "int" -> return Int "bool" -> return Bool _ -> fail "wrong type" parseValue :: Type -> Data.Aeson.Value -> Parser Value parseValue Bool = withBool "BoolValue" (return . BoolValue) parseValue Int = withScientific "IntValue" $ \v -> if (not (isInteger v)) then fail $ "Invalid integer literal: " ++ (show v) else do let num = toBoundedInteger v :: Maybe Int64 case num of (Just n) -> return $ IntValue n _ -> fail $ "Integer exceeds int64: " ++ (show v) 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 ]