Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: c38b6071df
Fetching contributors…

Cannot retrieve contributors at this time

176 lines (140 sloc) 5.148 kB
> module Epic.Language where
> import Control.Monad
Raw data types. Int, Char, Bool are unboxed.
> data Type = TyInt
> | TyChar
> | TyBool
> | TyFloat
> | TyBigInt
> | TyBigFloat
> | TyString
> | TyPtr
> | TyUnit
> | TyAny -- unchecked, polymorphic
> | TyData -- generic data type
> | TyFun -- any function
> deriving Eq
> instance Show Type where
> show TyInt = "Int"
> show TyChar = "Char"
> show TyBool = "Bool"
> show TyFloat = "Float"
> show TyBigInt = "BigInt"
> show TyBigFloat = "BigFloat"
> show TyString = "String"
> show TyPtr = "Ptr"
> show TyUnit = "Unit"
> show TyAny = "Any"
> show TyData = "Data"
> show TyFun = "Fun"
> data Const = MkInt Int
> | MkBigInt Integer
> | MkChar Char
> | MkFloat Float
> | MkBigFloat Double
> | MkString String
> | MkBool Bool
> | MkUnit
> deriving (Show, Eq)
> data Name = UN String -- user name
> | MN String Int -- machine generated name
> deriving Eq
> instance Show Name where
> show (UN str) = "_U_"++str
> show (MN str i) = "_M_"++show i++"_"++str
> showuser (UN str) = str
> showuser (MN str i) = "["++str++"_"++show i++"]"
> quotename [] = ""
> quotename ('_':cs) = "__"++quotename cs
> quotename ('\'':cs) = "_PR_"++quotename cs
> quotename ('?':cs) = "_QU_"++quotename cs
> quotename ('$':cs) = "_DO_"++quotename cs
> quotename ('#':cs) = "_HA_"++quotename cs
> quotename ('@':cs) = "_AT_"++quotename cs
> quotename (c:cs) = c:(quotename cs)
> showC n = quotename (show n)
> type Context = [(Name,([Type],Type))] -- Name, arg types, return type
Get the arity of a definition in the context
> arity x ctxt = case lookup x ctxt of
> Nothing -> error $ "No such function " ++ show x
> (Just (args,ret)) -> length args
> type Tag = Int
> data Expr = V Int -- Locally bound name
> | R Name -- Global reference
> | App Expr [Expr] -- Function application
> | Lazy Expr -- Lazy function application
> | Con Tag [Expr] -- Constructor, tags, arguments (fully applied)
> | Const Const -- a constant
> | Proj Expr Int -- Project argument
> | Case Expr [CaseAlt]
> | If Expr Expr Expr
> | Op Op Expr Expr -- Infix operator
> | Let Name Type Expr Expr -- Let binding
> | Error String -- Exit with error message
> | Impossible -- Claimed impossible to reach code
> | ForeignCall Type String [(Expr, Type)] -- Foreign function call
> | LazyForeignCall Type String [(Expr, Type)] -- Foreign function call
> deriving (Show, Eq)
> data CaseAlt = Alt { alt_tag :: Tag,
> alt_args :: [(Name, Type)], -- bound arguments
> alt_expr :: Expr -- what to do
> }
> | ConstAlt { alt_const :: Int,
> alt_expr :: Expr }
> | DefaultCase { alt_expr :: Expr }
> deriving (Show, Eq)
> instance Ord CaseAlt where -- only the tag matters
> compare (Alt t1 _ _) (Alt t2 _ _) = compare t1 t2
> compare (Alt _ _ _) (DefaultCase _) = LT
> compare (DefaultCase _) (Alt _ _ _) = GT
> compare _ _ = EQ
> data Op = Plus | Minus | Times | Divide | OpEQ | OpLT | OpLE | OpGT | OpGE
> deriving (Show, Eq)
Supercombinator definitions
> data Func = Bind { fun_args :: [(Name, Type)],
> locals :: Int, -- total number of locals
> defn :: Expr }
> deriving Show
Programs
> data Decl = Decl { fname :: Name,
> frettype :: Type,
> fdef :: Func,
> fexport :: Maybe String, -- C name
> fcompflags :: [CGFlag]
> }
> | Extern { fname :: Name,
> frettype :: Type,
> fargs :: [Type] }
> | Include String
> | Link String
> | CType Name
> deriving Show
> data CGFlag = Inline
> deriving (Show, Eq)
> data Result r = Success r
> | Failure String String Int
> deriving (Show, Eq)
>
> instance Monad Result where
> (Success r) >>= k = k r
> (Failure err fn line) >>= k = Failure err fn line
> return = Success
> fail s = Failure s "(no file)" 0
>
> instance MonadPlus Result where
> mzero = Failure "Error" "(no file)" 0
> mplus (Success x) _ = (Success x)
> mplus (Failure _ _ _) y = y
>
Some tests
foo x = let y = case x of
c1 a b -> a b
c2 c -> bar (c+2)
in y+3
testctxt = [((UN "foo"),([TyData], TyInt)),
((UN "bar"),([TyInt], TyInt))]
testprog = Bind [TyData] 3 $
Let (UN "y") TyInt (Case (V 0)
[Alt 0 [TyFun,TyInt] (App (V 1) [V 2]),
Alt 1 [TyInt] (App (R (UN "bar")) [Op Plus (V 1) (Const (MkInt 2))])])
(Op Plus (V 1) (Const (MkInt 3)))
Jump to Line
Something went wrong with that request. Please try again.