Commit 3bf54e78 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Hurrah! This major commit adds support for scoped kind variables,

which (finally) fills out the functionality of polymorphic kinds.
It also fixes numerous bugs.

Main changes are:

Renaming stuff
~~~~~~~~~~~~~~
* New type in HsTypes:
     data HsBndrSig sig = HsBSig sig [Name]
  which is used for type signatures in patterns, and kind signatures
  in types.  So when you say
       f (x :: [a]) = x ++ x
  or
       data T (f :: k -> *) (x :: *) = MkT (f x)
  the signatures in both cases are a HsBndrSig.

* The [Name] in HsBndrSig records the variables bound by the
  pattern, that is 'a' in the first example, 'k' in the second,
  and nothing in the third.  The renamer initialises the field.

* As a result I was able to get rid of
     RnHsSyn.extractHsTyNames :: LHsType Name -> NameSet
  and its friends altogether.  Deleted the entire module!
  This led to some knock-on refactoring; in particular the
  type renamer now returns the free variables just like the
  term renamer.

Kind-checking types: mainly TcHsType
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A major change is that instead of kind-checking types in two
passes, we now do one. Under the old scheme, the first pass did
kind-checking and (hackily) annotated the HsType with the
inferred kinds; and the second pass desugared the HsType to a
Type.  But now that we have kind variables inside types, the
first pass (TcHsType.tc_hs_type) can go straight to Type, and
zonking will squeeze out any kind unification variables later.

This is much nicer, but it was much more fiddly than I had expected.

The nastiest corner is this: it's very important that tc_hs_type
uses lazy constructors to build the returned type. See
Note [Zonking inside the knot] in TcHsType.

Type-checking type and class declarations: mainly TcTyClsDecls
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I did tons of refactoring in TcTyClsDecls.  Simpler and nicer now.

Typechecking bindings: mainly TcBinds
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I rejigged (yet again) the handling of type signatures in TcBinds.
It's a bit simpler now.  The main change is that tcTySigs goes
right through to a TcSigInfo in one step; previously it was split
into two, part here and part later.

Unsafe coercions
~~~~~~~~~~~~~~~~
Usually equality coercions have exactly the same kind on both
sides.  But we do allow an *unsafe* coercion between Int# and Bool,
say, used in
    case error Bool "flah" of { True -> 3#; False -> 0# }
-->
    (error Bool "flah") |> unsafeCoerce Bool Int#

So what is the instantiation of (~#) here?
   unsafeCoerce Bool Int# :: (~#) ??? Bool Int#
I'm using OpenKind here for now, but it's un-satisfying that
the lhs and rhs of the ~ don't have precisely the same kind.

More minor
~~~~~~~~~~
* HsDecl.TySynonym has its free variables attached, which makes
  the cycle computation in TcTyDecls.mkSynEdges easier.

* Fixed a nasty reversed-comparison bug in FamInstEnv:
  @@ -490,7 +490,7 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys
     n_tys = length tys
     extra_tys = drop arity tys
     (match_tys, add_extra_tys)
-       | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys)
+       | arity < n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys)
        | otherwise     = (tys,            \res_tys -> res_tys)
