I updated the External Core AST to be somewhat closer to reality (where reality is defined by the HEAD), and got all the code to compile under GHC 6.8.1. (That means it works, right?)
Major changes:
- Added a Makefile.
- Core AST:
- Represented package names and qualified module names.
- Added type annotation on Case exps.
- Changed Coerce to Cast.
- Cleaned up representation of qualified/unqualified names.
- Fixed up wired-in module names (no more "PrelGHC", etc.)
- Updated parser/interpreter/typechecker/prep for the new AST.
- Typechecker:
- Used a Reader monad to pass around the global environment and top module name.
- Added an entry point to check a single expression.
- Prep:
- Got rid of typeofExp; it's now defined in terms of the typechecker.
module Check where
-import Monad
+import Maybe
+import Control.Monad.Reader
+
import Core
import Printer
import List
allowing errors to be captured, this makes it easy to guarantee
that checking itself has been completed for an entire module. -}
-data CheckResult a = OkC a | FailC String
+{- We use the Reader monad transformer in order to thread the
+ top-level module name throughout the computation simply.
+ This is so that checkExp can also be an entry point (we call it
+ from Prep.) -}
+data CheckRes a = OkC a | FailC String
+type CheckResult a = ReaderT (AnMname, Menv) CheckRes a
+getMname :: CheckResult AnMname
+getMname = ask >>= (return . fst)
+getGlobalEnv :: CheckResult Menv
+getGlobalEnv = ask >>= (return . snd)
-instance Monad CheckResult where
+instance Monad CheckRes where
OkC a >>= k = k a
FailC s >>= k = fail s
return = OkC
type Tsenv = Env Tcon ([Tvar],Ty) -- type synonyms
type Cenv = Env Dcon Ty -- data constructors
type Venv = Env Var Ty -- values
-type Menv = Env Mname Envs -- modules
+type Menv = Env AnMname Envs -- modules
data Envs = Envs {tcenv_::Tcenv,tsenv_::Tsenv,cenv_::Cenv,venv_::Venv} -- all the exportable envs
{- Extend an environment, checking for illegal shadowing of identifiers. -}
Nothing -> fail ("undefined identifier: " ++ show k)
{- Main entry point. -}
-checkModule :: Menv -> Module -> CheckResult Menv
-checkModule globalEnv (Module mn tdefs vdefgs) =
- do (tcenv,tsenv) <- foldM checkTdef0 (eempty,eempty) tdefs
- cenv <- foldM (checkTdef tcenv) eempty tdefs
- (e_venv,l_venv) <- foldM (checkVdefg True (tcenv,tsenv,eempty,cenv)) (eempty,eempty) vdefgs
- return (eextend globalEnv (mn,Envs{tcenv_=tcenv,tsenv_=tsenv,cenv_=cenv,venv_=e_venv}))
- where
+checkModule :: Menv -> Module -> CheckRes Menv
+checkModule globalEnv mod@(Module mn tdefs vdefgs) =
+ runReaderT
+ (do (tcenv, tsenv, cenv) <- mkTypeEnvs tdefs
+ (e_venv,l_venv) <- foldM (checkVdefg True (tcenv,tsenv,eempty,cenv))
+ (eempty,eempty)
+ vdefgs
+ return (eextend globalEnv
+ (mn,Envs{tcenv_=tcenv,tsenv_=tsenv,cenv_=cenv,venv_=e_venv})))
+ (mn, globalEnv)
- checkTdef0 :: (Tcenv,Tsenv) -> Tdef -> CheckResult (Tcenv,Tsenv)
- checkTdef0 (tcenv,tsenv) tdef = ch tdef
+checkTdef0 :: (Tcenv,Tsenv) -> Tdef -> CheckResult (Tcenv,Tsenv)
+checkTdef0 (tcenv,tsenv) tdef = ch tdef
where
ch (Data (m,c) tbs _) =
- do require (m == mn) ("wrong module name in data type declaration:\n" ++ show tdef)
+ do mn <- getMname
+ requireModulesEq m mn "data type declaration" tdef False
tcenv' <- extendM tcenv (c,k)
return (tcenv',tsenv)
where k = foldr Karrow Klifted (map snd tbs)
ch (Newtype (m,c) tbs rhs) =
- do require (m == mn) ("wrong module name in newtype declaration:\n" ++ show tdef)
+ do mn <- getMname
+ requireModulesEq m mn "newtype declaration" tdef False
tcenv' <- extendM tcenv (c,k)
tsenv' <- case rhs of
Nothing -> return tsenv
return (tcenv', tsenv')
where k = foldr Karrow Klifted (map snd tbs)
- checkTdef :: Tcenv -> Cenv -> Tdef -> CheckResult Cenv
- checkTdef tcenv cenv = ch
+checkTdef :: Tcenv -> Cenv -> Tdef -> CheckResult Cenv
+checkTdef tcenv cenv = ch
where
ch (Data (_,c) utbs cdefs) =
do cbinds <- mapM checkCdef cdefs
foldM extendM cenv cbinds
where checkCdef (cdef@(Constr (m,dcon) etbs ts)) =
- do require (m == mn) ("wrong module name in constructor declaration:\n" ++ show cdef)
+ do mn <- getMname
+ requireModulesEq m mn "constructor declaration" cdef
+ False
tvenv <- foldM extendM eempty tbs
ks <- mapM (checkTy (tcenv,tvenv)) ts
mapM_ (\k -> require (baseKind k)
("higher-order kind in:\n" ++ show cdef ++ "\n" ++
"kind: " ++ show k) ) ks
- return (dcon,t)
+ return (dcon,t mn)
where tbs = utbs ++ etbs
- t = foldr Tforall
+ t mn = foldr Tforall
(foldr tArrow
- (foldl Tapp (Tcon (mn,c))
+ (foldl Tapp (Tcon (Just mn,c))
(map (Tvar . fst) utbs)) ts) tbs
ch (tdef@(Newtype c tbs (Just t))) =
do tvenv <- foldM extendM eempty tbs
ch (tdef@(Newtype c tbs Nothing)) =
{- should only occur for recursive Newtypes -}
return cenv
-
- checkVdefg :: Bool -> (Tcenv,Tsenv,Tvenv,Cenv) -> (Venv,Venv) -> Vdefg -> CheckResult (Venv,Venv)
- checkVdefg top_level (tcenv,tsenv,tvenv,cenv) (e_venv,l_venv) vdefg =
+mkTypeEnvs :: [Tdef] -> CheckResult (Tcenv, Tsenv, Cenv)
+mkTypeEnvs tdefs = do
+ (tcenv, tsenv) <- foldM checkTdef0 (eempty,eempty) tdefs
+ cenv <- foldM (checkTdef tcenv) eempty tdefs
+ return (tcenv, tsenv, cenv)
+
+requireModulesEq :: Show a => Mname -> AnMname -> String -> a
+ -> Bool -> CheckResult ()
+requireModulesEq (Just mn) m msg t _ = require (mn == m) (mkErrMsg msg t)
+requireModulesEq Nothing m msg t emptyOk = require emptyOk (mkErrMsg msg t)
+
+mkErrMsg :: Show a => String -> a -> String
+mkErrMsg msg t = "wrong module name in " ++ msg ++ ":\n" ++ show t
+
+checkVdefg :: Bool -> (Tcenv,Tsenv,Tvenv,Cenv) -> (Venv,Venv)
+ -> Vdefg -> CheckResult (Venv,Venv)
+checkVdefg top_level (tcenv,tsenv,tvenv,cenv) (e_venv,l_venv) vdefg =
case vdefg of
Rec vdefs ->
do e_venv' <- foldM extendM e_venv e_vts
l_venv' <- foldM extendM l_venv l_vts
let env' = (tcenv,tsenv,tvenv,cenv,e_venv',l_venv')
mapM_ (\ (vdef@(Vdef ((m,v),t,e))) ->
- do require (m == "" || m == mn) ("wrong module name in value definition:\n" ++ show vdef)
+ do mn <- getMname
+ requireModulesEq m mn "value definition" vdef True
k <- checkTy (tcenv,tvenv) t
require (k==Klifted) ("unlifted kind in:\n" ++ show vdef)
t' <- checkExp env' e
"declared type: " ++ show t ++ "\n" ++
"expression type: " ++ show t')) vdefs
return (e_venv',l_venv')
- where e_vts = [ (v,t) | Vdef ((m,v),t,_) <- vdefs, m /= "" ]
- l_vts = [ (v,t) | Vdef (("",v),t,_) <- vdefs]
+ where e_vts = [ (v,t) | Vdef ((Just _,v),t,_) <- vdefs ]
+ l_vts = [ (v,t) | Vdef ((Nothing,v),t,_) <- vdefs]
Nonrec (vdef@(Vdef ((m,v),t,e))) ->
- do require (m == "" || m == mn) ("wrong module name in value definition:\n" ++ show vdef)
+ do mn <- getMname
+ requireModulesEq m mn "value definition" vdef True
k <- checkTy (tcenv,tvenv) t
require (k /= Kopen) ("open kind in:\n" ++ show vdef)
require ((not top_level) || (k /= Kunlifted)) ("top-level unlifted kind in:\n" ++ show vdef)
("declared type doesn't match expression type in:\n" ++ show vdef ++ "\n" ++
"declared type: " ++ show t ++ "\n" ++
"expression type: " ++ show t')
- if m == "" then
+ if isNothing m then
do l_venv' <- extendM l_venv (v,t)
return (e_venv,l_venv')
else
do e_venv' <- extendM e_venv (v,t)
return (e_venv',l_venv)
- checkExp :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Exp -> CheckResult Ty
- checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv) = ch
+checkExpr :: AnMname -> Menv -> [Tdef] -> Venv -> Tvenv
+ -> Exp -> Ty
+checkExpr mn menv tdefs venv tvenv e = case (runReaderT (do
+ (tcenv, tsenv, cenv) <- mkTypeEnvs tdefs
+ checkExp (tcenv, tsenv, tvenv, cenv, venv, eempty) e)
+ (mn, menv)) of
+ OkC t -> t
+ FailC s -> reportError s
+
+checkExp :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Exp -> CheckResult Ty
+checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv) = ch
where
ch e0 =
case e0 of
require (not (isUtupleTy vt)) ("lambda-bound unboxed tuple in:\n" ++ show e0)
return (tArrow vt t)
Let vdefg e ->
- do (e_venv',l_venv') <- checkVdefg False (tcenv,tsenv,tvenv,cenv) (e_venv,l_venv) vdefg
+ do (e_venv',l_venv') <- checkVdefg False (tcenv,tsenv,tvenv,cenv)
+ (e_venv,l_venv) vdefg
checkExp (tcenv,tsenv,tvenv,cenv,e_venv',l_venv') e
- Case e (v,t) alts ->
+ Case e (v,t) resultTy alts ->
do t' <- ch e
checkTy (tcenv,tvenv) t
requireM (equalTy tsenv t t')
require (and bs)
("alternative types don't match in:\n" ++ show e0 ++ "\n" ++
"types: " ++ show (t:ts))
+ checkTy (tcenv,tvenv) resultTy
+ require (t == resultTy) ("case alternative type doesn't " ++
+ " match case return type in:\n" ++ show e0 ++ "\n" ++
+ "alt type: " ++ show t ++ " return type: " ++ show resultTy)
return t
- Coerce t e ->
+ Cast e t ->
do ch e
checkTy (tcenv,tvenv) t
return t
do checkTy (tcenv,eempty) t {- external types must be closed -}
return t
- checkAlt :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Ty -> Alt -> CheckResult Ty
- checkAlt (env@(tcenv,tsenv,tvenv,cenv,e_venv,l_venv)) t0 = ch
+checkAlt :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Ty -> Alt -> CheckResult Ty
+checkAlt (env@(tcenv,tsenv,tvenv,cenv,e_venv,l_venv)) t0 = ch
where
ch a0 =
case a0 of
Adefault e ->
checkExp env e
- checkTy :: (Tcenv,Tvenv) -> Ty -> CheckResult Kind
- checkTy (tcenv,tvenv) = ch
+checkTy :: (Tcenv,Tvenv) -> Ty -> CheckResult Kind
+checkTy (tcenv,tvenv) = ch
where
ch (Tvar tv) = lookupM tvenv tv
ch (Tcon qtc) = qlookupM tcenv_ tcenv eempty qtc
do tvenv' <- extendM tvenv tb
checkTy (tcenv,tvenv') t
- {- Type equality modulo newtype synonyms. -}
- equalTy :: Tsenv -> Ty -> Ty -> CheckResult Bool
- equalTy tsenv t1 t2 =
+{- Type equality modulo newtype synonyms. -}
+equalTy :: Tsenv -> Ty -> Ty -> CheckResult Bool
+equalTy tsenv t1 t2 =
do t1' <- expand t1
t2' <- expand t2
return (t1' == t2')
return (foldl Tapp t' ts)
- mlookupM :: (Envs -> Env a b) -> Env a b -> Env a b -> Mname -> CheckResult (Env a b)
- mlookupM selector external_env local_env m =
- if m == "" then
- return local_env
- else if m == mn then
- return external_env
- else
- case elookup globalEnv m of
- Just env' -> return (selector env')
- Nothing -> fail ("undefined module name: " ++ show m)
+mlookupM :: (Envs -> Env a b) -> Env a b -> Env a b -> Mname
+ -> CheckResult (Env a b)
+mlookupM _ _ local_env Nothing = return local_env
+mlookupM selector external_env _ (Just m) = do
+ mn <- getMname
+ if m == mn
+ then return external_env
+ else do
+ globalEnv <- getGlobalEnv
+ case elookup globalEnv m of
+ Just env' -> return (selector env')
+ Nothing -> fail ("undefined module name: " ++ show m)
- qlookupM :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> Env a b -> (Mname,a) -> CheckResult b
- qlookupM selector external_env local_env (m,k) =
+qlookupM :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> Env a b
+ -> Qual a -> CheckResult b
+qlookupM selector external_env local_env (m,k) =
do env <- mlookupM selector external_env local_env m
lookupM env k
freshTvar :: [Tvar] -> Tvar
freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way!
+-- todo
+reportError s = error $ ("Core parser error: checkExpr failed with " ++ s)
import List (elemIndex)
data Module
- = Module Mname [Tdef] [Vdefg]
+ = Module AnMname [Tdef] [Vdefg]
data Tdef
= Data (Qual Tcon) [Tbind] [Cdef]
= Var (Qual Var)
| Dcon (Qual Dcon)
| Lit Lit
+-- Why were type apps and value apps distinguished,
+-- but not type lambdas and value lambdas?
| App Exp Exp
| Appt Exp Ty
| Lam Bind Exp
| Let Vdefg Exp
- | Case Exp Vbind [Alt] {- non-empty list -}
- | Coerce Ty Exp
+-- Ty is new
+ | Case Exp Vbind Ty [Alt] {- non-empty list -}
+-- Renamed to Cast; switched order
+ | Cast Exp Ty
| Note String Exp
| External String Ty
| Lstring String Ty
deriving (Eq) -- with nearlyEqualTy
-type Mname = Id
+-- new: Pnames
+-- this requires at least one module name,
+-- and possibly other hierarchical names
+-- an alternative would be to flatten the
+-- module namespace, either when printing out
+-- Core or (probably preferably) in a
+-- preprocessor.
+-- Maybe because the empty module name is a module name (represented as
+-- Nothing.)
+
+type Mname = Maybe AnMname
+type AnMname = (Pname, [Id], Id)
+type Pname = Id
type Var = Id
type Tvar = Id
type Tcon = Id
type Qual t = (Mname,t)
+qual :: AnMname -> t -> Qual t
+qual mn t = (Just mn, t)
+
+unqual :: t -> Qual t
+unqual = (,) Nothing
+
type Id = String
+--- tjc: I haven't looked at the rest of this file. ---
+
{- Doesn't expand out fully applied newtype synonyms
(for which an environment is needed). -}
nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
baseKind (Karrow _ _ ) = False
baseKind _ = True
-primMname = "PrelGHC"
+isPrimVar (Just mn,_) = mn == primMname
+isPrimVar _ = False
+
+primMname = mkBaseMname "Prim"
+errMname = mkBaseMname "Err"
+mkBaseMname :: Id -> AnMname
+mkBaseMname mn = (basePkg, ghcPrefix, mn)
+basePkg = "base"
+mainPkg = "main"
+ghcPrefix = ["GHC"]
+mainPrefix = []
+baseMname = mkBaseMname "Base"
+mainVar = qual mainMname "main"
+mainMname = (mainPkg, mainPrefix, "Main")
tcArrow :: Qual Tcon
-tcArrow = (primMname, "ZLzmzgZR")
+tcArrow = (Just primMname, "ZLzmzgZR")
tArrow :: Ty -> Ty -> Ty
tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
+
ktArrow :: Kind
ktArrow = Karrow Kopen (Karrow Kopen Klifted)
{- Unboxed tuples -}
+-- tjc: not sure whether anything that follows is right
+
maxUtuple :: Int
maxUtuple = 100
tcUtuple :: Int -> Qual Tcon
-tcUtuple n = (primMname,"Z"++ (show n) ++ "H")
+tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
ktUtuple :: Int -> Kind
ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
isUtupleTy _ = False
dcUtuple :: Int -> Qual Dcon
-dcUtuple n = (primMname,"ZdwZ" ++ (show n) ++ "H")
+dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
isUtupleDc :: Qual Dcon -> Bool
isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
let result = evalProgram modules
putStrLn ("Result = " ++ show result)
putStrLn "All done"
+-- TODO
where flist = ["PrelBase.hcr",
"PrelMaybe.hcr",
"PrelTup.hcr",
-- etc., etc.
deriving (Eq,Show)
-type Menv = Env Mname Venv -- modules
+type Menv = Env AnMname Venv -- modules
initialGlobalEnv :: Menv
initialGlobalEnv =
{- Heap management. -}
{- Nothing is said about garbage collection. -}
-data Heap = Heap Ptr (Env Ptr HeapValue) -- last cell allocated; environment of allocated cells
- deriving (Show)
+data Heap = Heap Ptr (Env Ptr HeapValue)
+ -- last cell allocated; environment of allocated cells
+ deriving Show
hallocate :: Heap -> HeapValue -> (Heap,Ptr)
hallocate (Heap last contents) v =
evalProgram modules =
runE(
do globalEnv <- foldM evalModule initialGlobalEnv modules
- Vutuple [_,v] <- evalExp globalEnv eempty (App (Var ("Main","main")) (Var (primMname,"realWorldzh")))
+ Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar)
+ (Var (qual primMname "realWorldzh")))
return v)
{- Environments:
evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
do p <- hallocateE (suspendExp l_env e)
- let heaps =
- if m == "" then
- (e_env,eextend l_env (x,Vheap p))
- else
- (eextend e_env (x,Vheap p),l_env)
+ let heaps =
+ case m of
+ Nothing -> (e_env,eextend l_env (x,Vheap p))
+ _ -> (eextend e_env (x,Vheap p),l_env)
return heaps
evalVdef (e_env,l_env) (Rec vdefs) =
do l_vs0 <- mapM preallocate l_xs
let e_env' = foldl eextend e_env (zip e_xs e_vs)
return (e_env',l_env')
where
- (l_xs,l_es) = unzip [(x,e) | Vdef(("",x),_,e) <- vdefs]
- (e_xs,e_es) = unzip [(x,e) | Vdef((m,x),_,e) <- vdefs, m /= ""]
+ (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
+ (e_xs,e_es) = unzip [(x,e) | Vdef((Just m,x),_,e) <- vdefs]
preallocate _ =
do p <- hallocateE undefined
return (Vheap p)
{- allocate a thunk -}
do p <- hallocateE (Hconstr c vs)
return (Vheap p)
- evalApp env (op @ (Var(m,p))) es | m == primMname =
+ evalApp env (op @ (Var(v@(_,p)))) es | isPrimVar v =
do vs <- evalExps globalEnv env es
case (p,vs) of
("raisezh",[exn]) -> raiseE exn
evalExternal s vs
evalApp env (Appt e _) es = evalApp env e es
evalApp env (Lam (Tb _) e) es = evalApp env e es
- evalApp env (Coerce _ e) es = evalApp env e es
+ evalApp env (Cast e _) es = evalApp env e es
evalApp env (Note _ e) es = evalApp env e es
evalApp env e es =
{- e must now evaluate to a closure -}
do h <- hlookupE p
hupdateE p0 h
-evalExp globalEnv env (Case e (x,_) alts) =
+evalExp globalEnv env (Case e (x,_) _ alts) =
do z <- evalExp globalEnv env e
let env' = eextend env (x,z)
case z of
evalDefaultAlt :: Venv -> [Alt] -> Eval Value
evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
-evalExp globalEnv env (Coerce _ e) = evalExp globalEnv env e
+evalExp globalEnv env (Cast e _) = evalExp globalEnv env e
evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
evalExp globalEnv env (External s t) = evalExternal s []
where env' = thin env (delete x (freevarsExp e))
suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
-suspendExp globalEnv env (Coerce _ e) = suspendExp globalEnv env e
+suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
suspendExp globalEnv env (External s _) = evalExternal s []
suspendExp globalEnv env e =
suspendExps globalEnv env = mapM (suspendExp globalEnv env)
mlookup :: Menv -> Venv -> Mname -> Venv
-mlookup _ env "" = env
-mlookup globalEnv _ m =
+mlookup _ env Nothing = env
+mlookup globalEnv _ (Just m) =
case elookup globalEnv m of
Just env' -> env'
- Nothing -> error ("undefined module name: " ++ m)
+ Nothing -> error ("undefined module name: " ++ show m)
qlookup :: Menv -> Venv -> (Mname,Var) -> Value
qlookup globalEnv env (m,k) =
{- Return the free non-external variables in an expression. -}
freevarsExp :: Exp -> [Var]
-freevarsExp (Var ("",v)) = [v]
+freevarsExp (Var (Nothing,v)) = [v]
freevarsExp (Var qv) = []
freevarsExp (Dcon _) = []
freevarsExp (Lit _) = []
where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
-freevarsExp (Case e (v,_) as) = freevarsExp e `union` [v] `union` freevarsAlts as
+freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
freevarsAlt (Alit _ e) = freevarsExp e
freevarsAlt (Adefault e) = freevarsExp e
-freevarsExp (Coerce _ e) = freevarsExp e
+freevarsExp (Cast e _) = freevarsExp e
freevarsExp (Note _ e) = freevarsExp e
freevarsExp (External _ _) = []
("in",rest) -> cont TKin rest
("case",rest) -> cont TKcase rest
("of",rest) -> cont TKof rest
- ("coerce",rest) -> cont TKcoerce rest
+ ("cast",rest) -> cont TKcast rest
("note",rest) -> cont TKnote rest
("external",rest) -> cont TKexternal rest
("_",rest) -> cont TKwild rest
--- /dev/null
+all: Check.hs Core.hs Driver.hs Env.hs Interp.hs Lex.hs ParseGlue.hs Parser.hs Prep.hs Prims.hs Printer.hs
+ ghc --make -fglasgow-exts -o Driver Driver.hs
+
+Parser.hs: Parser.y
+ happy -o Parser.hs Parser.y
\ No newline at end of file
| TKin
| TKcase
| TKof
- | TKcoerce
+ | TKcast
| TKnote
| TKexternal
| TKwild
| TKbiglambda
| TKat
| TKdot
+ | TKcolon
| TKquestion
| TKsemicolon
| TKname String
'%in' { TKin }
'%case' { TKcase }
'%of' { TKof }
- '%coerce' { TKcoerce }
+ '%cast' { TKcast }
'%note' { TKnote }
'%external' { TKexternal }
'%_' { TKwild }
'\\' { TKlambda}
'@' { TKat }
'.' { TKdot }
+ ':' { TKcolon }
'?' { TKquestion}
';' { TKsemicolon }
NAME { TKname $$ }
{ foldr Lam $4 $2 }
| '%let' vdefg '%in' exp
{ Let $2 $4 }
- | '%case' aexp '%of' vbind '{' alts1 '}'
- { Case $2 $4 $6 }
- | '%coerce' aty exp
- { Coerce $2 $3 }
+ | '%case' ty aexp '%of' vbind '{' alts1 '}'
+ { Case $3 $5 $2 $7 }
+ | '%cast' exp aty
+ { Cast $2 $3 }
| '%note' STRING exp
{ Note $2 $3 }
| '%external' STRING aty
cname :: { Id }
: CNAME { $1 }
-mname :: { Id }
- : CNAME { $1 }
+mname :: { AnMname }
+ : pkgName ':' mnames '.' name
+ { ($1, $3, $5) }
+
+pkgName :: { Id }
+ : NAME { $1 }
+
+mnames :: { [Id] }
+ : {- empty -} {[]}
+ | name '.' mnames {$1:$3}
+
+-- it sucks to have to repeat the Maybe-checking twice,
+-- but otherwise we get reduce/reduce conflicts
-qname :: { (Id,Id) }
- : name { ("",$1) }
+qname :: { (Mname,Id) }
+ : name { (Nothing, $1) }
| mname '.' name
- { ($1,$3) }
+ { (Just $1,$3) }
-qcname :: { (Id,Id) }
- : mname '.' cname
- { ($1,$3) }
+qcname :: { (Mname,Id) }
+ : cname { (Nothing, $1) }
+ | mname '.' cname
+ { (Just $1,$3) }
{
prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
- prepVdefg (env@(venv,_)) (Nonrec(Vdef(("",x),t,e))) =
- (eextend venv (x,t), Nonrec(Vdef(("",x),t,prepExp env e)))
+ prepVdefg (env@(venv,_)) (Nonrec(Vdef((Nothing,x),t,e))) =
+ (eextend venv (x,t), Nonrec(Vdef((Nothing,x),t,prepExp env e)))
prepVdefg (env@(venv,_)) (Nonrec(Vdef(qx,t,e))) =
(venv, Nonrec(Vdef(qx,t,prepExp env e)))
prepVdefg (venv,tvenv) (Rec vdefs) =
(venv',Rec [Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])
- where venv' = foldl eextend venv [(x,t) | Vdef(("",x),t,_) <- vdefs]
+ where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs]
prepExp env (Var qv) = Var qv
prepExp env (Dcon qdc) = Dcon qdc
prepExp env e@(Appt _ _) = unwindApp env e []
prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e)
prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e)
- prepExp env@(venv,tvenv) (Let (Nonrec(Vdef(("",x),t,b))) e) | kindof tvenv t == Kunlifted && suspends b =
- Case (prepExp env b) (x,t) [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
+ prepExp env@(venv,tvenv) (Let (Nonrec(Vdef((Nothing,x),t,b))) e)
+ | kindof tvenv t == Kunlifted && suspends b =
+ -- There are two places where we call the typechecker, one of them
+ -- here.
+ -- We need to know the type of the let body in order to construct
+ -- a case expression.
+ let eTy = typeOfExp env e in
+ Case (prepExp env b) (x,t)
+ eTy
+ [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
prepExp (venv,tvenv) (Let vdefg e) = Let vdefg' (prepExp (venv',tvenv) e)
where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg
- prepExp env@(venv,tvenv) (Case e vb alts) = Case (prepExp env e) vb (map (prepAlt (eextend venv vb,tvenv)) alts)
- prepExp env (Coerce t e) = Coerce t (prepExp env e)
+ prepExp env@(venv,tvenv) (Case e vb t alts) = Case (prepExp env e) vb t (map (prepAlt (eextend venv vb,tvenv)) alts)
+ prepExp env (Cast e t) = Cast (prepExp env e) t
prepExp env (Note s e) = Note s (prepExp env e)
prepExp env (External s t) = External s t
atys = map (substl (map fst tbs) ts) atys0
ts = [t | Right t <- as]
n = length [e | Left e <- as]
- unwindApp env (op@(Var(m,p))) as | m == primMname =
+ unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =
etaExpand (drop n atys) (rewindApp env op as)
where Just atys = elookup primArgTys p
n = length [e | Left e <- as]
etaExpand ts e = foldl g e [('$':(show i),t) | (i,t) <- zip [1..] ts]
- where g e (v,t) = Lam (Vb(v,t)) (App e (Var ("",v)))
+ where g e (v,t) = Lam (Vb(v,t)) (App e (Var (unqual v)))
rewindApp env e [] = e
rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t == Kunlifted && suspends e2 =
- Case (prepExp env' e2) (v,t)
- [Adefault (rewindApp env' (App e1 (Var ("",v))) as)]
- where v = freshVar venv
- t = typeofExp env e2
+ -- This is the other place where we call the typechecker.
+ Case (prepExp env' e2) (v,t) (typeOfExp env rhs) [Adefault rhs]
+ where rhs = (rewindApp env' (App e1 (Var (unqual v))) as)
+ v = freshVar venv
+ t = typeOfExp env e2
env' = (eextend venv (v,t),tvenv)
rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way!
- typeofExp :: (Venv,Tvenv) -> Exp -> Ty
- typeofExp (venv,_) (Var qv) = qlookup venv_ venv qv
- typeofExp env (Dcon qdc) = qlookup cenv_ eempty qdc
- typeofExp env (Lit l) = typeofLit l
- where typeofLit (Lint _ t) = t
- typeofLit (Lrational _ t) = t
- typeofLit (Lchar _ t) = t
- typeofLit (Lstring _ t) = t
- typeofExp env (App e1 e2) = t
- where (Tapp(Tapp _ t0) t) = typeofExp env e1
- typeofExp env (Appt e t) = substl [tv] [t] t'
- where (Tforall (tv,_) t') = typeofExp env e
- typeofExp (venv,tvenv) (Lam (Vb(v,t)) e) = tArrow t (typeofExp (eextend venv (v,t),tvenv) e)
- typeofExp (venv,tvenv) (Lam (Tb tb) e) = Tforall tb (typeofExp (venv,eextend tvenv tb) e)
- typeofExp (venv,tvenv) (Let vdefg e) = typeofExp (venv',tvenv) e
- where venv' = case vdefg of
- Nonrec (Vdef((_,x),t,_)) -> eextend venv (x,t)
- Rec vdefs -> foldl eextend venv [(x,t) | Vdef((_,x),t,_) <- vdefs]
- typeofExp (venv,tvenv) (Case _ vb (alt:_)) = typeofAlt (eextend venv vb,tvenv) alt
- where typeofAlt (venv,tvenv) (Acon _ tbs vbs e) = typeofExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e
- typeofAlt env (Alit _ e) = typeofExp env e
- typeofAlt env (Adefault e) = typeofExp env e
- typeofExp env (Coerce t _) = t
- typeofExp env (Note _ e) = typeofExp env e
- typeofExp env (External _ t) = t
-
- {- Return false for those expressions for which Interp.suspendExp buidds a thunk. -}
+ typeOfExp :: (Venv, Tvenv) -> Exp -> Ty
+ typeOfExp = uncurry (checkExpr mn globalEnv tdefs)
+
+ {- Return false for those expressions for which Interp.suspendExp builds a thunk. -}
suspends (Var _) = False
suspends (Lit _) = False
suspends (Lam (Vb _) _) = False
suspends (Lam _ e) = suspends e
suspends (Appt e _) = suspends e
- suspends (Coerce _ e) = suspends e
+ suspends (Cast e _) = suspends e
suspends (Note _ e) = suspends e
suspends (External _ _) = False
suspends _ = True
kindof tvenv (Tforall _ t) = kindof tvenv t
mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
- mlookup _ local_env "" = local_env
- mlookup selector _ m =
+ mlookup _ local_env Nothing = local_env
+ mlookup selector _ (Just m) =
case elookup globalEnv m of
Just env -> selector env
- Nothing -> error ("undefined module name: " ++ m)
+ Nothing -> error ("undefined module name: " ++ show m)
qlookup :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
qlookup selector local_env (m,k) =
initialEnv :: Menv
initialEnv = efromlist [(primMname,primEnv),
- ("PrelErr",errorEnv)]
+ (errMname,errorEnv)]
primEnv :: Envs
primEnv = Envs {tcenv_=efromlist primTcs,
(tUtuple (map Tvar tvs)) tvs) tvs
where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
+pv = qual primMname
+pvz = (qual primMname) . (++ "zh")
{- Addrzh -}
-
-tcAddrzh = (primMname,"Addrzh")
+tcAddrzh = pvz "Addr"
tAddrzh = Tcon tcAddrzh
ktAddrzh = Kunlifted
{- Charzh -}
-tcCharzh = (primMname,"Charzh")
+tcCharzh = pvz "Char"
tCharzh = Tcon tcCharzh
ktCharzh = Kunlifted
{- Doublezh -}
-tcDoublezh = (primMname, "Doublezh")
+tcDoublezh = pvz "Double"
tDoublezh = Tcon tcDoublezh
ktDoublezh = Kunlifted
{- Floatzh -}
-tcFloatzh = (primMname, "Floatzh")
+tcFloatzh = pvz "Float"
tFloatzh = Tcon tcFloatzh
ktFloatzh = Kunlifted
{- Intzh -}
-tcIntzh = (primMname,"Intzh")
+tcIntzh = pvz "Int"
tIntzh = Tcon tcIntzh
ktIntzh = Kunlifted
{- Int32zh -}
-tcInt32zh = (primMname,"Int32zh")
+tcInt32zh = pvz "Int32"
tInt32zh = Tcon tcInt32zh
ktInt32zh = Kunlifted
{- Int64zh -}
-tcInt64zh = (primMname,"Int64zh")
+tcInt64zh = pvz "Int64"
tInt64zh = Tcon tcInt64zh
ktInt64zh = Kunlifted
{- Wordzh -}
-tcWordzh = (primMname,"Wordzh")
+tcWordzh = pvz "Word"
tWordzh = Tcon tcWordzh
ktWordzh = Kunlifted
{- Word32zh -}
-tcWord32zh = (primMname,"Word32zh")
+tcWord32zh = pvz "Word32"
tWord32zh = Tcon tcWord32zh
ktWord32zh = Kunlifted
{- Word64zh -}
-tcWord64zh = (primMname,"Word64zh")
+tcWord64zh = pvz "Word64"
tWord64zh = Tcon tcWord64zh
ktWord64zh = Kunlifted
{- Arrays -}
-tcArrayzh = (primMname,"Arrayzh")
+tcArrayzh = pvz "Array"
tArrayzh t = Tapp (Tcon tcArrayzh) t
ktArrayzh = Karrow Klifted Kunlifted
-tcByteArrayzh = (primMname,"ByteArrayzh")
+tcByteArrayzh = pvz "ByteArray"
tByteArrayzh = Tcon tcByteArrayzh
ktByteArrayzh = Kunlifted
-tcMutableArrayzh = (primMname,"MutableArrayzh")
+tcMutableArrayzh = pvz "MutableArray"
tMutableArrayzh s t = Tapp (Tapp (Tcon tcMutableArrayzh) s) t
ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
-tcMutableByteArrayzh = (primMname,"MutableByteArrayzh")
+tcMutableByteArrayzh = pvz "MutableByteArray"
tMutableByteArrayzh s = Tapp (Tcon tcMutableByteArrayzh) s
ktMutableByteArrayzh = Karrow Klifted Kunlifted
{- MutVars -}
-tcMutVarzh = (primMname,"MutVarzh")
+tcMutVarzh = pvz "MutVar"
tMutVarzh s t = Tapp (Tapp (Tcon tcMutVarzh) s) t
ktMutVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
{- Real world and state. -}
-tcRealWorld = (primMname,"RealWorld")
+-- tjc: why isn't this one unboxed?
+tcRealWorld = pv "RealWorld"
tRealWorld = Tcon tcRealWorld
ktRealWorld = Klifted
-tcStatezh = (primMname, "Statezh")
+tcStatezh = pvz "State"
tStatezh t = Tapp (Tcon tcStatezh) t
ktStatezh = Karrow Klifted Kunlifted
{- Mvars -}
-tcMVarzh = (primMname, "MVarzh")
+tcMVarzh = pvz "MVar"
tMVarzh s t = Tapp (Tapp (Tcon tcMVarzh) s) t
ktMVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
{- Weak Objects -}
-tcWeakzh = (primMname, "Weakzh")
+tcWeakzh = pvz "Weak"
tWeakzh t = Tapp (Tcon tcWeakzh) t
ktWeakzh = Karrow Klifted Kunlifted
{- Foreign Objects -}
-tcForeignObjzh = (primMname, "ForeignObjzh")
+tcForeignObjzh = pvz "ForeignObj"
tForeignObjzh = Tcon tcForeignObjzh
ktForeignObjzh = Kunlifted
{- Stable Pointers (but not names) -}
-tcStablePtrzh = (primMname, "StablePtrzh")
+tcStablePtrzh = pvz "StablePtr"
tStablePtrzh t = Tapp (Tcon tcStablePtrzh) t
ktStablePtrzh = Karrow Klifted Kunlifted
{- Concurrency operations -}
-tcThreadIdzh = (primMname,"ThreadIdzh")
+tcThreadIdzh = pvz "ThreadId"
tThreadIdzh = Tcon tcThreadIdzh
ktThreadIdzh = Kunlifted
We just define the type constructors for the dictionaries
corresponding to these pseudo-classes. -}
-tcZCTCCallable = (primMname,"ZCTCCallable")
+tcZCTCCallable = pv "ZCTCCallable"
ktZCTCCallable = Karrow Kopen Klifted -- ??
-tcZCTCReturnable = (primMname,"ZCTCReturnable")
+tcZCTCReturnable = pv "ZCTCReturnable"
ktZCTCReturnable = Karrow Kopen Klifted -- ??
{- Non-primitive, but mentioned in the types of primitives. -}
-tcUnit = ("PrelBase","Unit")
+bv = qual baseMname
+
+tcUnit = bv "Unit"
tUnit = Tcon tcUnit
ktUnit = Klifted
-tcBool = ("PrelBase","Bool")
+tcBool = bv "Bool"
tBool = Tcon tcBool
ktBool = Klifted
("irrefutPatError", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
("patError", Tforall ("a",Kopen) (tArrow tString (Tvar "a")))]
-tcChar = ("PrelBase","Char")
+tcChar = bv "Char"
tChar = Tcon tcChar
ktChar = Klifted
-tcList = ("PrelBase","ZMZN")
+tcList = bv "ZMZN"
tList t = Tapp (Tcon tcList) t
ktList = Karrow Klifted Klifted
tString = tList tChar
module Printer where
-import Pretty
-import Core
-import Char
+import Text.PrettyPrint.HughesPJ
import Numeric (fromRat)
+import Char
+
+import Core
instance Show Module where
showsPrec d m = shows (pmodule m)
indent = nest 2
+-- seems like this is asking for a type class...
+
pmodule (Module mname tdefs vdefgs) =
- (text "%module" <+> text mname)
+ (text "%module" <+> panmname mname)
$$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
$$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
pname id = text id
-pqname ("",id) = pname id
-pqname (m,id) = pname m <> char '.' <> pname id
+pqname (m,id) = pmname m <> char '.' <> pname id
+
+pmname Nothing = empty
+pmname (Just m) = panmname m
+
+panmname (pkgName, parents, name) = pname pkgName <> char ':'
+ <> (sep (punctuate (char '.') (map pname parents)))
+ <> char '.' <> pname name
ptbind (t,Klifted) = pname t
ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
pexp (Lam b e) = char '\\' <+> plamexp [b] e
pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
-pexp (Case e vb alts) = sep [text "%case" <+> paexp e,
+pexp (Case e vb t alts) = sep [text "%case" <+> pty t <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
-pexp (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e
+pexp (Cast e t) = (text "%cast" <+> paty t) $$ pexp e
pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e
pexp (External n t) = (text "%extcall" <+> pstring n) $$ paty t
pexp e = pfexp e
happy -o Parser.hs Parser.y
ghc --make -package text -fglasgow-exts -o Driver Driver.hs
+Most recently tested with GHC 6.8.1. I make no claims of portability. --tjc
+