Commit 6efe04de authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Use HsTyPats in associated type family defaults

Associated type family default declarations behave strangely in a
couple of ways:

1. If one tries to bind the type variables with an explicit `forall`,
   the `forall`'d part will simply be ignored. (#16110)
2. One cannot use visible kind application syntax on the left-hand
   sides of associated default equations, unlike every other form
   of type family equation. (#16356)

Both of these issues have a common solution. Instead of using
`LHsQTyVars` to represent the left-hand side arguments of an
associated default equation, we instead use `HsTyPats`, which is what
other forms of type family equations use. In particular, here are
some highlights of this patch:

* `FamEqn` is no longer parameterized by a `pats` type variable, as
  the `feqn_pats` field is now always `HsTyPats`.
* The new design for `FamEqn` in chronicled in
  `Note [Type family instance declarations in HsSyn]`.
* `TyFamDefltEqn` now becomes the same thing as `TyFamInstEqn`. This
  means that many of `TyFamDefltEqn`'s code paths can now reuse the
  code paths for `TyFamInstEqn`, resulting in substantial
  simplifications to various parts of the code dealing with
  associated type family defaults.

Fixes #16110 and #16356.
parent 2c15b85e
Pipeline #5950 failed with stages
in 379 minutes and 45 seconds
......@@ -328,7 +328,7 @@ repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
; fds1 <- repLFunDeps fds
; ats1 <- repFamilyDecls ats
; atds1 <- repAssocTyFamDefaults atds
; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds
; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
; wrapGenSyms ss decls2 }
......@@ -454,35 +454,8 @@ repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
repAssocTyFamDefaults = mapM rep_deflt
where
-- very like repTyFamEqn, but different in the details
rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tys
, feqn_fixity = fixity
, feqn_rhs = rhs }))
= addTyClTyVarBinds tys $ \ _ ->
do { tc1 <- lookupLOcc tc
; no_bndrs <- ASSERT( isNothing bndrs )
coreNothingList tyVarBndrQTyConName
; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
; lhs <- case fixity of
Prefix -> do { head_ty <- repNamedTyCon tc1
; repTapps head_ty tys1 }
Infix -> do { (t1:t2:args) <- checkTys tys1
; head_ty <- repTInfix t1 tc1 t2
; repTapps head_ty args }
; rhs1 <- repLTy rhs
; eqn1 <- repTySynEqn no_bndrs lhs rhs1
; repTySynInst eqn1 }
rep_deflt _ = panic "repAssocTyFamDefaults"
checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]
checkTys tys@(_:_:_) = return tys
checkTys _ = panic "repAssocTyFamDefaults:checkTys"
repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)
repAssocTyFamDefaultD = repTyFamInstD
-------------------------
-- represent fundeps
......
......@@ -333,7 +333,7 @@ instance HasLoc a => HasLoc [a] where
loc [] = noSrcSpan
loc xs = foldl1' combineSrcSpans $ map loc xs
instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
instance HasLoc a => HasLoc (FamEqn s a) where
loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
[loc a, loc tvs, loc b, loc c]
......@@ -1149,18 +1149,12 @@ instance ToHie (LTyClDecl GhcRn) where
, toHie $ fmap (BC InstanceBind ModuleScope) meths
, toHie typs
, concatMapM (pure . locOnly . getLoc) deftyps
, toHie $ map (go . unLoc) deftyps
, toHie deftyps
]
where
context_scope = mkLScope context
rhs_scope = foldl1' combineScopes $ map mkScope
[ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
go :: TyFamDefltEqn GhcRn
-> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
go (FamEqn a var bndrs pat b rhs) =
FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
go (XFamEqn NoExt) = XFamEqn NoExt
XTyClDecl _ -> []
instance ToHie (LFamilyDecl GhcRn) where
......@@ -1206,15 +1200,12 @@ instance ToHie (Located (FunDep (Located Name))) where
, toHie $ map (C Use) rhs
]
instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
=> ToHie (TScoped (FamEqn GhcRn pats rhs)) where
instance (ToHie rhs, HasLoc rhs)
=> ToHie (TScoped (FamEqn GhcRn rhs)) where
toHie (TS _ f) = toHie f
instance ( ToHie pats
, ToHie rhs
, HasLoc pats
, HasLoc rhs
) => ToHie (FamEqn GhcRn pats rhs) where
instance (ToHie rhs, HasLoc rhs)
=> ToHie (FamEqn GhcRn rhs) where
toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
[ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
, toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
......
......@@ -243,27 +243,20 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs
; unless (null adts')
(failWith $ (text "Default data instance declarations"
<+> text "are not allowed:")
$$ (Outputable.ppr adts'))
; at_defs <- mapM cvt_at_def ats'
; returnJustL $ TyClD noExt $
ClassDecl { tcdCExt = noExt
, tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
, tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }
, tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
-- no docs in TH ^^
}
where
cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
-- Very similar to what happens in RdrHsSyn.mkClassDecl
cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
Right (def, _) -> return def
Left (_, msg) -> failWith msg
cvtDec (InstanceD o ctxt ty decs)
= do { let doc = text "an instance declaration"
......
......@@ -37,11 +37,11 @@ module HsDecls (
-- ** Instance declarations
InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
TyFamDefltDecl, LTyFamDefltDecl,
DataFamInstDecl(..), LDataFamInstDecl,
pprDataFamInstFlavour, pprHsFamInstLHS,
pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,
FamInstEqn, LFamInstEqn, FamEqn(..),
TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
HsTyPats,
TyFamInstEqn, LTyFamInstEqn, HsTyPats,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
......@@ -533,7 +533,7 @@ data TyClDecl pass
tcdSigs :: [LSig pass], -- ^ Methods' signatures
tcdMeths :: LHsBinds pass, -- ^ Default methods
tcdATs :: [LFamilyDecl pass], -- ^ Associated types;
tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults
tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults
tcdDocs :: [LDocDecl] -- ^ Haddock docs
}
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
......@@ -726,7 +726,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
| otherwise -- Laid out
= vcat [ top_matter <+> text "where"
, nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++
map ppr_fam_deflt_eqn at_defs ++
map (pprTyFamDefltDecl . unLoc) at_defs ++
pprLHsBindsForUser methods sigs) ]
where
top_matter = text "class"
......@@ -1507,28 +1507,23 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
Note [Type family instance declarations in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The data type FamEqn represents one equation of a type family instance.
Aside from the pass, it is also parameterised over two fields:
feqn_pats and feqn_rhs.
feqn_pats is either LHsTypes (for ordinary data/type family instances) or
LHsQTyVars (for associated type family default instances). In particular:
* An ordinary type family instance declaration looks like this in source Haskell
type instance T [a] Int = a -> a
(or something similar for a closed family)
It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats
field.
* On the other hand, the *default instance* of an associated type looks like
this in source Haskell
class C a where
type T a b
type T a b = a -> b -- The default instance
It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in
the feqn_pats field.
Aside from the pass, it is also parameterised over another field, feqn_rhs.
feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType
(for type family instances).
Type family instances also include associated type family default equations.
That is because a default for a type family looks like this:
class C a where
type family F a b :: Type
type F c d = (c,d) -- Default instance
The default declaration is really just a `type instance` declaration, but one
with particularly simple patterns: they must all be distinct type variables.
That's because we will instantiate it (in an instance declaration for `C`) if
we don't give an explicit instance for `F`. Note that the names of the
variables don't need to match those of the class: it really is like a
free-standing `type instance` declaration.
-}
----------------- Type synonym family instances -------------
......@@ -1540,16 +1535,13 @@ type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
-- For details on above see note [Api annotations] in ApiAnnotation
-- | Located Type Family Default Equation
type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
-- | Haskell Type Patterns
type HsTyPats pass = [LHsTypeArg pass]
{- Note [Family instance declaration binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For ordinary data/type family instances, the feqn_pats field of FamEqn stores
the LHS type (and kind) patterns. Any type (and kind) variables contained
The feqn_pats field of FamEqn (family instance equation) stores the LHS type
(and kind) patterns. Any type (and kind) variables contained
in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs
in FamInstEqn depending on whether or not an explicit forall is present. In
the case of an explicit forall, the hsib_vars only includes kind variables not
......@@ -1577,19 +1569,19 @@ the hsib_vars. In the latter case, note that in particular
so that we can compare the type pattern in the 'instance' decl and
in the associated 'type' decl
For associated type family default instances (TyFamDefltEqn), instead of using
type patterns with binders in a surrounding HsImplicitBndrs, we use raw type
variables (LHsQTyVars) in the feqn_pats field of FamEqn.
c.f. Note [TyVar binders for associated declarations]
c.f. Note [TyVar binders for associated decls]
-}
-- | Type Family Instance Equation
type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
-- | Type Family Default Equation
type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
-- See Note [Type family instance declarations in HsSyn]
-- | Type family default declarations.
-- A convenient synonym for 'TyFamInstDecl'.
-- See @Note [Type family instance declarations in HsSyn]@.
type TyFamDefltDecl = TyFamInstDecl
-- | Located type family default declarations.
type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass)
-- | Located Type Family Instance Declaration
type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
......@@ -1625,8 +1617,7 @@ newtype DataFamInstDecl pass
type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
-- | Family Instance Equation
type FamInstEqn pass rhs
= HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)
-- ^ Here, the @pats@ are type patterns (with kind and type bndrs).
-- See Note [Family instance declaration binders]
......@@ -1636,23 +1627,23 @@ type FamInstEqn pass rhs
-- declaration, or type family default.
-- See Note [Type family instance declarations in HsSyn]
-- See Note [Family instance declaration binders]
data FamEqn pass pats rhs
data FamEqn pass rhs
= FamEqn
{ feqn_ext :: XCFamEqn pass pats rhs
{ feqn_ext :: XCFamEqn pass rhs
, feqn_tycon :: Located (IdP pass)
, feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars
, feqn_pats :: pats
, feqn_pats :: HsTyPats pass
, feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
, feqn_rhs :: rhs
}
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
| XFamEqn (XXFamEqn pass pats rhs)
| XFamEqn (XXFamEqn pass rhs)
-- For details on above see note [Api annotations] in ApiAnnotation
type instance XCFamEqn (GhcPass _) p r = NoExt
type instance XXFamEqn (GhcPass _) p r = NoExt
type instance XCFamEqn (GhcPass _) r = NoExt
type instance XXFamEqn (GhcPass _) r = NoExt
----------------- Class instances -------------
......@@ -1723,6 +1714,10 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
pprTyFamDefltDecl :: (OutputableBndrId (GhcPass p))
=> TyFamDefltDecl (GhcPass p) -> SDoc
pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel
ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
=> TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon
......@@ -1734,16 +1729,6 @@ ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon
ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p))
=> LTyFamDefltEqn (GhcPass p) -> SDoc
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 noLHsContext
<+> equals <+> ppr rhs
ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DataFamInstDecl p) where
ppr = pprDataFamInstDecl TopLevel
......
......@@ -355,12 +355,12 @@ type ForallXConDecl (c :: * -> Constraint) (x :: *) =
-- -------------------------------------
-- FamEqn type families
type family XCFamEqn x p r
type family XXFamEqn x p r
type family XCFamEqn x r
type family XXFamEqn x r
type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) =
( c (XCFamEqn x p r)
, c (XXFamEqn x p r)
type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) =
( c (XCFamEqn x r)
, c (XXFamEqn x r)
)
-- -------------------------------------
......
......@@ -164,10 +164,10 @@ deriving instance Data (DataFamInstDecl GhcPs)
deriving instance Data (DataFamInstDecl GhcRn)
deriving instance Data (DataFamInstDecl GhcTc)
-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs)
deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs)
deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs)
deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs)
-- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs)
deriving instance Data rhs => Data (FamEqn GhcPs rhs)
deriving instance Data rhs => Data (FamEqn GhcRn rhs)
deriving instance Data rhs => Data (FamEqn GhcTc rhs)
-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p)
deriving instance Data (ClsInstDecl GhcPs)
......
......@@ -45,7 +45,6 @@ module RdrHsSyn (
mkExtName, -- RdrName -> CLabelString
mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
mkConDeclH98,
mkATDefault,
-- Bunch of functions in the parser monad for
-- checking and constructing values
......@@ -173,14 +172,12 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl GhcPs)
mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
= do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts
; sequence_ annsi
; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
......@@ -190,34 +187,6 @@ mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
, tcdATs = ats, tcdATDefs = at_defs
, tcdDocs = docs })) }
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
-- ^ Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration.
-- We parse things as the former and use this function to convert to the latter
--
-- We use the Either monad because this also called from "Convert".
--
-- The @P ()@ we return corresponds represents an action which will add
-- some necessary paren annotations to the parsing context. Naturally, this
-- is not something that the "Convert" use cares about.
mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
| FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
, feqn_fixity = fixity, feqn_rhs = rhs } <- e
= do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
; let f = cL loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_bndrs = ASSERT( isNothing bndrs )
Nothing
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs })
; pure (f, addAnnsAt loc anns) }
mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
mkATDefault _ = panic "mkATDefault: Impossible Match"
-- due to #15884
mkTyData :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
......@@ -230,7 +199,7 @@ mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (cL loc (DataDecl { tcdDExt = noExt,
......@@ -263,7 +232,7 @@ mkTySynonym :: SrcSpan
mkTySynonym loc lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; return (cL loc (SynDecl { tcdSExt = noExt
, tcdLName = tc, tcdTyVars = tyvars
......@@ -322,7 +291,7 @@ mkFamDecl :: SrcSpan
mkFamDecl loc info lhs ksig injAnn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; return (cL loc (FamDecl noExt (FamilyDecl
{ fdExt = noExt
......@@ -804,56 +773,47 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
really doesn't matter!
-}
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
-- Same as checkTyVars, but in the P monad
checkTyVarsP pp_what equals_or_where tc tparms
= do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms
; eitherToP checkedTvs }
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP (Left (loc, doc)) = addFatalError loc doc
eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc)
( LHsQTyVars GhcPs -- the synthesized type variables
, [AddAnn] ) -- action which adds annotations
-> P ( LHsQTyVars GhcPs -- the synthesized type variables
, [AddAnn] ) -- action which adds annotations
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
-- We use the Either monad because it's also called (via 'mkATDefault') from
-- "Convert".
checkTyVars pp_what equals_or_where tc tparms
= do { (tvs, anns) <- fmap unzip $ mapM check tparms
; return (mkHsQTvs tvs, concat anns) }
where
check (HsTypeArg _ ki@(L loc _))
= Left (loc,
= addFatalError loc $
vcat [ text "Unexpected type application" <+>
text "@" <> ppr ki
, text "In the" <+> pp_what <+>
ptext (sLit "declaration for") <+> quotes (ppr tc)])
ptext (sLit "declaration for") <+> quotes (ppr tc)]
check (HsValArg ty) = chkParens [] ty
check (HsArgPar sp) = Left (sp, vcat [text "Malformed" <+> pp_what
<+> text "declaration for" <+> quotes (ppr tc)])
check (HsArgPar sp) = addFatalError sp $
vcat [text "Malformed" <+> pp_what
<+> text "declaration for" <+> quotes (ppr tc)]
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn])
-> P (LHsTyVarBndr GhcPs, [AddAnn])
chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l
++ acc) ty
chkParens acc ty = case chk ty of
Left err -> Left err
Right tv -> Right (tv, reverse acc)
chkParens acc ty = do
tv <- chk ty
return (tv, reverse acc)
-- Check that the name space is correct!
chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs)
chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
| isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k))
chk (dL->L l (HsTyVar _ _ (dL->L ltv tv)))
| isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv)))
chk t@(dL->L loc _)
= Left (loc,
= addFatalError loc $
vcat [ text "Unexpected type" <+> quotes (ppr t)
, text "In the" <+> pp_what
<+> ptext (sLit "declaration for") <+> quotes tc'
......@@ -863,7 +823,7 @@ checkTyVars pp_what equals_or_where tc tparms
(pp_what
<+> tc'
<+> hsep (map text (takeList tparms allNameStrings))
<+> equals_or_where) ] ])
<+> equals_or_where) ] ]
-- Avoid printing a constraint tuple in the error message. Print
-- a plain old tuple instead (since that's what the user probably
......
......@@ -424,11 +424,11 @@ patchCCallTarget unitId callTarget =
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
= do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
= do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi
; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
= do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
= do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi
; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
rnSrcInstDecl (ClsInstD { cid_inst = cid })
......@@ -666,21 +666,22 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
rnFamInstEqn :: HsDocContext
-> Maybe (Name, [Name]) -- Nothing => not associated
-- Just (cls,tvs) => associated,
-- and gives class and tyvars of the
-- parent instance decl
-> AssocTyFamInfo
-> [Located RdrName] -- Kind variables from the equation's RHS
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamInstEqn GhcRn rhs', FreeVars)
rnFamInstEqn doc mb_cls rhs_kvars
rnFamInstEqn doc atfi rhs_kvars
(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_bndrs = mb_bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = payload }}) rn_payload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
= do { let mb_cls = case atfi of
NonAssocTyFamEqn -> Nothing
AssocTyFamDeflt cls -> Just cls
AssocTyFamInst cls _ -> Just cls
; tycon' <- lookupFamInstName mb_cls tycon
; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
-- Use the "...Dups" form because it's needed
-- below to report unsed binder on the LHS
......@@ -730,9 +731,10 @@ rnFamInstEqn doc mb_cls rhs_kvars
-- Note [Unused type variables in family instances]
; let nms_used = extendNameSetList rhs_fvs $
inst_tvs ++ nms_dups
inst_tvs = case mb_cls of
Nothing -> []
Just (_, inst_tvs) -> inst_tvs
inst_tvs = case atfi of
NonAssocTyFamEqn -> []
AssocTyFamDeflt _ -> []
AssocTyFamInst _ inst_tvs -> inst_tvs
all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
; warnUnusedTypePatterns all_nms nms_used
......@@ -753,15 +755,27 @@ rnFamInstEqn doc mb_cls rhs_kvars
rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
rnTyFamInstDecl :: Maybe (Name, [Name]) -- Just (cls,tvs) => associated,
-- and gives class and tyvars of
-- the parent instance decl
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
= do { (eqn', fvs) <- rnTyFamInstEqn mb_cls NotClosedTyFam eqn
rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })
= do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn
; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
-- | Tracks whether we are renaming:
--
-- 1. A type family equation that is not associated
-- with a parent type class ('NonAssocTyFamEqn')
--
-- 2. An associated type family default delcaration ('AssocTyFamDeflt')
--
-- 3. An associated type family instance declaration ('AssocTyFamInst')
data AssocTyFamInfo
= NonAssocTyFamEqn
| AssocTyFamDeflt Name -- Name of the parent class
| AssocTyFamInst Name -- Name of the parent class
[Name] -- Names of the tyvars of the parent instance decl
-- | Tracks whether we are renaming an equation in a closed type family
-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
data ClosedTyFamInfo
......@@ -769,17 +783,17 @@ data ClosedTyFamInfo
| ClosedTyFam (Located RdrName) Name
-- The names (RdrName and Name) of the closed type family
rnTyFamInstEqn :: Maybe (Name, [Name])
rnTyFamInstEqn :: AssocTyFamInfo
-> ClosedTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn mb_cls ctf_info
rnTyFamInstEqn atfi ctf_info
eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})
= do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
; (eqn'@(HsIB { hsib_body =
FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)
<- rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn
<- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
; case ctf_info of
NotClosedTyFam -> pure ()
ClosedTyFam fam_rdr_name fam_name ->
......@@ -790,38 +804,20 @@ rnTyFamInstEqn mb_cls ctf_info
rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn GhcPs
-> RnM (TyFamDefltEqn GhcRn, FreeVars)
rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
, feqn_bndrs = bndrs
, feqn_pats = tyvars
, feqn_fixity = fixity
, feqn_rhs = rhs })
= do { let kvs = extractHsTyRdrTyVarsKindVars rhs
; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tycon'
, feqn_bndrs = ASSERT( isNothing bndrs )
Nothing
, feqn_pats = tyvars'
, feqn_fixity = fixity
, feqn_rhs = rhs' }, fvs) } }
where
ctx = TyFamilyCtx tycon
rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
-> RnM (TyFamDefltDecl GhcRn, FreeVars)
rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)
rnDataFamInstDecl :: Maybe (Name, [Name])
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})})
rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})})
= do { let rhs_kvs = extractDataDefnKindVars rhs
; (eqn', fvs) <-
rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn
; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
= panic "rnDataFamInstDecl"
......@@ -837,8 +833,8 @@ rnATDecls :: Name -- Class
rnATDecls cls at_decls
= rnList (rnFamDecl (Just cls)) at_decls
rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
decl GhcPs -> -- an instance. rnTyFamInstDecl
rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames
decl GhcPs -> -- an instance. rnTyFamInstDecl
RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
-> Name -- Class
-> [Name]
......@@ -850,7 +846,7 @@ rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
-- NB: We allow duplicate associated-type decls;
-- See Note [Associated type instances] in TcInstDcls
rnATInstDecls rnFun cls tv_ns at_insts
= rnList (rnFun (Just (cls, tv_ns))) at_insts
= rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts
-- See Note [Renaming associated types]