module Language.Pascal.Types where
import Control.Monad.State
import Control.Monad.Error
import qualified Data.Map as M
import Data.List (intercalate)
import Text.Printf
import Language.SSVM.Types
type Id = String
data Annotate node ann = Annotate {
content :: node,
annotation :: ann }
deriving (Eq)
instance (Show node) => Show (Annotate node ann) where
show (Annotate x _) = show x
data SrcPos = SrcPos {
srcLine :: Int,
srcColumn :: Int }
deriving (Eq)
instance Show SrcPos where
show (SrcPos l c) = printf "[l. %d, c. %d]" l c
data TypeAnn = TypeAnn {
srcPos :: SrcPos,
typeOf :: Type,
localSymbols :: M.Map Id Symbol }
deriving (Eq, Show)
type node :~ ann = Annotate (node ann) ann
withType :: Annotate a SrcPos -> Type -> Annotate a TypeAnn
withType (Annotate x pos) t = Annotate x $ TypeAnn {
srcPos = pos,
typeOf = t,
localSymbols = M.empty}
setType :: Annotate Symbol a -> Type -> Annotate Symbol a
setType (Annotate s pos) t = Annotate (s {symbolType = t}) pos
annotate :: ann -> Annotate node old -> Annotate node ann
annotate a (Annotate x _) = Annotate x a
data Program a = Program {
progConsts :: [(Id, Expression :~ a)],
progTypes :: M.Map Id Type,
progVariables :: [Annotate Symbol a],
progFunctions :: [Function :~ a],
progBody :: [Statement :~ a]
}
deriving (Eq, Show)
data Function a = Function {
fnName :: String,
fnFormalArgs :: [Annotate Symbol a],
fnResultType :: Type,
fnVars :: [Annotate Symbol a],
fnBody :: [Statement :~ a]
}
deriving (Eq, Show)
type SymbolTable = [M.Map Id Symbol]
data Symbol = Symbol {
symbolName :: Id,
symbolType :: Type,
symbolDefLine :: Int,
symbolDefCol :: Int
}
deriving (Eq)
instance Show Symbol where
show (Symbol {..}) = symbolName ++ ": " ++ show symbolType
showSymbol :: Symbol -> String
showSymbol (Symbol {..}) =
printf "%s: %s (defined at l.%d, c.%d)"
symbolName (show symbolType) symbolDefLine symbolDefCol
symbolNameC :: Annotate Symbol ann -> Id
symbolNameC = symbolName . content
symbolTypeC :: Annotate Symbol ann -> Type
symbolTypeC = symbolType . content
typeOfA :: Annotate node TypeAnn -> Type
typeOfA = typeOf . annotation
(#) :: Id -> Type -> Symbol
name # tp = Symbol {
symbolName = name,
symbolType = tp,
symbolDefLine = 0,
symbolDefCol = 0 }
data Type =
TInteger
| TString
| TBool
| TVoid
| TUser Id
| TAny
| TArray Integer Type
| TRecord [(Id, Type)]
| TField Int Type
| TFunction [Type] Type
deriving (Eq)
instance Show Type where
show TInteger = "integer"
show TString = "string"
show TBool = "boolean"
show TVoid = "void"
show (TUser s) = s
show TAny = "any"
show (TArray sz t) = printf "array [%d] of %s" sz (show t)
show (TRecord pairs) = "record " ++ intercalate ", " (map s pairs) ++ " end"
where
s (i,t) = i ++ ": " ++ show t
show (TField _ t) = "record field of type " ++ show t
show (TFunction args TVoid) =
"procedure (" ++ intercalate ", " (map show args) ++ ")"
show (TFunction args res) =
"function (" ++ intercalate ", " (map show args) ++ "): " ++ show res
data LValue a =
LVariable Id
| LArray Id (Expression :~ a)
| LField Id Id
deriving (Eq)
instance Show (LValue a) where
show (LVariable n) = n
show (LArray a i) = printf "%s[%s]" a (show i)
show (LField r f) = r ++ "." ++ f
data Statement a =
Assign (LValue :~ a) (Expression :~ a)
| Procedure Id [Expression :~ a]
| Return (Expression :~ a)
| Break
| Continue
| Exit
| IfThenElse (Expression :~ a) [Statement :~ a] [Statement :~ a]
| For Id (Expression :~ a) (Expression :~ a) [Statement :~ a]
deriving (Eq)
instance Show (Statement a) where
show (Assign lvalue expr) = show lvalue ++ " := " ++ show expr ++ ";"
show (Procedure name args) = name ++ "(" ++ intercalate ", " (map show args) ++ ");"
show Break = "break;"
show Continue = "continue;"
show Exit = "exit;"
show (Return e) = "return " ++ show e ++ ";"
show (IfThenElse c a b) = "if " ++ show c ++ " then " ++ show a ++ "else" ++ show b ++ ";"
show (For name start end body) = "for " ++ name ++ " := " ++ show start ++ " to " ++ show end ++ show body
data Lit =
LInteger Integer
| LString String
| LBool Bool
deriving (Eq)
instance Show Lit where
show (LInteger i) = show i
show (LString s) = s
show (LBool b) = show b
data Expression a =
Variable Id
| ArrayItem Id (Expression :~ a)
| RecordField Id Id
| Literal Lit
| Call Id [Expression :~ a]
| Op BinOp (Expression :~ a) (Expression :~ a)
deriving (Eq)
instance Show (Expression a) where
show (Variable x) = x
show (ArrayItem name ix) = printf "%s[%s]" name (show ix)
show (RecordField name field) = name ++ "." ++ field
show (Literal x) = show x
show (Call name args) = name ++ "(" ++ intercalate ", " (map show args) ++ ")"
show (Op op x y) = "(" ++ show x ++ " " ++ show op ++ " " ++ show y ++ ")"
data BinOp =
Add
| Sub
| Mul
| Div
| Mod
| Pow
| IsGT
| IsLT
| IsEQ
| IsNE
deriving (Eq)
instance Show BinOp where
show Add = "+"
show Sub = "-"
show Mul = "*"
show Div = "/"
show Mod = "%"
show Pow = "^"
show IsGT = ">"
show IsLT = "<"
show IsEQ = "="
show IsNE = "!="
data TError = TError {
errLine :: Int,
errColumn :: Int,
errContext :: Context,
errMessage :: String }
deriving (Eq)
instance Show TError where
show (TError {..}) =
printf "[l.%d, c.%d] (in %s): %s" errLine errColumn (show errContext) errMessage
instance Error TError where
noMsg = TError 0 0 Unknown "Unknown error"
strMsg s = TError 0 0 Unknown s
data Context =
Unknown
| Outside
| ProgramBody
| ForLoop Id Int
| InFunction Id Type
deriving (Eq)
instance Show Context where
show Unknown = "unknown context"
show Outside = "outside program body"
show ProgramBody = "program body"
show (ForLoop i _) = "for loop with counter: " ++ i
show (InFunction name TVoid) = "procedure " ++ name
show (InFunction name tp) = printf "function %s(): %s" name (show tp)
contextId :: Context -> String
contextId Unknown = "unknown"
contextId Outside = "main"
contextId ProgramBody = "main"
contextId (ForLoop i n) = "for_" ++ i ++ "_at_" ++ show n
contextId (InFunction name _) = name
data CheckState = CheckState {
userTypes :: M.Map Id Type,
userConsts :: [(Id, Expression :~ TypeAnn)],
symbolTable :: SymbolTable,
contexts :: [Context],
ckLine :: Int,
ckColumn :: Int }
deriving (Eq, Show)
data CodeGenState = CGState {
constants :: [(Id, Lit)],
variables :: [Id],
currentContext :: [Context],
quoteMode :: Bool,
generated :: Code }
deriving (Eq, Show)
emptyGState :: CodeGenState
emptyGState = CGState {
constants = [],
variables = [],
currentContext = [],
quoteMode = False,
generated = Code [M.empty] [] }
newtype Generate a = Generate {runGenerate :: ErrorT TError (State CodeGenState) a}
deriving (Monad, MonadState CodeGenState, MonadError TError)
newtype Check a = Check {runCheck :: ErrorT TError (State CheckState) a}
deriving (Monad, MonadError TError, MonadState CheckState)
class (Monad m) => Checker m where
enterContext :: Context -> m ()
dropContext :: m ()
failCheck :: String -> m a
inContext :: (Checker m) => Context -> m a -> m a
inContext cxt actions = do
enterContext cxt
x <- actions
dropContext
return x