Commit 27658502 authored by chevalier@alum.wellesley.edu's avatar chevalier@alum.wellesley.edu
Browse files

First cut at reviving the External Core tools

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.
parent e415eeaf
module Check where
import Monad
import Maybe
import Control.Monad.Reader
import Core
import Printer
import List
......@@ -10,9 +12,18 @@ import Env
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
......@@ -33,7 +44,7 @@ type Tcenv = Env Tcon Kind -- type constructors
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. -}
......@@ -50,24 +61,29 @@ lookupM env k =
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
......@@ -75,24 +91,26 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -102,17 +120,32 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -121,10 +154,11 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
"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)
......@@ -133,15 +167,24 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
("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
......@@ -189,9 +232,10 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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')
......@@ -225,8 +269,12 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -236,8 +284,8 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -292,8 +340,8 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -312,9 +360,9 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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')
......@@ -339,19 +387,22 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -419,3 +470,5 @@ freeTvars (Tforall (t,_) t1) = delete t (freeTvars t1)
freshTvar :: [Tvar] -> Tvar
freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way!
-- todo
reportError s = error $ ("Core parser error: checkExpr failed with " ++ s)
......@@ -3,7 +3,7 @@ module Core where
import List (elemIndex)
data Module
= Module Mname [Tdef] [Vdefg]
= Module AnMname [Tdef] [Vdefg]
data Tdef
= Data (Qual Tcon) [Tbind] [Cdef]
......@@ -22,12 +22,16 @@ data Exp
= 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
......@@ -63,7 +67,19 @@ data Lit
| 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
......@@ -71,8 +87,16 @@ type Dcon = 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
......@@ -100,24 +124,40 @@ baseKind :: Kind -> Bool
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)
......@@ -131,7 +171,7 @@ isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
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]]
......
......@@ -44,6 +44,7 @@ main = do (_,modules) <- foldM process (initialEnv,[]) flist
let result = evalProgram modules
putStrLn ("Result = " ++ show result)
putStrLn "All done"
-- TODO
where flist = ["PrelBase.hcr",
"PrelMaybe.hcr",
"PrelTup.hcr",
......
......@@ -50,7 +50,7 @@ data PrimValue = -- values of the (unboxed) primitive types
-- etc., etc.
deriving (Eq,Show)
type Menv = Env Mname Venv -- modules
type Menv = Env AnMname Venv -- modules
initialGlobalEnv :: Menv
initialGlobalEnv =
......@@ -60,8 +60,9 @@ 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 =
......@@ -137,7 +138,8 @@ evalProgram :: [Module] -> Value
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:
......@@ -175,11 +177,10 @@ evalModule globalEnv (Module mn tdefs vdefgs) =
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
......@@ -191,8 +192,8 @@ evalModule globalEnv (Module mn tdefs vdefgs) =
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)
......@@ -241,7 +242,7 @@ evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
{- 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
......@@ -254,7 +255,7 @@ evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
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 -}
......@@ -299,7 +300,7 @@ evalExp globalEnv env (Let vdef e) =
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
......@@ -345,7 +346,7 @@ evalExp globalEnv env (Case e (x,_) alts) =
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 []
......@@ -361,7 +362,7 @@ suspendExp globalEnv env (Lam (Vb(x,_)) e) =
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 =
......@@ -373,11 +374,11 @@ suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
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) =
......@@ -424,7 +425,7 @@ thin env vars = efilter env (`elem` vars)
{- 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 _) = []
......@@ -436,12 +437,12 @@ freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
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 _ _) = []
......
......@@ -84,7 +84,7 @@ lexKeyword cont cs =
("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
......
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
......@@ -25,7 +25,7 @@ data Token =
| TKin
| TKcase
| TKof
| TKcoerce
| TKcast
| TKnote
| TKexternal
| TKwild
......@@ -42,6 +42,7 @@ data Token =
| TKbiglambda
| TKat
| TKdot
| TKcolon
| TKquestion
| TKsemicolon
| TKname String
......
......@@ -20,7 +20,7 @@ import Lex
'%in' { TKin }
'%case' { TKcase }
'%of' { TKof }
'%coerce' { TKcoerce }
'%cast' { TKcast }
'%note' { TKnote }
'%external' { TKexternal }
'%_' { TKwild }
......@@ -36,6 +36,7 @@ import Lex
'\\' { TKlambda}
'@' { TKat }
'.' { TKdot }
':' { TKcolon }