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.

diff --git a/utils/ext-core/Check.hs b/utils/ext-core/Check.hs
index a9a3eac..8b928b0 100644 (file)
--- a/utils/ext-core/Check.hs
+++ b/utils/ext-core/Check.hs
@@ -1,6 +1,8 @@
 module Check where
 
 module Check where
 

-import Monad
+import Maybe
+import Control.Monad.Reader
+

 import Core
 import Printer
 import List
 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. -}
 
    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
   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 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. -}
 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. -}
      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 _) = 
       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) = 
               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
               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)
     
               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)) =
        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
                       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
                    where tbs = utbs ++ etbs

-                         t = foldr Tforall 
+                         t mn = foldr Tforall 

                                  (foldr tArrow
                                  (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
                                                 (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
         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))) -> 
       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
                               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')
                                         "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))) ->
        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) 
               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') 
                        ("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)
     
                  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
       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 ->
                 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
                 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') 
              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))
                 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
                 return t

-           Coerce t e -> 
+           Cast e t -> 

              do ch e 
                 checkTy (tcenv,tvenv) t 
                 return 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
     
              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 
       where 
        ch a0 = 
          case a0 of 

@@ -292,8 +340,8 @@ checkModule globalEnv (Module mn tdefs vdefgs) =
            Adefault e ->
              checkExp env e
     
            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
      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
     
            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')
            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)
     
 
                 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
 
       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!
 
 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 2f94f80..89f8294 100644 (file)
--- a/utils/ext-core/Core.hs
+++ b/utils/ext-core/Core.hs
@@ -3,7 +3,7 @@ module Core where
 import List (elemIndex)
 
 data Module 
 import List (elemIndex)
 
 data Module 

- = Module Mname [Tdef] [Vdefg]
+ = Module AnMname [Tdef] [Vdefg]

 
 data Tdef 
   = Data (Qual Tcon) [Tbind] [Cdef]
 
 data Tdef 
   = Data (Qual Tcon) [Tbind] [Cdef]

@@ -22,12 +22,16 @@ data Exp
   = Var (Qual Var)
   | Dcon (Qual Dcon)
   | Lit Lit
   = 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
   | 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
 
   | Note String Exp
   | External String Ty
 

@@ -63,7 +67,19 @@ data Lit
   | Lstring String Ty
   deriving (Eq)  -- with nearlyEqualTy 
 
   | Lstring String Ty
   deriving (Eq)  -- with nearlyEqualTy 
 

-type Mname = Id
+-- new: Pnames
+-- this requires at least one module name,
+-- and possibly other hierarchical names
+-- an alternative would be to flatten the
+-- module namespace, either when printing out
+-- Core or (probably preferably) in a 
+-- preprocessor.
+-- Maybe because the empty module name is a module name (represented as
+-- Nothing.)
+
+type Mname = Maybe AnMname
+type AnMname = (Pname, [Id], Id)
+type Pname = Id

 type Var = Id
 type Tvar = Id
 type Tcon = Id
 type Var = Id
 type Tvar = Id
 type Tcon = Id

@@ -71,8 +87,16 @@ type Dcon = Id
 
 type Qual t = (Mname,t)
 
 
 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
 
 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 
 {- 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
 
 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 :: Qual Tcon

-tcArrow = (primMname, "ZLzmzgZR")
+tcArrow = (Just primMname, "ZLzmzgZR")

 
 tArrow :: Ty -> Ty -> Ty
 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 
 
 tArrow :: Ty -> Ty -> Ty
 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 

+

 ktArrow :: Kind
 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 
 {- Unboxed tuples -}
 
 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
 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)
 
 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
 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]]
 
 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 2328eca..da15dce 100644 (file)
--- 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"
          let result = evalProgram modules
          putStrLn ("Result = " ++ show result)
          putStrLn "All done"

