summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--utils/ext-core/Check.hs159
-rw-r--r--utils/ext-core/Core.hs56
-rw-r--r--utils/ext-core/Driver.hs1
-rw-r--r--utils/ext-core/Interp.hs45
-rw-r--r--utils/ext-core/Lex.hs2
-rw-r--r--utils/ext-core/Makefile5
-rw-r--r--utils/ext-core/ParseGlue.hs3
-rw-r--r--utils/ext-core/Parser.y39
-rw-r--r--utils/ext-core/Prep.hs74
-rw-r--r--utils/ext-core/Prims.hs64
-rw-r--r--utils/ext-core/Printer.hs25
-rw-r--r--utils/ext-core/README2
12 files changed, 295 insertions, 180 deletions
diff --git a/utils/ext-core/Check.hs b/utils/ext-core/Check.hs
index a9a3eac8f4..8b928b0f5a 100644
--- a/utils/ext-core/Check.hs
+++ b/utils/ext-core/Check.hs
@@ -1,6 +1,8 @@
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)
diff --git a/utils/ext-core/Core.hs b/utils/ext-core/Core.hs
index 2f94f80b3e..89f8294c25 100644
--- a/utils/ext-core/Core.hs
+++ b/utils/ext-core/Core.hs
@@ -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]]
diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs
index 2328eca22a..da15dce75b 100644
--- a/utils/ext-core/Driver.hs
+++ b/utils/ext-core/Driver.hs
@@ -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",
diff --git a/utils/ext-core/Interp.hs b/utils/ext-core/Interp.hs
index 1988ae9cf3..b2f68bfdf4 100644
--- a/utils/ext-core/Interp.hs
+++ b/utils/ext-core/Interp.hs
@@ -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 _ _) = []
diff --git a/utils/ext-core/Lex.hs b/utils/ext-core/Lex.hs
index ad9d2eb00f..8150b16fb8 100644
--- a/utils/ext-core/Lex.hs
+++ b/utils/ext-core/Lex.hs
@@ -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
diff --git a/utils/ext-core/Makefile b/utils/ext-core/Makefile
new file mode 100644
index 0000000000..67afd4359b
--- /dev/null
+++ b/utils/ext-core/Makefile
@@ -0,0 +1,5 @@
+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
diff --git a/utils/ext-core/ParseGlue.hs b/utils/ext-core/ParseGlue.hs
index 3dde0c3d75..9bd3c4f7eb 100644
--- a/utils/ext-core/ParseGlue.hs
+++ b/utils/ext-core/ParseGlue.hs
@@ -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
diff --git a/utils/ext-core/Parser.y b/utils/ext-core/Parser.y
index 1e1c6a3592..ac186e399a 100644
--- a/utils/ext-core/Parser.y
+++ b/utils/ext-core/Parser.y
@@ -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 }
'?' { TKquestion}
';' { TKsemicolon }
NAME { TKname $$ }
@@ -172,10 +173,10 @@ exp :: { Exp }
{ 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
@@ -209,17 +210,29 @@ name :: { Id }
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) }
{
diff --git a/utils/ext-core/Prep.hs b/utils/ext-core/Prep.hs
index ee65eaaba2..352108e198 100644
--- a/utils/ext-core/Prep.hs
+++ b/utils/ext-core/Prep.hs
@@ -30,13 +30,13 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
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
@@ -45,12 +45,20 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
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
@@ -67,7 +75,7 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
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]
@@ -75,53 +83,31 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
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
@@ -137,11 +123,11 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
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) =
diff --git a/utils/ext-core/Prims.hs b/utils/ext-core/Prims.hs
index fd6e827c39..efcd60e679 100644
--- a/utils/ext-core/Prims.hs
+++ b/utils/ext-core/Prims.hs
@@ -9,7 +9,7 @@ import Check
initialEnv :: Menv
initialEnv = efromlist [(primMname,primEnv),
- ("PrelErr",errorEnv)]
+ (errMname,errorEnv)]
primEnv :: Envs
primEnv = Envs {tcenv_=efromlist primTcs,
@@ -93,10 +93,11 @@ dcUtuples = map ( \n -> (dcUtuple n, typ n)) [1..100]
(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
@@ -114,7 +115,7 @@ opsAddrzh = [
{- Charzh -}
-tcCharzh = (primMname,"Charzh")
+tcCharzh = pvz "Char"
tCharzh = Tcon tcCharzh
ktCharzh = Kunlifted
@@ -130,7 +131,7 @@ opsCharzh = [
{- Doublezh -}
-tcDoublezh = (primMname, "Doublezh")
+tcDoublezh = pvz "Double"
tDoublezh = Tcon tcDoublezh
ktDoublezh = Kunlifted
@@ -166,7 +167,7 @@ opsDoublezh = [
{- Floatzh -}
-tcFloatzh = (primMname, "Floatzh")
+tcFloatzh = pvz "Float"
tFloatzh = Tcon tcFloatzh
ktFloatzh = Kunlifted
@@ -202,7 +203,7 @@ opsFloatzh = [
{- Intzh -}
-tcIntzh = (primMname,"Intzh")
+tcIntzh = pvz "Int"
tIntzh = Tcon tcIntzh
ktIntzh = Kunlifted
@@ -236,7 +237,7 @@ opsIntzh = [
{- Int32zh -}
-tcInt32zh = (primMname,"Int32zh")
+tcInt32zh = pvz "Int32"
tInt32zh = Tcon tcInt32zh
ktInt32zh = Kunlifted
@@ -247,7 +248,7 @@ opsInt32zh = [
{- Int64zh -}
-tcInt64zh = (primMname,"Int64zh")
+tcInt64zh = pvz "Int64"
tInt64zh = Tcon tcInt64zh
ktInt64zh = Kunlifted
@@ -289,7 +290,7 @@ opsIntegerzh = [
{- Wordzh -}
-tcWordzh = (primMname,"Wordzh")
+tcWordzh = pvz "Word"
tWordzh = Tcon tcWordzh
ktWordzh = Kunlifted
@@ -317,7 +318,7 @@ opsWordzh = [
{- Word32zh -}
-tcWord32zh = (primMname,"Word32zh")
+tcWord32zh = pvz "Word32"
tWord32zh = Tcon tcWord32zh
ktWord32zh = Kunlifted
@@ -327,7 +328,7 @@ opsWord32zh = [
{- Word64zh -}
-tcWord64zh = (primMname,"Word64zh")
+tcWord64zh = pvz "Word64"
tWord64zh = Tcon tcWord64zh
ktWord64zh = Kunlifted
@@ -346,19 +347,19 @@ opsSized = [
{- 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
@@ -588,7 +589,7 @@ opsArray = [
{- MutVars -}
-tcMutVarzh = (primMname,"MutVarzh")
+tcMutVarzh = pvz "MutVar"
tMutVarzh s t = Tapp (Tapp (Tcon tcMutVarzh) s) t
ktMutVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
@@ -617,11 +618,12 @@ opsMutVarzh = [
{- 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
@@ -653,7 +655,7 @@ opsExn = [
{- Mvars -}
-tcMVarzh = (primMname, "MVarzh")
+tcMVarzh = pvz "MVar"
tMVarzh s t = Tapp (Tapp (Tcon tcMVarzh) s) t
ktMVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
@@ -698,7 +700,7 @@ opsMVar = [
{- Weak Objects -}
-tcWeakzh = (primMname, "Weakzh")
+tcWeakzh = pvz "Weak"
tWeakzh t = Tapp (Tcon tcWeakzh) t
ktWeakzh = Karrow Klifted Kunlifted
@@ -722,7 +724,7 @@ opsWeak = [
{- Foreign Objects -}
-tcForeignObjzh = (primMname, "ForeignObjzh")
+tcForeignObjzh = pvz "ForeignObj"
tForeignObjzh = Tcon tcForeignObjzh
ktForeignObjzh = Kunlifted
@@ -741,7 +743,7 @@ opsForeignObjzh = [
{- Stable Pointers (but not names) -}
-tcStablePtrzh = (primMname, "StablePtrzh")
+tcStablePtrzh = pvz "StablePtr"
tStablePtrzh t = Tapp (Tcon tcStablePtrzh) t
ktStablePtrzh = Karrow Klifted Kunlifted
@@ -758,7 +760,7 @@ opsStablePtrzh = [
{- Concurrency operations -}
-tcThreadIdzh = (primMname,"ThreadIdzh")
+tcThreadIdzh = pvz "ThreadId"
tThreadIdzh = Tcon tcThreadIdzh
ktThreadIdzh = Kunlifted
@@ -799,17 +801,19 @@ opsMisc = [
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
@@ -819,10 +823,10 @@ errorVals = [
("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
diff --git a/utils/ext-core/Printer.hs b/utils/ext-core/Printer.hs
index ded48aadc2..8ff4ba5ad2 100644
--- a/utils/ext-core/Printer.hs
+++ b/utils/ext-core/Printer.hs
@@ -1,9 +1,10 @@
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)
@@ -38,8 +39,10 @@ instance Show Lit where
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)))
@@ -58,8 +61,14 @@ pcdef (Constr qdcon tbinds tys) =
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)
@@ -122,10 +131,10 @@ pappexp e as = fsep (paexp e : map pa as)
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
diff --git a/utils/ext-core/README b/utils/ext-core/README
index 7ec8adf09a..6b8168d25b 100644
--- a/utils/ext-core/README
+++ b/utils/ext-core/README
@@ -7,3 +7,5 @@ All can be built using, e.g.,
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
+
View Lorry Controller Status