Commit 5e3f005d by simonpj

### [project @ 2001-11-26 09:20:25 by simonpj]

----------------------
Implement Rank-N types
----------------------

This commit implements the full glory of Rank-N types, using
the Odersky/Laufer approach described in their paper
"Putting type annotations to work"

In fact, I've had to adapt their approach to deal with the
full glory of Haskell (including pattern matching, and the
scoped-type-variable extension).  However, the result is:

* There is no restriction to rank-2 types.  You can nest forall's
as deep as you like in a type.  For example, you can write a type
like
p :: ((forall a. Eq a => a->a) -> Int) -> Int
This is a rank-3 type, illegal in GHC 5.02

* When matching types, GHC uses the cunning Odersky/Laufer coercion
rules.  For example, suppose we have
q :: (forall c. Ord c => c->c) -> Int
Then, is this well typed?
x :: Int
x = p q
Yes, it is, but GHC has to generate the right coercion.  Here's
what it looks like with all the big lambdas and dictionaries put in:

x = p (\ f :: (forall a. Eq a => a->a) ->
q (/\c \d::Ord c -> f c (eqFromOrd d)))

where eqFromOrd selects the Eq superclass dictionary from the Ord
dicationary:		eqFromOrd :: Ord a -> Eq a

* You can use polymorphic types in pattern type signatures.  For
example:

f (g :: forall a. a->a) = (g 'c', g True)

(Previously, pattern type signatures had to be monotypes.)

* The basic rule for using rank-N types is that you must specify
a type signature for every binder that you want to have a type
scheme (as opposed to a plain monotype) as its type.

However, you don't need to give the type signature on the
binder (as I did above in the defn for f).  You can give it
in a separate type signature, thus:

f :: (forall a. a->a) -> (Char,Bool)
f g = (g 'c', g True)

GHC will push the external type signature inwards, and use
that information to decorate the binders as it comes across them.
I don't have a *precise* specification of this process, but I
think it is obvious enough in practice.

* In a type synonym you can use rank-N types too.  For example,
you can write

type IdFun = forall a. a->a

f :: IdFun -> (Char,Bool)
f g = (g 'c', g True)

As always, type synonyms must always occur saturated; GHC
expands them before it does anything else.  (Still, GHC goes
to some trouble to keep them unexpanded in error message.)

The main plan is as before.  The main typechecker for expressions,
tcExpr, takes an "expected type" as its argument.  This greatly
improves error messages.  The new feature is that when this
"expected type" (going down) meets an "actual type" (coming up)
we use the new subsumption function
TcUnify.tcSub
which checks that the actual type can be coerced into the
expected type (and produces a coercion function to demonstrate).

The main new chunk of code is TcUnify.tcSub.  The unifier itself
is unchanged, but it has moved from TcMType into TcUnify.  Also
checkSigTyVars has moved from TcMonoType into TcUnify.
Result: the new module, TcUnify, contains all stuff relevant
to subsumption and unification.

Unfortunately, there is now an inevitable loop between TcUnify
and TcSimplify, but that's just too bad (a simple TcUnify.hi-boot
file).

