From 276585028d51a2516a31b91a91a1f4bba5c9f8ba Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Mon, 10 Mar 2008 02:58:21 +0000 Subject: [PATCH] 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. --- utils/ext-core/Check.hs | 159 ++++++++++++++++++++++++++++--------------- utils/ext-core/Core.hs | 56 ++++++++++++--- utils/ext-core/Driver.hs | 1 + utils/ext-core/Interp.hs | 45 ++++++------ utils/ext-core/Lex.hs | 2 +- utils/ext-core/Makefile | 5 ++ utils/ext-core/ParseGlue.hs | 3 +- utils/ext-core/Parser.y | 39 +++++++---- utils/ext-core/Prep.hs | 74 ++++++++------------ utils/ext-core/Prims.hs | 64 +++++++++-------- utils/ext-core/Printer.hs | 25 ++++--- utils/ext-core/README | 2 + 12 files changed, 295 insertions(+), 180 deletions(-) create mode 100644 utils/ext-core/Makefile diff --git a/utils/ext-core/Check.hs b/utils/ext-core/Check.hs index a9a3eac..8b928b0 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 2f94f80..89f8294 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 2328eca2..da15dce 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 1988ae9..b2f68bf 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 ad9d2eb..8150b16 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 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 --- 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 1e1c6a3..ac186e3 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 ee65eaa..352108e 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 fd6e827..efcd60e 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 ded48aa..8ff4ba5 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 7ec8adf..6b8168d 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 + -- 1.7.10.4