Commit 5e3f005d authored by simonpj's avatar simonpj
Browse files

[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).


All of this doesn't come entirely for free.  Here's the typechecker
line count (INCLUDING comments)
	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}
......
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