From 3212d689cc0a66e3c9e1f9bd745f20160df90642 Mon Sep 17 00:00:00 2001 From: chak Date: Wed, 13 Nov 2002 09:57:02 +0000 Subject: [PATCH] [project @ 2002-11-13 09:57:02 by chak] Added forall's to the representation of type terms --- ghc/compiler/deSugar/DsMeta.hs | 173 ++++++++++++++++++++++++++++------------ 1 file changed, 123 insertions(+), 50 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 3f00e7f..f263059 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -42,7 +42,8 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), toHsType ) -import PrelNames ( mETA_META_Name, rationalTyConName, negateName ) +import PrelNames ( mETA_META_Name, rationalTyConName, negateName, + parrTyConName ) import MkIface ( ifaceTyThing ) import Name ( Name, nameOccName, nameModule ) import OccName ( isDataOcc, isTvOcc, occNameUserString ) @@ -64,7 +65,7 @@ import TysWiredIn ( stringTy ) import CoreSyn import CoreUtils ( exprType ) import SrcLoc ( noSrcLoc ) -import Maybe ( catMaybes ) +import Maybe ( catMaybes, fromMaybe ) import Panic ( panic ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) @@ -210,7 +211,7 @@ repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, }) = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] tvs1 <- repTvs tvs ; - cxt1 <- repCtxt cxt ; + cxt1 <- repContext cxt ; sigs1 <- rep_sigs sigs ; binds1 <- rep_monobind binds ; decls1 <- coreList declTyConName (sigs1 ++ binds1) ; @@ -226,7 +227,7 @@ repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ; repInstD (InstDecl ty binds _ _ loc) -- Ignore user pragmas for now - = do { cxt1 <- repCtxt cxt ; + = do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) ; binds1 <- rep_monobind binds ; decls1 <- coreList declTyConName binds1 ; @@ -294,45 +295,87 @@ rep_proto nm ty = do { nm1 <- lookupBinder nm ; -- Types ------------------------------------------------------- +-- represent a list of type variables in a usage position that does not need +-- gensym'ing +-- repTvs :: [HsTyVarBndr Name] -> DsM (Core [String]) repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ; return (coreList' stringTy tvs1) } ------------------ -repCtxt :: HsContext Name -> DsM (Core M.Ctxt) -repCtxt ctxt = do { preds <- mapM repPred ctxt; - coreList typeTyConName preds } +-- represent a type context +-- +repContext :: HsContext Name -> DsM (Core M.Ctxt) +repContext ctxt = do + preds <- mapM repPred ctxt + predList <- coreList typeTyConName preds + repCtxt predList ------------------ +-- represent a type predicate +-- repPred :: HsPred Name -> DsM (Core M.Type) -repPred (HsClassP cls tys) - = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1; - tys1 <- repTys tys; repTapps tcon tys1 } -repPred (HsIParam _ _) = panic "No implicit parameters yet" - ------------------ +repPred (HsClassP cls tys) = do + tcon <- repTy (HsTyVar cls) + tys1 <- repTys tys + repTapps tcon tys1 +repPred (HsIParam _ _) = + panic "DsMeta.repTy: Can't represent predicates with implicit parameters" + +-- yield the representation of a list of types +-- repTys :: [HsType Name] -> DsM [Core M.Type] repTys tys = mapM repTy tys ------------------ +-- represent a type +-- repTy :: HsType Name -> DsM (Core M.Type) - +repTy (HsForAllTy bndrs ctxt ty) = + do + let names = map hsTyVarName (fromMaybe [] bndrs) + freshNames <- mkGenSyms names + forallTy <- addBinds freshNames $ do + bndrs' <- mapM lookupBinder names + ctxt' <- repContext ctxt + ty' <- repTy ty + repTForall (coreList' stringTy bndrs') ctxt' ty' + wrapGenSyns typTyConName freshNames forallTy repTy (HsTyVar n) - | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 } - | otherwise = do { tc1 <- lookupOcc n; repNamedTyCon tc1 } -repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 } -repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; - tcon <- repArrowTyCon ; repTapps tcon [f1,a1] } -repTy (HsListTy t) = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 } -repTy (HsTupleTy tc tys) = do { tys1 <- repTys tys; - tcon <- repTupleTyCon (length tys); - repTapps tcon tys1 } + | isTvOcc (nameOccName n) = do + tv1 <- lookupBinder n + repTvar tv1 + | otherwise = do + tc1 <- lookupOcc n + repNamedTyCon tc1 +repTy (HsAppTy f a) = do + f1 <- repTy f + a1 <- repTy a + repTapp f1 a1 +repTy (HsFunTy f a) = do + f1 <- repTy f + a1 <- repTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy t) = do + t1 <- repTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsPArrTy t) = do + t1 <- repTy t + tcon <- repTy (HsTyVar parrTyConName) + repTapp tcon t1 +repTy (HsTupleTy tc tys) = do + tys1 <- repTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2) -repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2) +repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) + `HsAppTy` ty2) repTy (HsParTy t) = repTy t -repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys) +repTy (HsNumTy i) = + panic "DsMeta.repTy: Can't represent number types (for generics)" +repTy (HsPredTy pred) = repPred pred +repTy (HsKindSig ty kind) = + panic "DsMeta.repTy: Can't represent explicit kind signatures yet" -repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig ----------------------------------------------------------------------------- -- Expressions @@ -672,19 +715,31 @@ repListPat (p:ps) = do { p2 <- repP p ---------------------------------------------------------- -- The meta-environment +-- A name/identifier association for fresh names of locally bound entities +-- type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id -- I.e. (x, x_id) means -- let x_id = gensym "x" in ... -addBinds :: [GenSymBind] -> DsM a -> DsM a -addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m - +-- Generate a fresh name for a locally bound entity +-- mkGenSym :: Name -> DsM GenSymBind mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) } +-- Ditto for a list of names +-- mkGenSyms :: [Name] -> DsM [GenSymBind] mkGenSyms ns = mapM mkGenSym ns +-- Add a list of fresh names for locally bound entities to the meta +-- environment (which is part of the state carried around by the desugarer +-- monad) +-- +addBinds :: [GenSymBind] -> DsM a -> DsM a +addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m + +-- Look up a locally bound name +-- lookupBinder :: Name -> DsM (Core String) lookupBinder n = do { mb_val <- dsLookupMetaEnv n; @@ -692,6 +747,11 @@ lookupBinder n Just (Bound x) -> return (coreVar x) other -> pprPanic "Failed binder lookup:" (ppr n) } +-- Look up a name that is either locally bound or a global name +-- +-- * If it is a global name, generate the "original name" representation (ie, +-- the : form) for the associated entity +-- lookupOcc :: Name -> DsM (Core String) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist @@ -913,11 +973,17 @@ repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs repProto :: Core String -> Core M.Type -> DsM (Core M.Decl) repProto (MkC s) (MkC ty) = rep2 protoName [s, ty] +repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt) +repCtxt (MkC tys) = rep2 ctxtName [tys] + repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons) -repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys] +repConstr (MkC con) (MkC tys) = rep2 constrName [con, tys] ------------ Types ------------------- +repTForall :: Core [String] -> Core M.Ctxt -> Core M.Type -> DsM (Core M.Type) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty] + repTvar :: Core String -> DsM (Core M.Type) repTvar (MkC s) = rep2 tvarName [s] @@ -1043,9 +1109,9 @@ templateHaskellNames funName, valName, liftName, gensymName, returnQName, bindQName, sequenceQName, matchName, clauseName, funName, valName, dataDName, classDName, - instName, protoName, tvarName, tconName, tappName, + instName, protoName, tforallName, tvarName, tconName, tappName, arrowTyConName, tupleTyConName, listTyConName, namedTyConName, - constrName, + ctxtName, constrName, exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName, stmtTyConName, consTyConName, typeTyConName, qTyConName, expTyConName, matTyConName, clsTyConName, @@ -1121,15 +1187,19 @@ instName = varQual FSLIT("inst") instIdKey protoName = varQual FSLIT("proto") protoIdKey -- data Typ = ... +tforallName = varQual FSLIT("tforall") tforallIdKey tvarName = varQual FSLIT("tvar") tvarIdKey tconName = varQual FSLIT("tcon") tconIdKey tappName = varQual FSLIT("tapp") tappIdKey -- data Tag = ... -arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey -tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey -listTyConName = varQual FSLIT("listTyCon") listIdKey -namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey +arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey +tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey +listTyConName = varQual FSLIT("listTyCon") listIdKey +namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey + +-- type Ctxt = ... +ctxtName = varQual FSLIT("ctxt") ctxtIdKey -- data Con = ... constrName = varQual FSLIT("constr") constrIdKey @@ -1225,21 +1295,24 @@ letStIdKey = mkPreludeMiscIdUnique 248 noBindStIdKey = mkPreludeMiscIdUnique 249 parStIdKey = mkPreludeMiscIdUnique 250 -tvarIdKey = mkPreludeMiscIdUnique 251 -tconIdKey = mkPreludeMiscIdUnique 252 -tappIdKey = mkPreludeMiscIdUnique 253 +tforallIdKey = mkPreludeMiscIdUnique 251 +tvarIdKey = mkPreludeMiscIdUnique 252 +tconIdKey = mkPreludeMiscIdUnique 253 +tappIdKey = mkPreludeMiscIdUnique 254 + +arrowIdKey = mkPreludeMiscIdUnique 255 +tupleIdKey = mkPreludeMiscIdUnique 256 +listIdKey = mkPreludeMiscIdUnique 257 +namedTyConIdKey = mkPreludeMiscIdUnique 258 -arrowIdKey = mkPreludeMiscIdUnique 254 -tupleIdKey = mkPreludeMiscIdUnique 255 -listIdKey = mkPreludeMiscIdUnique 256 -namedTyConIdKey = mkPreludeMiscIdUnique 257 +ctxtIdKey = mkPreludeMiscIdUnique 259 -constrIdKey = mkPreludeMiscIdUnique 258 +constrIdKey = mkPreludeMiscIdUnique 260 -stringLIdKey = mkPreludeMiscIdUnique 259 -rationalLIdKey = mkPreludeMiscIdUnique 260 +stringLIdKey = mkPreludeMiscIdUnique 261 +rationalLIdKey = mkPreludeMiscIdUnique 262 -sigExpIdKey = mkPreludeMiscIdUnique 261 +sigExpIdKey = mkPreludeMiscIdUnique 263 -- 1.7.10.4