Skip to content

GitLab

Commit 3212d689 authored by chak's avatar chak
Browse files

[project @ 2002-11-13 09:57:02 by chak] 

Added forall's to the representation of type terms
parent 12a5d425
Hide whitespace changes
Inline Side-by-side
ghc/compiler/deSugar/DsMeta.hs
View file @ 3212d689
......@@ -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 <module>:<name> 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment