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.

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
+