Before	16,551
After	17,116
parent f5a6b456
 ... ... @@ -28,7 +28,7 @@ then then TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId, loop Generics.mkGenInfo) then TcType( lots of TywWiredIn stuff) TcType( lots of TysWiredIn stuff) then PprType( lots of TcType stuff ) then ... ...
 * Can a scoped type variable denote a type scheme? * Relation between separate type sigs and pattern type sigs f :: forall a. a->a f :: b->b = e -- No: monomorphic f :: forall a. a->a f :: forall a. a->a -- OK f :: forall a. [a] -> [a] f :: forall b. b->b = e ??? ------------------------------- NB: all floats are let-binds, but some non-rec lets may be unlifted (with RHS ok-for-speculation) ... ...
 ... ... @@ -144,6 +144,7 @@ data NewOrData deriving( Eq ) -- Needed because Demand derives Eq \end{code} %************************************************************************ %* * \subsection[Top-level/local]{Top-level/not-top level flag} ... ...
 ... ... @@ -25,7 +25,7 @@ module DataCon ( import {-# SOURCE #-} Subst( substTyWith ) import {-# SOURCE #-} PprType( pprType ) import Type ( Type, TauType, ThetaType, import Type ( Type, ThetaType, mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTys, splitTyConApp_maybe, repType, mkPredTys, isStrictType ... ... @@ -208,7 +208,7 @@ mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> ThetaType -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> [Type] -> TyCon -> Id -> Id -> DataCon -- Can get the tag from the TyCon ... ... @@ -303,7 +303,7 @@ dataConRepStrictness dc = dcRepStrictness dc dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon) [Type], TyCon) dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, dcExTyVars = ex_tyvars, dcExTheta = ex_theta, ... ... @@ -345,7 +345,7 @@ after any flattening has been done. dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc dataConRepArgTys :: DataCon -> [TauType] dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys dc = dcRepArgTys dc \end{code} ... ...
 ... ... @@ -136,10 +136,8 @@ where it can easily be found. mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc) (addFreeTyVars ty) vanillaIdInfo mkSpecPragmaId :: Name -> Type -> Id mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info ... ...
 ... ... @@ -8,7 +8,7 @@ foreach $f ( @ARGV ) { if ($f =~ /\.lhs$/ ) { open(INF, "/home/simonpj/builds/slpj/ghc/utils/unlit/unlit$f - |") || die "Couldn't unlit $f!\n"; open(INF, "c:/fptools-HEAD/ghc/utils/unlit/unlit$f - |") || die "Couldn't unlit $f!\n"; } else { open(INF, "<$f") || die "Couldn't open $f!\n"; } ... ...  ... ... @@ -564,8 +564,9 @@ simplify_pat :: TypecheckedPat -> TypecheckedPat simplify_pat pat@(WildPat gt) = pat simplify_pat (VarPat id) = WildPat (idType id) simplify_pat (LazyPat p) = simplify_pat p simplify_pat (AsPat id p) = simplify_pat p simplify_pat (LazyPat p) = simplify_pat p simplify_pat (AsPat id p) = simplify_pat p simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps) ... ... @@ -635,5 +636,4 @@ simplify_pat (DictPat dicts methods) = where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) \end{code}  ... ... @@ -45,6 +45,7 @@ import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys ) import DataCon ( isExistentialDataCon ) import Literal ( Literal(..) ) import Type ( ipNameName ) import TyCon ( tyConDataCons ) import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon ) import BasicTypes ( RecFlag(..), Boxity(..) ) ... ... @@ -143,9 +144,9 @@ dsLet (MonoBind binds sigs is_rec) body \begin{code} dsExpr :: TypecheckedHsExpr -> DsM CoreExpr dsExpr (HsVar var) = returnDs (Var var) dsExpr (HsIPVar var) = returnDs (Var var) dsExpr (HsLit lit) = dsLit lit dsExpr (HsVar var) = returnDs (Var var) dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit -- HsOverLit has been gotten rid of by the type checker dsExpr expr@(HsLam a_Match) ... ... @@ -258,7 +259,7 @@ dsExpr (HsWith expr binds) where dsIPBind body (n, e) = dsExpr e thenDs \ e' -> returnDs (Let (NonRec n e') body) returnDs (Let (NonRec (ipNameName n) e') body) dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc) | maybeToBool maybe_list_comp ... ...  ... ... @@ -449,15 +449,13 @@ mkSelectorBinds pat val_expr | otherwise = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) thenDs \ error_expr -> matchSimply val_expr PatBindRhs pat local_tuple error_expr thenDs \ tuple_expr -> newSysLocalDs tuple_ty thenDs \ tuple_var -> = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) thenDs \ error_expr -> matchSimply val_expr PatBindRhs pat local_tuple error_expr thenDs \ tuple_expr -> newSysLocalDs tuple_ty thenDs \ tuple_var -> let mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) in returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where ... ...  ... ... @@ -8,6 +8,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w #include "HsVersions.h" import {-# SOURCE #-} DsExpr( dsExpr ) import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType ) ... ... @@ -238,21 +239,13 @@ And gluing the success expressions'' together isn't quite so pretty. \begin{code} match [] eqns_info = complete_matches eqns_info = returnDs (foldr1 combineMatchResults match_results) where complete_matches [eqn] = complete_match eqn complete_matches (eqn:eqns) = complete_match eqn thenDs \ match_result1 -> complete_matches eqns thenDs \ match_result2 -> returnDs (combineMatchResults match_result1 match_result2) complete_match (EqnInfo _ _ pats match_result) = ASSERT( null pats ) returnDs match_result match_results = [ ASSERT( null pats) mr | EqnInfo _ _ pats mr <- eqns_info ] \end{code} %************************************************************************ %* * %* match: non-empty rule * ... ... @@ -382,6 +375,16 @@ tidy1 v (AsPat var pat) match_result match_result' | v == var = match_result | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result tidy1 v (SigPat pat ty fn) match_result = selectMatchVar pat thenDs \ v' -> tidy1 v' pat match_result thenDs \ (WildPat _, match_result') -> -- The ice is a little thin here -- We only expect a SigPat (with a non-trivial coercion) wrapping -- a variable pattern. If it was a constructor or literal pattern -- there would be no interesting polymorphism, and hence no coercion. dsExpr (HsApp fn (HsVar v)) thenDs \ e -> returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result') tidy1 v (WildPat ty) match_result = returnDs (WildPat ty, match_result) ... ... @@ -573,7 +576,7 @@ matchUnmixedEqns all_vars@(var:vars) eqns_info where first_pat = head column_1_pats column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info] column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info] remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info] \end{code} ... ...  ... ... @@ -21,7 +21,7 @@ import Name ( Name ) import ForeignCall ( Safety ) import Outputable import PprType ( pprParendType ) import Type ( Type ) import Type ( Type, IPName ) import Var ( TyVar ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) ... ... @@ -38,7 +38,7 @@ import SrcLoc ( SrcLoc ) \begin{code} data HsExpr id pat = HsVar id -- variable | HsIPVar id -- implicit parameter | HsIPVar (IPName id) -- implicit parameter | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker | HsLit HsLit -- Simple (non-overloaded) literals ... ... @@ -83,7 +83,7 @@ data HsExpr id pat (HsExpr id pat) | HsWith (HsExpr id pat) -- implicit parameter binding [(id, HsExpr id pat)] [(IPName id, HsExpr id pat)] | HsDo HsDoContext [Stmt id pat] -- "do":one or more stmts ... ... @@ -218,7 +218,7 @@ ppr_expr (HsVar v) | isOperator v = parens (ppr v) | otherwise = ppr v ppr_expr (HsIPVar v) = char '?' <> ppr v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit ... ... @@ -413,10 +413,10 @@ pp_rbinds thing rbinds \begin{code} pp_ipbinds :: (Outputable id, Outputable pat) => [(id, HsExpr id pat)] -> SDoc => [(IPName id, HsExpr id pat)] -> SDoc pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs)) where pp_item (id,rhs) = char '?' <> ppr id <+> equals <+> ppr_expr rhs pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs \end{code} ... ...  ... ... @@ -9,8 +9,8 @@ module HsPat ( OutPat(..), irrefutablePat, irrefutablePats, failureFreePat, isWildPat, patsAreAllCons, isConPat, failureFreePat, isWildPat, patsAreAllCons, isConPat, patsAreAllLits, isLitPat, collectPatBinders, collectPatsBinders, collectSigTysFromPat, collectSigTysFromPats ... ... @@ -87,6 +87,12 @@ data OutPat id | AsPat id -- as pattern (OutPat id) | SigPat (OutPat id) -- Pattern p Type -- Type, t, of the whole pattern (HsExpr id (OutPat id)) -- Coercion function, -- of type t -> typeof(p) | ListPat -- Syntactic list Type -- The type of the elements [OutPat id] ... ... @@ -187,6 +193,8 @@ pprOutPat (LazyPat pat) = hcat [char '~', ppr pat] pprOutPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) pprOutPat (SigPat pat ty _) = ppr pat <+> dcolon <+> ppr ty pprOutPat (ConPat name ty [] [] []) = ppr name ... ...  ... ... @@ -30,7 +30,7 @@ module HsTypes ( #include "HsVersions.h" import Class ( FunDep ) import TcType ( Type, Kind, ThetaType, SourceType(..), import TcType ( Type, Kind, ThetaType, SourceType(..), IPName, tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType ) import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation ... ... @@ -80,7 +80,7 @@ This is the syntax for types as seen in type signatures. type HsContext name = [HsPred name] data HsPred name = HsClassP name [HsType name] | HsIParam name (HsType name) | HsIParam (IPName name) (HsType name) data HsType name = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures ... ... @@ -191,7 +191,7 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where instance Outputable name => Outputable (HsPred name) where ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty] ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc pprHsTyVarBndr name kind | kind eqKind liftedTypeKind = ppr name ... ... @@ -353,7 +353,7 @@ toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty) toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys) toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty) toHsPred (IParam n ty) = HsIParam n (toHsType ty) toHsContext :: ThetaType -> HsContext Name toHsContext theta = map toHsPred theta ... ...  ... ... @@ -52,7 +52,8 @@ module HscTypes ( #include "HsVersions.h" import RdrName ( RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList ) import RdrName ( RdrName, RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList ) import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) import NameEnv import OccName ( OccName ) ... ... @@ -63,6 +64,7 @@ import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import Id ( Id ) import Type ( IPName ) import Class ( Class, classSelIds ) import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) import DataCon ( dataConId, dataConWrapId ) ... ... @@ -585,7 +587,7 @@ data NameSupply } type OrigNameCache = FiniteMap (ModuleName,OccName) Name type OrigIParamCache = FiniteMap OccName Name type OrigIParamCache = FiniteMap (IPName RdrName) (IPName Name) \end{code} @ImportedModuleInfo@ contains info ONLY about modules that have not yet ... ...  ... ... @@ -210,7 +210,8 @@ data Token | ITqvarsym (FAST_STRING,FAST_STRING) | ITqconsym (FAST_STRING,FAST_STRING) | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x | ITpragma StringBuffer ... ... @@ -653,7 +654,9 @@ lexToken cont glaexts buf = cont (ITunknown "\NUL") (stepOn buf) '?'# | flag glaexts && is_lower (lookAhead# buf 1#) -> lex_ip cont (incLexeme buf) lex_ip ITdupipvarid cont (incLexeme buf) '%'# | flag glaexts && is_lower (lookAhead# buf 1#) -> lex_ip ITsplitipvarid cont (incLexeme buf) c | is_digit c -> lex_num cont glaexts 0 buf | is_symbol c -> lex_sym cont buf | is_upper c -> lex_con cont glaexts buf ... ... @@ -936,10 +939,10 @@ lex_cstring cont buf = ----------------------------------------------------------------------------- -- identifiers, symbols etc. lex_ip cont buf = lex_ip ip_constr cont buf = case expandWhile# is_ident buf of buf' -> cont (ITipvarid lexeme) buf' where lexeme = lexemeToFastString buf' buf' -> cont (ip_constr (tailFS lexeme)) buf' where lexeme = lexemeToFastString buf' lex_id cont glaexts buf = let buf1 = expandWhile# is_ident buf in ... ...  {- -----------------------------------------------------------------------------$Id: Parser.y,v 1.76 2001/10/31 15:22:54 simonpj Exp Id: Parser.y,v 1.77 2001/11/26 09:20:26 simonpj Exp $Haskell grammar. ... ... @@ -13,6 +13,7 @@ module Parser ( parseModule, parseStmt, parseIdentifier ) where import HsSyn import HsTypes ( mkHsTupCon ) import TypeRep ( IPName(..) ) import RdrHsSyn import Lex ... ... @@ -189,7 +190,8 @@ Conflicts: 14 shift/reduce QVARSYM { ITqvarsym $$} QCONSYM { ITqconsym$$ } IPVARID { ITipvarid $$} -- GHC extension IPDUPVARID { ITdupipvarid$$ } -- GHC extension IPSPLITVARID { ITsplitipvarid $$} -- GHC extension CHAR { ITchar$$ } STRING { ITstring $$} ... ... @@ -914,17 +916,17 @@ fbind :: { (RdrName, RdrNameHsExpr, Bool) } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings dbinding :: { [(RdrName, RdrNameHsExpr)] } dbinding :: { [(IPName RdrName, RdrNameHsExpr)] } : '{' dbinds '}' { 2 } | layout_on dbinds close { 2 } dbinds :: { [(RdrName, RdrNameHsExpr)] } dbinds :: { [(IPName RdrName, RdrNameHsExpr)] } : dbinds ';' dbind { 3 : 1 } | dbinds ';' { 1 } | dbind { [1] } | {- empty -} { [] } dbind :: { (RdrName, RdrNameHsExpr) } dbind :: { (IPName RdrName, RdrNameHsExpr) } dbind : ipvar '=' exp { (1, 3) } ----------------------------------------------------------------------------- ... ... @@ -969,8 +971,9 @@ qvar :: { RdrName } -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. ipvar :: { RdrName } : IPVARID { (mkUnqual varName (tailFS 1)) } ipvar :: { IPName RdrName } : IPDUPVARID { Dupable (mkUnqual varName 1) } | IPSPLITVARID { MustSplit (mkUnqual varName 1) } qcon :: { RdrName } : qconid { 1 } ... ...  ... ... @@ -98,7 +98,7 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, TauType, ThetaType ) ThetaType ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames import Array ... ... @@ -184,7 +184,7 @@ mk_tc_gen_info mod tc_uniq tc_name tycon name1 = mkWiredInName mod occ_name1 fn1_key name2 = mkWiredInName mod occ_name2 fn2_key pcDataCon :: Name -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon -- The unique is the first of two free uniques; -- the first is used for the datacon itself and the worker; -- the second is used for the wrapper. ... ...  ... ... @@ -43,6 +43,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), StrictnessMark(..), ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind ) import TypeRep ( IPName(..) ) import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) ) import Lex ... ... @@ -182,7 +183,8 @@ import FastString ( tailFS ) QVARSYM { ITqvarsym$$ } QCONSYM { ITqconsym $$} IPVARID { ITipvarid$$ } -- GHC extension IPDUPVARID { ITdupipvarid $$} -- GHC extension IPSPLITVARID { ITsplitipvarid$$ } -- GHC extension PRAGMA { ITpragma$$} ... ... @@ -626,8 +628,9 @@ qvar_name :: { RdrName } qvar_name : var_name {$1 } | QVARID { mkIfaceOrig varName $1 } ipvar_name :: { RdrName } : IPVARID { mkRdrUnqual (mkSysOccFS varName (tailFS$1)) } ipvar_name :: { IPName RdrName } : IPDUPVARID { Dupable (mkRdrUnqual (mkSysOccFS varName $1)) } | IPSPLITVARID { MustSplit (mkRdrUnqual (mkSysOccFS varName$1)) } qvar_names1 :: { [RdrName] } qvar_names1 : qvar_name { [\$1] } ... ...
 ... ... @@ -25,6 +25,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, Deprecations(..), lookupDeprec, extendLocalRdrEnv ) import Type ( mapIPName ) import RnMonad import Name ( Name, getSrcLoc, nameIsLocalOrFrom, ... ... @@ -161,21 +162,24 @@ newGlobalName mod_name occ name = mkGlobalName uniq mod occ noSrcLoc new_cache = addToFM cache key name newIPName rdr_name newIPName rdr_name_ip = getNameSupplyRn thenRn \ name_supply -> let ipcache = nsIPs name_supply in case lookupFM ipcache key of Just name -> returnRn name Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) thenRn_ returnRn name Just name_ip -> returnRn name_ip Nothing -> setNameSupplyRn new_ns thenRn_ returnRn name_ip where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 name = mkIPName uniq key new_ipcache = addToFM ipcache key name where key = (rdrNameOcc rdr_name) name_ip = mapIPName mk_name rdr_name_ip mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name) new_ipcache = addToFM ipcache key name_ip new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} where key = rdr_name_ip -- Ensures that ?x and %x get distinct Names \end{code} %********************************************************* ... ...
 ... ... @@ -54,7 +54,8 @@ import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet, isClassPred, isTyVarClassPred, getClassPredTys, getClassPredTys_maybe, mkPredName, tidyType, tidyTypes, tidyFreeTyVars, tcCmpType, tcCmpTypes, tcCmpPred tcCmpType, tcCmpTypes, tcCmpPred, IPName, mapIPName, ipNameName ) import CoreFVs ( idFreeTyVars ) import Class ( Class ) ... ... @@ -219,11 +220,12 @@ predsOfInst (LitInst _ _ _ _) = [] ipNamesOfInsts :: [Inst] -> [Name] ipNamesOfInst :: Inst -> [Name] -- Get the implicit parameters mentioned by these Insts -- NB: ?x and %x get different Names ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst] ipNamesOfInst (Dict _ (IParam n _) _) = [n] ipNamesOfInst (Method _ _ _ theta _ _) = [n | IParam n _ <- theta] ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n] ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta] ipNamesOfInst other = [] tyVarsOfInst :: Inst -> TcTyVarSet ... ... @@ -273,7 +275,6 @@ must be witnessed by an actual binding; the second tells whether an \begin{code} instBindingRequired :: Inst -> Bool instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas) instBindingRequired (Dict _ (IParam _ _) _) = False instBindingRequired other = True instCanBeGeneralised :: Inst -> Bool ... ... @@ -310,12 +311,20 @@ newDictsAtLoc inst_loc@(_,loc,_) theta where mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc -- For implicit parameters, since there is only one in scope -- at any time, we use the name of the implicit parameter itself newIPDict orig name ty = tcGetInstLoc orig thenNF_Tc \ inst_loc -> returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc) where pred = IParam name ty -- For vanilla implicit parameters, there is only one in scope -- at any time, so we used to use the name of the implicit parameter itself -- But with splittable implicit parameters there may be many in -- scope, so we make up a new name. newIPDict :: InstOrigin -> IPName Name -> Type -> NF_TcM (IPName Id, Inst) newIPDict orig ip_name ty = tcGetInstLoc orig thenNF_Tc \ inst_loc@(_,loc,_) -> tcGetUnique thenNF_Tc \ uniq -> let pred = IParam ip_name ty id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred) in returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc) \end{code} ... ...
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!