+-- TODO

        where flist =    ["PrelBase.hcr",
                          "PrelMaybe.hcr",
                          "PrelTup.hcr",
        where flist =    ["PrelBase.hcr",
                          "PrelMaybe.hcr",
                          "PrelTup.hcr",

diff --git a/utils/ext-core/Interp.hs b/utils/ext-core/Interp.hs
index 1988ae9..b2f68bf 100644 (file)
--- 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)
 
 --  etc., etc.
   deriving (Eq,Show)
 

-type Menv = Env Mname Venv     -- modules
+type Menv = Env AnMname Venv   -- modules

 
 initialGlobalEnv :: Menv
 initialGlobalEnv =
 
 initialGlobalEnv :: Menv
 initialGlobalEnv =

@@ -60,8 +60,9 @@ initialGlobalEnv =
 {- Heap management. -}
 {- Nothing is said about garbage collection. -}
 
 {- 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 = 
 
 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
 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:
      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)
     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
        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 
         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)
         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)
            {- 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
       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
         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 -}
     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
        
          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
   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
 
     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 []
 
 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
    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 = 
 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
 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'
     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) =   
 
 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]
 {- 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 _) = []
 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
   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
   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 _ _) = []
 
 freevarsExp (Note _ e) =  freevarsExp e
 freevarsExp (External _ _) = []
 