parent 0bc6055b
......@@ -563,7 +563,7 @@ mkDataCon name declared_infix
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
mk_pred_strict_mark :: PredType -> HsBang
mk_pred_strict_mark pred
......
......@@ -29,7 +29,6 @@ import Demand
import DataCon
import TyCon
import Type
import Kind
import Coercion
import StaticFlags
import BasicTypes
......@@ -312,12 +311,7 @@ pprTypedLetBinder binder
pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
pprKindedTyVarBndr tyvar
= ptext (sLit "@") <+> ppr tyvar <> opt_kind
where
opt_kind -- Print the kind if not *
| isLiftedTypeKind kind = empty
| otherwise = dcolon <> pprKind kind
kind = tyVarKind tyvar
= ptext (sLit "@") <+> pprTvBndr tyvar
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
......
......@@ -252,8 +252,8 @@ repTyFamily :: LTyClDecl Name
-> ProcessTyVarBinds TH.Dec
-> DsM (Maybe (SrcSpan, Core TH.DecQ))
repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
tcdLName = tc, tcdTyVars = tvs,
tcdKind = opt_kind }))
tcdLName = tc, tcdTyVars = tvs,
tcdKindSig = opt_kind }))
tyVarBinds
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- tyVarBinds tvs $ \bndrs ->
......@@ -403,7 +403,7 @@ in_subst _ [] = False
in_subst n ((n',_):ns) = n==n' || in_subst n ns
mkGadtCtxt :: [Name] -- Tyvars of the data type
-> ResType Name
-> ResType (LHsType Name)
-> DsM (HsContext Name, [(Name,Name)])
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
......@@ -607,7 +607,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm
repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm
= repKind ki >>= repKindedTV nm
-- represent a type context
......
......@@ -356,7 +356,6 @@ Library
RnEnv
RnExpr
RnHsDoc
RnHsSyn
RnNames
RnPat
RnSource
......
......@@ -161,7 +161,9 @@ cvtDec (PragmaD prag)
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
; returnL $ TyClD (TySynonym { tcdLName = tc'
, tcdTyVars = tvs', tcdTyPats = Nothing
, tcdSynRhs = rhs', tcdFVs = placeHolderNames }) }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
......@@ -235,7 +237,9 @@ cvtDec (TySynInstD tc tys rhs)
= do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
; returnL $ InstD $ FamInstDecl $
TySynonym tc' tvs' tys' rhs' }
TySynonym { tcdLName = tc'
, tcdTyVars = tvs', tcdTyPats = tys'
, tcdSynRhs = rhs', tcdFVs = placeHolderNames } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
......@@ -753,9 +757,10 @@ cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
cvtp TH.WildP = return $ WildPat void
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
......@@ -791,8 +796,7 @@ cvt_tv (TH.PlainTV nm)
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' ki' placeHolderKind
}
; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
......
......@@ -449,10 +449,10 @@ data TyClDecl name
| -- | @type/data family T :: *->*@
TyFamily { tcdFlavour:: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKind :: Maybe (LHsKind name) -- result kind
TyFamily { tcdFlavour :: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKindSig :: Maybe (LHsKind name) -- result kind
}
......@@ -501,7 +501,9 @@ data TyClDecl name
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns
-- See Note [tcdTyVars and tcdTyPats]
tcdSynRhs :: LHsType name -- ^ synonym expansion
tcdSynRhs :: LHsType name, -- ^ synonym expansion
tcdFVs :: NameSet -- ^ Free tycons of the decl
-- (Used for cycle detection)
}
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
......@@ -634,7 +636,7 @@ instance OutputableBndr name
= hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon,
tcdTyVars = tyvars, tcdKind = mb_kind})
tcdTyVars = tyvars, tcdKindSig = mb_kind})
= pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
where
pp_flavour = case flavour of
......@@ -766,7 +768,7 @@ data ConDecl name
, con_details :: HsConDeclDetails name
-- ^ The main payload
, con_res :: ResType name
, con_res :: ResType (LHsType name)
-- ^ Result type of the constructor
, con_doc :: Maybe LHsDocString
......@@ -786,16 +788,16 @@ hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map cd_fld_type flds
data ResType name
data ResType ty
= ResTyH98 -- Constructor was declared using Haskell 98 syntax
| ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax,
-- and here is its result type
| ResTyGADT ty -- Constructor was declared using GADT-style syntax,
-- and here is its result type
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (ResType name) where
instance Outputable ty => Outputable (ResType ty) where
-- Debugging only
ppr ResTyH98 = ptext (sLit "ResTyH98")
ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
ppr ResTyH98 = ptext (sLit "ResTyH98")
ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
\end{code}
......@@ -1061,10 +1063,10 @@ data RuleDecl name
data RuleBndr name
= RuleBndr (Located name)
| RuleBndrSig (Located name) (LHsType name)
| RuleBndrSig (Located name) (HsBndrSig (LHsType name))
deriving (Data, Typeable)
collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
instance OutputableBndr name => Outputable (RuleDecl name) where
......
......@@ -132,7 +132,7 @@ data Pat id
------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsType id)
(HsBndrSig (LHsType id))
| SigPatOut (LPat id) -- Pattern with a type signature
Type
......
......@@ -17,7 +17,7 @@ HsTypes: Abstract syntax: user-defined types
module HsTypes (
HsType(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
HsTupleSort(..), HsExplicitFlag(..),
HsContext, LHsContext,
HsQuasiQuote(..),
......@@ -29,7 +29,7 @@ module HsTypes (
ConDeclField(..), pprConDeclFields,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
hsTyVarName, hsTyVarNames,
hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
......@@ -37,6 +37,7 @@ module HsTypes (
splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType,
splitHsAppTys, mkHsAppTys, mkHsOpTy,
placeHolderBndrs,
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
......@@ -47,6 +48,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
import HsLit
import NameSet( FreeVars )
import Name( Name )
import Type
import HsDoc
import BasicTypes
......@@ -119,12 +121,44 @@ type LHsType name = Located (HsType name)
type HsKind name = HsType name
type LHsKind name = Located (HsKind name)
type LHsTyVarBndr name = Located (HsTyVarBndr name)
data HsBndrSig sig
= HsBSig
sig
[Name] -- The *binding* type/kind names of this signature
deriving (Data, Typeable)
-- Consider a binder (or pattern) decoarated with a type or kind,
-- \ (x :: a -> a). blah
-- forall (a :: k -> *) (b :: k). blah
-- Then we use a LHsBndrSig on the binder, so that the
-- renamer can decorate it with the variables bound
-- by the pattern ('a' in the first example, 'k' in the second),
-- assuming that neither of them is in scope already
placeHolderBndrs :: [Name]
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderBndrs = panic "placeHolderBndrs"
data HsTyVarBndr name
= UserTyVar -- No explicit kinding
name -- See Note [Printing KindedTyVars]
PostTcKind
| KindedTyVar
name
(HsBndrSig (LHsKind name)) -- The user-supplied kind signature
PostTcKind
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
deriving (Data, Typeable)
data HsType name
= HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way
-- the user wrote it originally, so that the printer can
-- print it as the user wrote it
[LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list
-- until the renamer fills in the variables
[LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders]
(LHsContext name)
(LHsType name)
......@@ -195,6 +229,22 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
\end{code}
Note [HsForAllTy tyvar binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
After parsing:
* Implicit => empty
Explicit => the varibles the user wrote
After renaming
* Implicit => the *type* variables free in the type
Explicit => the variables the user wrote (renamed)
Note that in neither case do we inclde the kind variables.
In the explicit case, the [HsTyVarBndr] can bring kind variables
into scope: f :: forall (a::k->*) (b::k). a b -> Int
but we do not record them explicitly, similar to the case
for the type variables in a pattern type signature.
Note [Unit tuples]
~~~~~~~~~~~~~~~~~~
Consider the type
......@@ -323,22 +373,6 @@ hsExplicitTvs (L _ (HsForAllTy Explicit tvs _ _)) = hsLTyVarNames tvs
hsExplicitTvs _ = []
---------------------
type LHsTyVarBndr name = Located (HsTyVarBndr name)
data HsTyVarBndr name
= UserTyVar -- No explicit kinding
name -- See Note [Printing KindedTyVars]
PostTcKind
| KindedTyVar
name
(LHsKind name) -- The user-supplied kind signature
PostTcKind
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
deriving (Data, Typeable)
hsTyVarName :: HsTyVarBndr name -> name
hsTyVarName (UserTyVar n _) = n
hsTyVarName (KindedTyVar n _ _) = n
......@@ -368,19 +402,6 @@ hsLTyVarLocName = fmap hsTyVarName
hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
hsLTyVarLocNames = map hsLTyVarLocName
replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2 -- new type name
-> (LHsKind name1 -> m (LHsKind name2)) -- kind renaming
-> m (HsTyVarBndr name2)
replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k
replaceTyVarName (KindedTyVar _ k tck) n' rn = do
k' <- rn k
return $ KindedTyVar n' k' tck
replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2
-> (LHsKind name1 -> m (LHsKind name2))
-> m (LHsTyVarBndr name2)
replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc
\end{code}
......@@ -468,6 +489,9 @@ splitHsFunType other = ([], other)
instance (OutputableBndr name) => Outputable (HsType name) where
ppr ty = pprHsType ty
instance (Outputable sig) => Outputable (HsBndrSig sig) where
ppr (HsBSig ty _) = ppr ty
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name _) = ppr name
ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind]
......
......@@ -761,17 +761,17 @@ lPatImplicits = hs_lpat
%************************************************************************
\begin{code}
collectSigTysFromPats :: [InPat name] -> [LHsType name]
collectSigTysFromPats :: [InPat name] -> [HsBndrSig (LHsType name)]
collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
collectSigTysFromPat :: InPat name -> [LHsType name]
collectSigTysFromPat :: InPat name -> [HsBndrSig (LHsType name)]
collectSigTysFromPat pat = collect_sig_lpat pat []
collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
collect_sig_lpat :: InPat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)]
collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
collect_sig_pat :: Pat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)]
collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
......
......@@ -871,7 +871,7 @@ rule_var_list :: { [RuleBndr RdrName] }
rule_var :: { RuleBndr RdrName }
: varid { RuleBndr $1 }
| '(' varid '::' ctype ')' { RuleBndrSig $2 $4 }
| '(' varid '::' ctype ')' { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) }
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
......@@ -1102,7 +1102,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
tv_bndr :: { LHsTyVarBndr RdrName }
: tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
......@@ -1135,6 +1135,7 @@ akind :: { LHsKind RdrName }
: '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
| '(' kind ')' { LL $ HsParTy $2 }
| pkind { $1 }
| tyvar { L1 $ HsTyVar (unLoc $1) }
pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion]
: qtycon { L1 $ HsTyVar $ unLoc $1 }
......
......@@ -375,7 +375,9 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind
where
bsig = HsBSig (toHsKind k) placeHolderBndrs
ifaceExtRdrName :: Name -> RdrName
ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
......
......@@ -218,7 +218,9 @@ mkTySynonym :: SrcSpan
mkTySynonym loc is_family lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; (tyvars, typats) <- checkTParams is_family lhs tparams
; return (L loc (TySynonym tc tyvars typats rhs)) }
; return (L loc (TySynonym { tcdLName = tc
, tcdTyVars = tyvars, tcdTyPats = typats
, tcdSynRhs = rhs, tcdFVs = placeHolderNames })) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
......@@ -499,7 +501,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
where
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv k placeHolderKind))
| isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
chk t@(L l _)
......@@ -636,7 +638,7 @@ checkAPat dynflags loc e0 = case e0 of
let t' = case t of
L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
other -> other
return (SigPatIn e t')
return (SigPatIn e (HsBSig t' placeHolderBndrs))
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
......
......@@ -477,7 +477,7 @@ keep different state threads separate. It is represented by nothing at all.
\begin{code}
mkStatePrimTy :: Type -> Type
mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty]
statePrimTyCon :: TyCon -- See Note [The State# TyCon]
statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep
......@@ -523,17 +523,17 @@ arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRe
mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep
mkArrayPrimTy :: Type -> Type
mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt]
mkArrayPrimTy elt = mkNakedTyConApp arrayPrimTyCon [elt]
byteArrayPrimTy :: Type
byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon
mkArrayArrayPrimTy :: Type
mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon
mkMutableArrayPrimTy :: Type -> Type -> Type
mkMutableArrayPrimTy s elt = mkTyConApp mutableArrayPrimTyCon [s, elt]
mkMutableArrayPrimTy s elt = mkNakedTyConApp mutableArrayPrimTyCon [s, elt]
mkMutableByteArrayPrimTy :: Type -> Type
mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s]
mkMutableByteArrayPrimTy s = mkNakedTyConApp mutableByteArrayPrimTyCon [s]
mkMutableArrayArrayPrimTy :: Type -> Type
mkMutableArrayArrayPrimTy s = mkTyConApp mutableArrayArrayPrimTyCon [s]
mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s]
\end{code}
%************************************************************************
......@@ -547,7 +547,7 @@ mutVarPrimTyCon :: TyCon
mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep
mkMutVarPrimTy :: Type -> Type -> Type
mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt]
mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
......@@ -561,7 +561,7 @@ mVarPrimTyCon :: TyCon
mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep
mkMVarPrimTy :: Type -> Type -> Type
mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt]
mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
......@@ -575,7 +575,7 @@ tVarPrimTyCon :: TyCon
tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep
mkTVarPrimTy :: Type -> Type -> Type
mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt]
mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
......@@ -589,7 +589,7 @@ stablePtrPrimTyCon :: TyCon
stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep
mkStablePtrPrimTy :: Type -> Type
mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty]
\end{code}
%************************************************************************
......@@ -603,7 +603,7 @@ stableNamePrimTyCon :: TyCon
stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep
mkStableNamePrimTy :: Type -> Type
mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty]
\end{code}
%************************************************************************
......@@ -630,7 +630,7 @@ weakPrimTyCon :: TyCon
weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep
mkWeakPrimTy :: Type -> Type
mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v]
\end{code}
%************************************************************************
......@@ -731,5 +731,5 @@ anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
\end{code}
......@@ -54,8 +54,8 @@ module TysWiredIn (
-- * Tuples
mkTupleTy, mkBoxedTupleTy,
tupleTyCon, promotedTupleTyCon,
tupleCon,
tupleTyCon, tupleCon,
promotedTupleTyCon, promotedTupleDataCon,
unitTyCon, unitDataCon, unitDataConId, pairTyCon,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedSingletonTyCon, unboxedSingletonDataCon,
......@@ -88,6 +88,7 @@ import TysPrim
import Coercion
import Constants ( mAX_TUPLE_SIZE )
import Module ( Module )
import Type ( mkTyConApp )
import DataCon
import Var
import TyCon
......@@ -328,6 +329,9 @@ tupleTyCon ConstraintTuple i = fst (factTupleArr ! i)
promotedTupleTyCon :: TupleSort -> Arity -> TyCon
promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i)
promotedTupleDataCon :: TupleSort -> Arity -> TyCon
promotedTupleDataCon sort i = buildPromotedDataCon (tupleCon sort i)
tupleCon :: TupleSort -> Arity -> DataCon
tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially
tupleCon BoxedTuple i = snd (boxedTupleArr ! i)
......
......@@ -33,10 +33,9 @@ module RnBinds (
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import RnHsSyn
import TcRnMonad
import TcEvidence ( emptyTcEvBinds )
import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
import RnTypes ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
import RnPat
import RnEnv
import DynFlags
......@@ -184,8 +183,8 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot (ValBindsIn mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
; sigs' <- renameSigs HsBootCtxt sigs
; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
; (sigs', fvs) <- renameSigs HsBootCtxt sigs
; return (ValBindsOut [] sigs', usesOnly fvs) }
rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
\end{code}
......@@ -291,13 +290,13 @@ rnValBindsRHS :: HsSigCtxt
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
= do { sigs' <- renameSigs ctxt sigs
= do { (sigs', sig_fvs) <- renameSigs ctxt sigs
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
; case depAnalBinds binds_w_dus of
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
where
valbind' = ValBindsOut anal_binds sigs'
valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
-- Put the sig uses *after* the bindings
-- so that the binders are removed from
-- the uses in the sigs
......@@ -649,7 +648,7 @@ signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
renameSigs :: HsSigCtxt
-> [LSig RdrName]
-> RnM [LSig Name]
-> RnM ([LSig Name], FreeVars)
-- Renames the signatures and performs error checks
renameSigs ctxt sigs
= do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs) -- Duplicate
......@@ -662,12 +661,12 @@ renameSigs ctxt sigs
-- op :: a -> a
-- default op :: Eq a => a -> a
; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs
; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
; mapM_ misplacedSigErr bad_sigs -- Misplaced
; return good_sigs }
; return (good_sigs, sig_fvs) }
----------------------
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
......@@ -679,26 +678,26 @@ renameSigs ctxt sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name)
renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
-- FixitySig is renamed elsewhere.
renameSig _ (IdSig x)
= return (IdSig x) -- Actually this never occurs
= return (IdSig x, emptyFVs) -- Actually this never occurs
renameSig ctxt sig@(TypeSig vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (TypeSig new_vs new_ty) }
; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (TypeSig new_vs new_ty, fvs) }
renameSig ctxt sig@(GenericSig vs ty)
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures
; unless defaultSigs_on (addErr (defaultSigErr sig))
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (GenericSig new_v new_ty) }
; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (GenericSig new_v new_ty, fvs) }
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType SpecInstSigCtx ty
; return (SpecInstSig new_ty) }
= do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
; return (SpecInstSig new_ty,fvs) }
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
-- so, in the top-level case (when mb_names is Nothing)
......@@ -708,16 +707,16 @@ renameSig ctxt sig@(SpecSig v ty inl)
= do { new_v <- case ctxt of
TopSigCtxt -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl) }
; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl, fvs) }
renameSig ctxt sig@(InlineSig v s)
= do { new_v <- lookupSigOccRn ctxt sig v
; return (InlineSig new_v s) }
; return (InlineSig new_v s, emptyFVs) }
renameSig ctxt sig@(FixSig (FixitySig v f))
= do { new_v <- lookupSigOccRn ctxt sig v
; return (FixSig (FixitySig new_v f)) }
; return (FixSig (FixitySig new_v f), emptyFVs) }
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
......@@ -778,7 +777,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
{ (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
; return (Match pats' Nothing grhss', grhss_fvs) }}
-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc
resSigErr ctxt match ty
......
......@@ -14,13 +14,16 @@
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn,
lookupLocatedOccRn, lookupOccRn,
lookupLocalOccRn_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndrOcc, greRdrName,
lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName,
greRdrName,
lookupSubBndrGREs, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
......@@ -31,7 +34,6 @@ module RnEnv (
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
addLocalFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
extendTyVarEnvFVRn,
checkDupRdrNames, checkDupAndShadowedRdrNames,
......@@ -40,7 +42,6 @@ module RnEnv (
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg,
HsDocContext(..), docOfHsDocContext
) where
......@@ -49,7 +50,6 @@ module RnEnv (
import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv
import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
import HscTypes
import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage )
......@@ -72,7 +72,6 @@ import ListSetOps ( removeDups )
import DynFlags
import FastString
import Control.Monad
import Data.List
import qualified Data.Set as Set
\end{code}
......@@ -271,6 +270,25 @@ lookupInstDeclBndr cls what rdr
where
doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
-----------------------------------------------
lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
-- Used for TyData and TySynonym only,
-- both ordinary ones and family instances
-- See Note [Family instance binders]
lookupTcdName mb_cls tc_decl
| not (isFamInstDecl tc_decl) -- The normal case
= ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
lookupLocatedTopBndrRn tc_rdr
| Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
= wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
| otherwise -- Family instance; tc_rdr is an *occurrence*
= lookupLocatedOccRn tc_rdr
where