Commit 2257a86d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Taming the Kind Inference Monster

My original goal was (Trac #15809) to move towards using level numbers
as the basis for deciding which type variables to generalise, rather
than searching for the free varaibles of the environment.  However
it has turned into a truly major refactoring of the kind inference
engine.

Let's deal with the level-numbers part first:

* Augment quantifyTyVars to calculate the type variables to
  quantify using level numbers, and compare the result with
  the existing approach.  That is; no change in behaviour,
  just a WARNing if the two approaches give different answers.

* To do this I had to get the level number right when calling
  quantifyTyVars, and this entailed a bit of care, especially
  in the code for kind-checking type declarations.

* However, on the way I was able to eliminate or simplify
  a number of calls to solveEqualities.

This work is incomplete: I'm not /using/ level numbers yet.
When I subsequently get rid of any remaining WARNings in
quantifyTyVars, that the level-number answers differ from
the current answers, then I can rip out the current
"free vars of the environment" stuff.

Anyway, this led me into deep dive into kind inference for type and
class declarations, which is an increasingly soggy part of GHC.
Richard already did some good work recently in

   commit 5e45ad10
   Date:   Thu Sep 13 09:56:02 2018 +0200

    Finish fix for #14880.

    The real change that fixes the ticket is described in
    Note [Naughty quantification candidates] in TcMType.

but I kept turning over stones. So this patch has ended up
with a pretty significant refactoring of that code too.

Kind inference for types and classes
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

* Major refactoring in the way we generalise the inferred kind of
  a TyCon, in kcTyClGroup.  Indeed, I made it into a new top-level
  function, generaliseTcTyCon.  Plus a new Note to explain it
  Note [Inferring kinds for type declarations].

* We decided (Trac #15592) not to treat class type variables specially
  when dealing with Inferred/Specified/Required for associated types.
  That simplifies things quite a bit. I also rewrote
  Note [Required, Specified, and Inferred for types]

* Major refactoring of the crucial function kcLHsQTyVars:
  I split it into
       kcLHsQTyVars_Cusk  and  kcLHsQTyVars_NonCusk
  because the two are really quite different. The CUSK case is
  almost entirely rewritten, and is much easier because of our new
  decision not to treat the class variables specially

* I moved all the error checks from tcTyClTyVars (which was a bizarre
  place for it) into generaliseTcTyCon and/or the CUSK case of
  kcLHsQTyVars.  Now tcTyClTyVars is extremely simple.

* I got rid of all the all the subtleties in tcImplicitTKBndrs. Indeed
  now there is no difference between tcImplicitTKBndrs and
  kcImplicitTKBndrs; there is now a single bindImplicitTKBndrs.
  Same for kc/tcExplicitTKBndrs.  None of them monkey with level
  numbers, nor build implication constraints.  scopeTyVars is gone
  entirely, as is kcLHsQTyVarBndrs. It's vastly simpler.

  I found I could get rid of kcLHsQTyVarBndrs entirely, in favour of
  the bnew bindExplicitTKBndrs.

Quantification
~~~~~~~~~~~~~~
* I now deal with the "naughty quantification candidates"
  of the previous patch in candidateQTyVars, rather than in
  quantifyTyVars; see Note [Naughty quantification candidates]
  in TcMType.

  I also killed off closeOverKindsCQTvs in favour of the same
  strategy that we use for tyCoVarsOfType: namely, close over kinds
  at the occurrences.

  And candidateQTyVars no longer needs a gbl_tvs argument.

* Passing the ContextKind, rather than the expected kind itself,
  to tc_hs_sig_type_and_gen makes it easy to allocate the expected
  result kind (when we are in inference mode) at the right level.

Type families
~~~~~~~~~~~~~~
* I did a major rewrite of the impenetrable tcFamTyPats. The result
  is vastly more comprehensible.

* I got rid of kcDataDefn entirely, quite a big function.

* I re-did the way that checkConsistentFamInst works, so
  that it allows alpha-renaming of invisible arguments.

* The interaction of kind signatures and family instances is tricky.
    Type families: see Note [Apparently-nullary families]
    Data families: see Note [Result kind signature for a data family instance]
                   and Note [Eta-reduction for data families]

* The consistent instantation of an associated type family is tricky.
  See Note [Checking consistent instantiation] and
      Note [Matching in the consistent-instantation check]
  in TcTyClsDecls.  It's now checked in TcTyClsDecls because that is
  when we have the relevant info to hand.

* I got tired of the compromises in etaExpandFamInst, so I did the
  job properly by adding a field cab_eta_tvs to CoAxBranch.
  See Coercion.etaExpandCoAxBranch.

tcInferApps and friends
~~~~~~~~~~~~~~~~~~~~~~~
* I got rid of the mysterious and horrible ClsInstInfo argument
  to tcInferApps, checkExpectedKindX, and various checkValid
  functions.  It was horrible!

* I got rid of [Type] result of tcInferApps.  This list was used
  only in tcFamTyPats, when checking the LHS of a type instance;
  and if there is a cast in the middle, the list is meaningless.
  So I made tcInferApps simpler, and moved the complexity
  (not much) to tcInferApps.

  Result: tcInferApps is now pretty comprehensible again.

* I refactored the many function in TcMType that instantiate skolems.

Smaller things

* I rejigged the error message in checkValidTelescope; I think it's
  quite a bit better now.

* checkValidType was not rejecting constraints in a kind signature
     forall (a :: Eq b => blah). blah2
  That led to further errors when we then do an ambiguity check.
  So I make checkValidType reject it more aggressively.

* I killed off quantifyConDecl, instead calling kindGeneralize
  directly.

* I fixed an outright bug in tyCoVarsOfImplic, where we were not
  colleting the tyvar of the kind of the skolems

* Renamed ClsInstInfo to AssocInstInfo, and made it into its
  own data type

* Some fiddling around with pretty-printing of family
  instances which was trickier than I thought.  I wanted
  wildcards to print as plain "_" in user messages, although
  they each need a unique identity in the CoAxBranch.

Some other oddments

* Refactoring around the trace messages from reportUnsolved.
* A bit of extra tc-tracing in TcHsSyn.commitFlexi

This patch fixes a raft of bugs, and includes tests for them.

 * #14887
 * #15740
 * #15764
 * #15789
 * #15804
 * #15817
 * #15870
 * #15874
 * #15881
parent 79d5427e
......@@ -74,6 +74,7 @@ import Class
import Name
import PrelNames
import Var
import VarSet( emptyVarSet )
import Outputable
import Util
import BasicTypes
......@@ -1487,7 +1488,7 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
= mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta
rhs parent gadt_syn
where
binders = mkTyConBindersPreferAnon ktvs liftedTypeKind
binders = mkTyConBindersPreferAnon ktvs emptyVarSet
buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> KnotTied Type -> TyCon
......
......@@ -859,9 +859,10 @@ avoidClashesOccEnv env occs = go env emptyUFM occs
tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName env occ@(OccName occ_sp fs)
| not (fs `elemUFM` env)
&& (fs /= fsLit "_")
-- See Note [Always number wildcard types when tidying]
= (addToUFM env fs 1, occ) -- Desired OccName is free
= -- Desired OccName is free, so use it,
-- and record in 'env' that it's no longer available
(addToUFM env fs 1, occ)
| otherwise
= case lookupUFM env base1 of
Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
......@@ -887,33 +888,6 @@ tidyOccName env occ@(OccName occ_sp fs)
-- If they are the same (n==1), the former wins
-- See Note [TidyOccEnv]
{-
Note [Always number wildcard types when tidying]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following example (from the DataFamilyInstanceLHS test case):
data family Sing (a :: k)
data instance Sing (_ :: MyKind) where
SingA :: Sing A
SingB :: Sing B
If we're not careful during tidying, then when this program is compiled with
-ddump-types, we'll get the following information:
COERCION AXIOMS
axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::
Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _
Yikes! We shouldn't have a wildcard type appearing on the RHS like that. To
avoid this issue, during tidying, we always opt to add a numeric suffix to
types that are simply `_`. That way, you instead end up with:
COERCION AXIOMS
axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::
Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1
Which is at least legal syntax.
-}
{-
************************************************************************
......
......@@ -70,7 +70,7 @@ module VarEnv (
-- * TidyEnv and its operation
TidyEnv,
emptyTidyEnv
emptyTidyEnv, mkEmptyTidyEnv
) where
import GhcPrelude
......@@ -402,6 +402,9 @@ type TidyEnv = (TidyOccEnv, VarEnv Var)
emptyTidyEnv :: TidyEnv
emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv
mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv)
{-
************************************************************************
* *
......
......@@ -1958,11 +1958,12 @@ lintCoercion co@(AxiomInstCo con ind cos)
(zip3 (ktvs ++ cvs) roles cos)
; let lhs' = substTys subst_l lhs
rhs' = substTy subst_r rhs
fam_tc = coAxiomTyCon con
; case checkAxInstCo co of
Just bad_branch -> bad_ax $ text "inconsistent with" <+>
pprCoAxBranch con bad_branch
pprCoAxBranch fam_tc bad_branch
Nothing -> return ()
; let s2 = mkTyConApp (coAxiomTyCon con) lhs'
; let s2 = mkTyConApp fam_tc lhs'
; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }
where
bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what)
......
......@@ -37,7 +37,8 @@ module HsDecls (
-- ** Instance declarations
InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
DataFamInstDecl(..), LDataFamInstDecl,
pprDataFamInstFlavour, pprHsFamInstLHS,
FamInstEqn, LFamInstEqn, FamEqn(..),
TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
HsTyPats,
......@@ -701,7 +702,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
, tcdRhs = rhs })
= hang (text "type" <+>
pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals)
pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals)
4 (ppr rhs)
ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
......@@ -723,8 +724,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
pprLHsBindsForUser methods sigs) ]
where
top_matter = text "class"
<+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pp_vanilla_decl_head lclas tyvars fixity context
<+> pprFundeps (map unLoc fds)
ppr (XTyClDecl x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
......@@ -743,10 +745,10 @@ pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p))
=> Located (IdP (GhcPass p))
-> LHsQTyVars (GhcPass p)
-> LexicalFixity
-> HsContext (GhcPass p)
-> LHsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprHsContext context, pp_tyvars tyvars]
= hsep [pprLHsContext context, pp_tyvars tyvars]
where
pp_tyvars (varl:varsr)
| fixity == Infix && length varsr > 1
......@@ -1109,7 +1111,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdResultSig = L _ result
, fdInjectivityAnn = mb_inj })
= vcat [ pprFlavour info <+> pp_top_level <+>
pp_vanilla_decl_head ltycon tyvars fixity [] <+>
pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+>
pp_kind <+> pp_inj <+> pp_where
, nest 2 $ pp_eqns ]
where
......@@ -1399,10 +1401,10 @@ hsConDeclTheta Nothing = []
hsConDeclTheta (Just (L _ theta)) = theta
pp_data_defn :: (OutputableBndrId (GhcPass p))
=> (HsContext (GhcPass p) -> SDoc) -- Printing the header
=> (LHsContext (GhcPass p) -> SDoc) -- Printing the header
-> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context
, dd_cType = mb_ct
, dd_kindSig = mb_sig
, dd_cons = condecls, dd_derivs = derivings })
......@@ -1453,7 +1455,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
: map (pprHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
cxt = fromMaybe (noLoc []) mcxt
cxt = fromMaybe noLHsContext mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
, con_mb_cxt = mcxt, con_args = args
......@@ -1466,7 +1468,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
cxt = fromMaybe (noLoc []) mcxt
cxt = fromMaybe noLHsContext mcxt
ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
ppr_arrow_chain [] = empty
......@@ -1704,12 +1706,12 @@ ppr_instance_keyword NotTopLevel = empty
ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
=> TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprFamInstLHS tycon bndrs pats fixity [] Nothing <+> equals <+> ppr rhs
= pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs
ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
......@@ -1719,7 +1721,7 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs }))
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity noLHsContext
<+> equals <+> ppr rhs
ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x
......@@ -1730,7 +1732,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
=> TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
FamEqn { feqn_tycon = L _ tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
......@@ -1738,10 +1740,9 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
<+> pprFamInstLHS tycon bndrs pats fixity ctxt Nothing
-- No need to pass an explicit kind signature to
-- pprFamInstLHS here, since pp_data_defn already
-- pretty-prints that. See #14817.
<+> pprHsFamInstLHS tycon bndrs pats fixity ctxt
-- pp_data_defn pretty-prints the kind sig. See #14817.
pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))
= ppr x
pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))
......@@ -1759,35 +1760,28 @@ pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))
pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
= ppr x
pprFamInstLHS :: (OutputableBndrId (GhcPass p))
=> Located (IdP (GhcPass p))
pprHsFamInstLHS :: (OutputableBndrId (GhcPass p))
=> IdP (GhcPass p)
-> Maybe [LHsTyVarBndr (GhcPass p)]
-> HsTyPats (GhcPass p)
-> LexicalFixity
-> HsContext (GhcPass p)
-> Maybe (LHsKind (GhcPass p))
-> LHsContext (GhcPass p)
-> SDoc
pprFamInstLHS thing bndrs typats fixity context mb_kind_sig
-- explicit type patterns
= hsep [ pprHsContext context, pprHsExplicitForAll bndrs
, pp_pats typats, pp_kind_sig ]
pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
= hsep [ pprHsExplicitForAll bndrs
, pprLHsContext mb_ctxt
, pp_pats typats ]
where
pp_pats (patl:patr:pats)
| Infix <- fixity
= let pp_op_app = hsep [ ppr patl, pprInfixOcc (unLoc thing), ppr patr ] in
= let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in
case pats of
[] -> pp_op_app
_ -> hsep (parens pp_op_app : map ppr pats)
pp_pats pats = hsep [ pprPrefixOcc (unLoc thing)
pp_pats pats = hsep [ pprPrefixOcc thing
, hsep (map ppr pats)]
pp_kind_sig
| Just k <- mb_kind_sig
= dcolon <+> ppr k
| otherwise
= empty
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ClsInstDecl p) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
......
......@@ -24,7 +24,7 @@ module HsTypes (
HsWildCardBndrs(..),
LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
HsContext, LHsContext,
HsContext, LHsContext, noLHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
......@@ -63,7 +63,7 @@ module HsTypes (
-- Printing
pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
pprLHsContext,
hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
) where
......@@ -90,7 +90,6 @@ import FastString
import Maybes( isJust )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe ( fromMaybe )
{-
************************************************************************
......@@ -264,9 +263,16 @@ quantified in left-to-right order in kind signatures is nice since:
-- | Located Haskell Context
type LHsContext pass = Located (HsContext pass)
-- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit'
-- For details on above see note [Api annotations] in ApiAnnotation
noLHsContext :: LHsContext pass
-- Use this when there is no context in the original program
-- It would really be more kosher to use a Maybe, to distinguish
-- class () => C a where ...
-- from
-- class C a where ...
noLHsContext = noLoc []
-- | Haskell Context
type HsContext pass = [LHsType pass]
......@@ -1126,7 +1132,7 @@ splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
splitLHsQualTy body = (noLoc [], body)
splitLHsQualTy body = (noLHsContext, body)
splitLHsInstDeclTy :: LHsSigType GhcRn
-> ([Name], LHsContext GhcRn, LHsType GhcRn)
......@@ -1307,7 +1313,7 @@ pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
=> Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pp_forall <+> pprHsContextExtra (isJust extra) (unLoc cxt)
= pp_forall <+> pprLHsContextExtra (isJust extra) cxt
where
pp_forall | null qtvs = whenPprDebug (forAllLit <> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
......@@ -1319,36 +1325,28 @@ pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
pprHsExplicitForAll Nothing = empty
pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
pprLHsContext :: (OutputableBndrId (GhcPass p))
=> LHsContext (GhcPass p) -> SDoc
pprLHsContext lctxt
| null (unLoc lctxt) = empty
| otherwise = pprLHsContextAlways lctxt
-- For use in a HsQualTy, which always gets printed if it exists.
pprHsContextAlways :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
pprLHsContextAlways :: (OutputableBndrId (GhcPass p))
=> LHsContext (GhcPass p) -> SDoc
pprLHsContextAlways (L _ ctxt)
= case ctxt of
[] -> parens empty <+> darrow
[L _ ty] -> ppr_mono_ty ty <+> darrow
_ -> parens (interpp'SP ctxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
pprHsContextExtra :: (OutputableBndrId (GhcPass p))
=> Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
| null ctxt
= char '_' <+> darrow
| otherwise
= parens (sep (punctuate comma ctxt')) <+> darrow
pprLHsContextExtra :: (OutputableBndrId (GhcPass p))
=> Bool -> LHsContext (GhcPass p) -> SDoc
pprLHsContextExtra show_extra lctxt@(L _ ctxt)
| not show_extra = pprLHsContext lctxt
| null ctxt = char '_' <+> darrow
| otherwise = parens (sep (punctuate comma ctxt')) <+> darrow
where
ctxt' = map ppr ctxt ++ [char '_']
......@@ -1386,10 +1384,10 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAll tvs (noLoc []), ppr_mono_lty ty]
= sep [pprHsForAll tvs noLHsContext, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
= sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
......
......@@ -211,12 +211,13 @@ data IfaceAT = IfaceAT -- See Class.ClassATItem
-- This is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
, ifaxbCoVars :: [IfaceIdBndr]
, ifaxbLHS :: IfaceAppArgs
, ifaxbRoles :: [Role]
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
, ifaxbEtaTyVars :: [IfaceTvBndr]
, ifaxbCoVars :: [IfaceIdBndr]
, ifaxbLHS :: IfaceAppArgs
, ifaxbRoles :: [Role]
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
-- See Note [Storing compatibility] in CoAxiom
data IfaceConDecls
......@@ -556,11 +557,19 @@ pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc
-- The TyCon might be local (just an OccName), or this might
-- be a branch for an imported TyCon, so it would be an ExtName
-- So it's easier to take an SDoc here
--
-- This function is used
-- to print interface files,
-- in debug messages
-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon
-- For user error messages we use Coercion.pprCoAxiom and friends
pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
, ifaxbCoVars = _cvs
, ifaxbLHS = pat_tys
, ifaxbRHS = rhs
, ifaxbIncomps = incomps })
= hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
= WARN( not (null _cvs), pp_tc $$ ppr _cvs )
hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
$+$
nest 2 maybe_incomps
where
......@@ -890,10 +899,9 @@ pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
, ifAxBranches = branches })
= hang (text "axiom" <+> ppr name <> dcolon)
= hang (text "axiom" <+> ppr name <+> dcolon)
2 (vcat $ map (pprAxBranch (ppr tycon)) branches)
pprCType :: Maybe CType -> SDoc
pprCType Nothing = Outputable.empty
pprCType (Just cType) = text "C type:" <+> ppr cType
......@@ -1073,13 +1081,14 @@ instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleOrph = orph })
= sep [hsep [pprRuleName name,
if isOrphan orph then text "[orphan]" else Outputable.empty,
ppr act,
text "forall" <+> pprIfaceBndrs bndrs],
nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
text "=" <+> ppr rhs])
]
= sep [ hsep [ pprRuleName name
, if isOrphan orph then text "[orphan]" else Outputable.empty
, ppr act
, pp_foralls ]
, nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
text "=" <+> ppr rhs]) ]
where
pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot
instance Outputable IfaceClsInst where
ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
......@@ -1856,13 +1865,14 @@ instance Binary IfaceAT where
return (IfaceAT dec defs)
instance Binary IfaceAxBranch where
put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
put_ bh a6
put_ bh a7
get bh = do
a1 <- get bh
a2 <- get bh
......@@ -1870,7 +1880,8 @@ instance Binary IfaceAxBranch where
a4 <- get bh
a5 <- get bh
a6 <- get bh
return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
a7 <- get bh
return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7)
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
......
......@@ -22,6 +22,7 @@ module MkIface (
RecompileRequired(..), recompileRequired,
mkIfaceExports,
coAxiomToIfaceDecl,
tyThingToIfaceDecl -- Converting things to their Iface equivalents
) where
......@@ -1634,18 +1635,16 @@ coAxBranchToIfaceBranch tc lhs_s
-- use this one for standalone branches without incompatibles
coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
, cab_eta_tvs = eta_tvs
, cab_lhs = lhs
, cab_roles = roles, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs
, ifaxbCoVars = map toIfaceIdBndr cvs
, ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
, ifaxbRoles = roles
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
(env1, tidy_tvs) = tidyVarBndrs emptyTidyEnv tvs
-- Don't re-bind in-scope tyvars
-- See Note [CoAxBranch type variables] in CoAxiom
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs
, ifaxbCoVars = map toIfaceIdBndr cvs
, ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
, ifaxbLHS = toIfaceTcArgs tc lhs
, ifaxbRoles = roles
, ifaxbRHS = toIfaceType rhs
, ifaxbIncomps = [] }
-----------------
tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
......@@ -1708,6 +1707,7 @@ tyConToIfaceDecl env tycon
(tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
tc_tyvars = binderVars tc_binders
if_binders = toIfaceTyCoVarBinders tc_binders
-- No tidying of the binders; they are already tidy
if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
if_syn_type ty = tidyToIfaceType tc_env1 ty
if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
......@@ -1718,19 +1718,16 @@ tyConToIfaceDecl env tycon
(tidyToIfaceTcArgs tc_env1 tc ty)
Nothing -> IfNoParent
to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
= IfaceClosedSynFamilyTyCon (Just (axn, ibr))
where defs = fromBranches $ coAxiomBranches ax
ibr = map (coAxBranchToIfaceBranch' tycon) defs
axn = coAxiomName ax
to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
= IfaceClosedSynFamilyTyCon Nothing
to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
......
......@@ -857,17 +857,24 @@ tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
(IfaceAxBranch { ifaxbTyVars = tv_bndrs
, ifaxbEtaTyVars = eta_tv_bndrs
, ifaxbCoVars = cv_bndrs
, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyConBinders_AT
(map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
bindIfaceIds cv_bndrs $ \ cvs -> do
{ tc_lhs <- tcIfaceAppArgs lhs
; tc_rhs <- tcIfaceType rhs
; let br = CoAxBranch { cab_loc = noSrcSpan
{ tc_lhs <- tcIfaceAppArgs lhs
; tc_rhs <- tcIfaceType rhs
; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return
; this_mod <- getIfModule
; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`
moduleNameFS (moduleName this_mod))
br = CoAxBranch { cab_loc = loc
, cab_tvs = binderVars tvs
, cab_eta_tvs = eta_tvs
, cab_cvs = cvs
, cab_lhs = tc_lhs
, cab_roles = roles
......@@ -1768,6 +1775,13 @@ bindIfaceTyVar (occ,kind) thing_inside
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars [] thing_inside = thing_inside []
bindIfaceTyVars (bndr:bndrs) thing_inside
= bindIfaceTyVar bndr $ \tv ->
bindIfaceTyVars bndrs $ \tvs ->
thing_inside (tv : tvs)
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
mk_iface_tyvar name ifKind
= do { kind <- tcIfaceType ifKind
......
......@@ -489,7 +489,6 @@ getCfgProc weights (CmmProc _info _lab _live graph)
| null (toBlockList graph) = mapEmpty
| otherwise = getCfg weights graph
getCfg :: D.CfgWeights -> CmmGraph -> CFG
getCfg weights graph =
foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
......
......@@ -871,12 +871,12 @@ equalsDots = text "= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just (dL->L loc c))
checkDatatypeContext (Just c)