diff --git a/utils/ext-core/Lex.hs b/utils/ext-core/Lex.hs
index ad9d2eb..8150b16 100644 (file)
--- 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    
       ("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
       ("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 (file)
index 0000000..67afd43
--- /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 3dde0c3..9bd3c4f 100644 (file)
--- a/utils/ext-core/ParseGlue.hs
+++ b/utils/ext-core/ParseGlue.hs
@@ -25,7 +25,7 @@ data Token =
  | TKin 
  | TKcase 
  | TKof 
  | TKin 
  | TKcase 
  | TKof 

- | TKcoerce 
+ | TKcast

  | TKnote 
  | TKexternal
  | TKwild
  | TKnote 
  | TKexternal
  | TKwild

@@ -42,6 +42,7 @@ data Token =
  | TKbiglambda
  | TKat 
  | TKdot
  | TKbiglambda
  | TKat 
  | TKdot

+ | TKcolon

  | TKquestion
  | TKsemicolon
  | TKname String 
  | TKquestion
  | TKsemicolon
  | TKname String 

diff --git a/utils/ext-core/Parser.y b/utils/ext-core/Parser.y
index 1e1c6a3..ac186e3 100644 (file)
--- a/utils/ext-core/Parser.y
+++ b/utils/ext-core/Parser.y
@@ -20,7 +20,7 @@ import Lex
  '%in'         { TKin }
  '%case'       { TKcase }
  '%of'         { TKof }
  '%in'         { TKin }
  '%case'       { TKcase }
  '%of'         { TKof }

- '%coerce'     { TKcoerce }
+ '%cast'       { TKcast }

  '%note'       { TKnote }
  '%external'   { TKexternal }
  '%_'          { TKwild }
  '%note'       { TKnote }
  '%external'   { TKexternal }
  '%_'          { TKwild }

@@ -36,6 +36,7 @@ import Lex
  '\\'          { TKlambda}
  '@'           { TKat }
  '.'           { TKdot }
  '\\'          { TKlambda}
  '@'           { TKat }
  '.'           { TKdot }

+ ':'           { TKcolon }

  '?'           { TKquestion}
  ';'            { TKsemicolon }
  NAME          { TKname $$ }
  '?'           { TKquestion}
  ';'            { TKsemicolon }
  NAME          { TKname $$ }

@@ -172,10 +173,10 @@ exp       :: { Exp }
                { foldr Lam $4 $2 }
        | '%let' vdefg '%in' exp 
                { Let $2 $4 }
                { 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
        | '%note' STRING exp 
                { Note $2 $3 }
         | '%external' STRING aty

@@ -209,17 +210,29 @@ name      :: { Id }
 cname  :: { Id }
        : CNAME { $1 }
          
 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 
        | 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 ee65eaa..352108e 100644 (file)
--- 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
  
     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])
     prepVdefg (env@(venv,_))  (Nonrec(Vdef(qx,t,e))) = 
        (venv, Nonrec(Vdef(qx,t,prepExp env e)))
     prepVdefg (venv,tvenv) (Rec vdefs) = 
        (venv',Rec [Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])

-       where venv' = foldl eextend venv [(x,t) | Vdef(("",x),t,_) <- vdefs]
+       where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs]

 
     prepExp env (Var qv) = Var qv
     prepExp env (Dcon qdc) = Dcon qdc
 
     prepExp env (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 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 (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
 
     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]
              atys = map (substl (map fst tbs) ts) atys0
              ts = [t | Right t <- as]
               n = length [e | Left e <- as]

-    unwindApp env (op@(Var(m,p))) as | m == primMname =
+    unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =

        etaExpand (drop n atys) (rewindApp env op as)
         where Just atys = elookup primArgTys p
               n = length [e | Left e <- as]
        etaExpand (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]
 
 
     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 =
 
     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!
 
               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 (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
     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
     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
       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) =   
 
     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 fd6e827..efcd60e 100644 (file)
--- a/utils/ext-core/Prims.hs
+++ b/utils/ext-core/Prims.hs
@@ -9,7 +9,7 @@ import Check
 
 initialEnv :: Menv
 initialEnv = efromlist [(primMname,primEnv),
 
 initialEnv :: Menv
 initialEnv = efromlist [(primMname,primEnv),

-                    ("PrelErr",errorEnv)]
+                    (errMname,errorEnv)]

 
 primEnv :: Envs
 primEnv = Envs {tcenv_=efromlist primTcs,
 
 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]
 
                                             (tUtuple (map Tvar tvs)) tvs) tvs
                      where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
 

+pv = qual primMname
+pvz = (qual primMname) . (++ "zh")

 
 {- Addrzh -}
 
 {- Addrzh -}

-
-tcAddrzh = (primMname,"Addrzh")
+tcAddrzh = pvz "Addr"

 tAddrzh = Tcon tcAddrzh
 ktAddrzh = Kunlifted
 
 tAddrzh = Tcon tcAddrzh
 ktAddrzh = Kunlifted
 

@@ -114,7 +115,7 @@ opsAddrzh = [
 
 {- Charzh -}
 
 
 {- Charzh -}
 

-tcCharzh = (primMname,"Charzh")
+tcCharzh = pvz "Char"

 tCharzh = Tcon tcCharzh
 ktCharzh = Kunlifted
 
 tCharzh = Tcon tcCharzh
 ktCharzh = Kunlifted
 

@@ -130,7 +131,7 @@ opsCharzh = [
 
 {- Doublezh -}
 
 
 {- Doublezh -}
 

-tcDoublezh = (primMname, "Doublezh")
+tcDoublezh = pvz "Double"

 tDoublezh = Tcon tcDoublezh
 ktDoublezh = Kunlifted
 
 tDoublezh = Tcon tcDoublezh
 ktDoublezh = Kunlifted
 

@@ -166,7 +167,7 @@ opsDoublezh = [
 
 {- Floatzh -}
 
 
 {- Floatzh -}
 

-tcFloatzh = (primMname, "Floatzh")
+tcFloatzh = pvz "Float"

 tFloatzh = Tcon tcFloatzh
 ktFloatzh = Kunlifted
 
 tFloatzh = Tcon tcFloatzh
 ktFloatzh = Kunlifted
 

@@ -202,7 +203,7 @@ opsFloatzh = [
 
 {- Intzh -}
 
 
 {- Intzh -}
 

-tcIntzh = (primMname,"Intzh")
+tcIntzh = pvz "Int"

 tIntzh = Tcon tcIntzh
 ktIntzh = Kunlifted
 
 tIntzh = Tcon tcIntzh
 ktIntzh = Kunlifted
 

@@ -236,7 +237,7 @@ opsIntzh = [
 
 {- Int32zh -}
 
 
 {- Int32zh -}
 

-tcInt32zh = (primMname,"Int32zh")
+tcInt32zh = pvz "Int32"

 tInt32zh = Tcon tcInt32zh
 ktInt32zh = Kunlifted
 
 tInt32zh = Tcon tcInt32zh
 ktInt32zh = Kunlifted
 

@@ -247,7 +248,7 @@ opsInt32zh = [
 
 {- Int64zh -}
 
 
 {- Int64zh -}
 

-tcInt64zh = (primMname,"Int64zh")
+tcInt64zh = pvz "Int64"

 tInt64zh = Tcon tcInt64zh
 ktInt64zh = Kunlifted
 
 tInt64zh = Tcon tcInt64zh
 ktInt64zh = Kunlifted
 

@@ -289,7 +290,7 @@ opsIntegerzh = [
 
 {- Wordzh -}
 
 
 {- Wordzh -}
 

-tcWordzh = (primMname,"Wordzh")
+tcWordzh = pvz "Word"

 tWordzh = Tcon tcWordzh
 ktWordzh = Kunlifted
 
 tWordzh = Tcon tcWordzh
 ktWordzh = Kunlifted
 

@@ -317,7 +318,7 @@ opsWordzh = [
 
 {- Word32zh -}
 
 
 {- Word32zh -}
 

-tcWord32zh = (primMname,"Word32zh")
+tcWord32zh = pvz "Word32"

 tWord32zh = Tcon tcWord32zh
 ktWord32zh = Kunlifted
 
 tWord32zh = Tcon tcWord32zh
 ktWord32zh = Kunlifted
 

@@ -327,7 +328,7 @@ opsWord32zh = [
 
 {- Word64zh -}
 
 
 {- Word64zh -}
 

-tcWord64zh = (primMname,"Word64zh")
+tcWord64zh = pvz "Word64"

 tWord64zh = Tcon tcWord64zh
 ktWord64zh = Kunlifted
 
 tWord64zh = Tcon tcWord64zh
 ktWord64zh = Kunlifted
 

@@ -346,19 +347,19 @@ opsSized = [
 
 {- Arrays -}
 
 
 {- Arrays -}
 

-tcArrayzh = (primMname,"Arrayzh")
+tcArrayzh = pvz "Array"

 tArrayzh t = Tapp (Tcon tcArrayzh) t
 ktArrayzh = Karrow Klifted Kunlifted
 
 tArrayzh t = Tapp (Tcon tcArrayzh) t
 ktArrayzh = Karrow Klifted Kunlifted
 

-tcByteArrayzh = (primMname,"ByteArrayzh")
+tcByteArrayzh = pvz "ByteArray"

 tByteArrayzh = Tcon tcByteArrayzh
 ktByteArrayzh = Kunlifted
 
 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)
 
 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
 
 tMutableByteArrayzh s = Tapp (Tcon tcMutableByteArrayzh) s
 ktMutableByteArrayzh = Karrow Klifted Kunlifted
 

@@ -588,7 +589,7 @@ opsArray = [
 
 {- MutVars -}
 
 
 {- MutVars -}
 

-tcMutVarzh = (primMname,"MutVarzh")
+tcMutVarzh = pvz "MutVar"

 tMutVarzh s t = Tapp (Tapp (Tcon tcMutVarzh) s) t
 ktMutVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
 
 tMutVarzh s t = Tapp (Tapp (Tcon tcMutVarzh) s) t
 ktMutVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
 

@@ -617,11 +618,12 @@ opsMutVarzh = [
 
 {- Real world and state. -}
 
 
 {- Real world and state. -}
 

-tcRealWorld = (primMname,"RealWorld")
+-- tjc: why isn't this one unboxed?
+tcRealWorld = pv "RealWorld"

 tRealWorld = Tcon tcRealWorld
 ktRealWorld = Klifted
 
 tRealWorld = Tcon tcRealWorld
 ktRealWorld = Klifted
 

-tcStatezh = (primMname, "Statezh")
+tcStatezh = pvz "State"

 tStatezh t = Tapp (Tcon tcStatezh) t
 ktStatezh = Karrow Klifted Kunlifted
 
 tStatezh t = Tapp (Tcon tcStatezh) t
 ktStatezh = Karrow Klifted Kunlifted
 

@@ -653,7 +655,7 @@ opsExn = [
 
 {- Mvars -} 
 
 
 {- Mvars -} 
 

-tcMVarzh = (primMname, "MVarzh")
+tcMVarzh = pvz "MVar"

 tMVarzh s t = Tapp (Tapp (Tcon tcMVarzh) s) t
 ktMVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
 
 tMVarzh s t = Tapp (Tapp (Tcon tcMVarzh) s) t
 ktMVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
 

@@ -698,7 +700,7 @@ opsMVar = [
 
 {- Weak Objects -}
 
 
 {- Weak Objects -}
 

-tcWeakzh = (primMname, "Weakzh")
+tcWeakzh = pvz "Weak"

 tWeakzh t = Tapp (Tcon tcWeakzh) t
 ktWeakzh = Karrow Klifted Kunlifted
 
 tWeakzh t = Tapp (Tcon tcWeakzh) t
 ktWeakzh = Karrow Klifted Kunlifted
 

@@ -722,7 +724,7 @@ opsWeak = [
 
 {- Foreign Objects -}
 
 
 {- Foreign Objects -}
 

-tcForeignObjzh = (primMname, "ForeignObjzh")
+tcForeignObjzh = pvz "ForeignObj"

 tForeignObjzh = Tcon tcForeignObjzh
 ktForeignObjzh = Kunlifted
 
 tForeignObjzh = Tcon tcForeignObjzh
 ktForeignObjzh = Kunlifted
 

@@ -741,7 +743,7 @@ opsForeignObjzh = [
 
 {- Stable Pointers (but not names) -}
 
 
 {- Stable Pointers (but not names) -}
 

-tcStablePtrzh = (primMname, "StablePtrzh")
+tcStablePtrzh = pvz "StablePtr"

 tStablePtrzh t = Tapp (Tcon tcStablePtrzh) t
 ktStablePtrzh = Karrow Klifted Kunlifted
 
 tStablePtrzh t = Tapp (Tcon tcStablePtrzh) t
 ktStablePtrzh = Karrow Klifted Kunlifted
 

@@ -758,7 +760,7 @@ opsStablePtrzh = [
 
 {- Concurrency  operations -}
 
 
 {- Concurrency  operations -}
 

-tcThreadIdzh = (primMname,"ThreadIdzh")
+tcThreadIdzh = pvz "ThreadId"

 tThreadIdzh = Tcon tcThreadIdzh
 ktThreadIdzh = Kunlifted
 
 tThreadIdzh = Tcon tcThreadIdzh
 ktThreadIdzh = Kunlifted
 

@@ -799,17 +801,19 @@ opsMisc =  [
    We just define the type constructors for the dictionaries
    corresponding to these pseudo-classes. -}
 
    We just define the type constructors for the dictionaries
    corresponding to these pseudo-classes. -}
 

-tcZCTCCallable = (primMname,"ZCTCCallable")
+tcZCTCCallable = pv "ZCTCCallable"

 ktZCTCCallable = Karrow Kopen Klifted  -- ??
 ktZCTCCallable = Karrow Kopen Klifted  -- ??

-tcZCTCReturnable = (primMname,"ZCTCReturnable")
+tcZCTCReturnable = pv "ZCTCReturnable"

 ktZCTCReturnable = Karrow Kopen Klifted  -- ??
 
 {- Non-primitive, but mentioned in the types of primitives. -}
 
 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
 tUnit = Tcon tcUnit
 ktUnit = Klifted

-tcBool = ("PrelBase","Bool")
+tcBool = bv "Bool"

 tBool = Tcon tcBool
 ktBool = Klifted
 
 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")))]
   
  ("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
 tChar = Tcon tcChar
 ktChar = Klifted

-tcList = ("PrelBase","ZMZN")
+tcList = bv "ZMZN"

 tList t = Tapp (Tcon tcList) t
 ktList = Karrow Klifted Klifted
 tString = tList tChar
 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 ded48aa..8ff4ba5 100644 (file)
--- a/utils/ext-core/Printer.hs
+++ b/utils/ext-core/Printer.hs
@@ -1,9 +1,10 @@
 module Printer where
 
 module Printer where
 

-import Pretty
-import Core
-import Char
+import Text.PrettyPrint.HughesPJ

 import Numeric (fromRat)
 import Numeric (fromRat)

+import Char
+
+import Core

 
 instance Show Module where
   showsPrec d m = shows (pmodule m)
 
 instance Show Module where
   showsPrec d m = shows (pmodule m)

@@ -38,8 +39,10 @@ instance Show Lit where
 
 indent = nest 2
 
 
 indent = nest 2
 

+-- seems like this is asking for a type class...
+

 pmodule (Module mname tdefs vdefgs) =
 pmodule (Module mname tdefs vdefgs) =

-  (text "%module" <+> text mname)
+  (text "%module" <+> panmname mname)

   $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
             $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
 
   $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
             $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
 

@@ -58,8 +61,14 @@ pcdef (Constr qdcon tbinds tys)  =
 
 pname id = text id
 
 
 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)
 
 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 (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)))))
                             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
 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 7ec8adf..6b8168d 100644 (file)
--- 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
 
 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
+