Permalink
Browse files

Revise implementation of overlapping type family instances.

This commit changes the syntax and story around overlapping type
family instances. Before, we had "unbranched" instances and
"branched" instances. Now, we have closed type families and
open ones.

The behavior of open families is completely unchanged. In particular,
coincident overlap of open type family instances still works, despite
emails to the contrary.

A closed type family is declared like this:
> type family F a where
>   F Int = Bool
>   F a   = Char
The equations are tried in order, from top to bottom, subject to
certain constraints, as described in the user manual. It is not
allowed to declare an instance of a closed family.
  • Loading branch information...
1 parent 11db9cf commit 569b26526403df4d88fe2a6d64c7dade09d003ad Richard Eisenberg committed Jun 21, 2013
Showing with 1,428 additions and 1,165 deletions.
  1. +1 −1 compiler/coreSyn/CoreLint.lhs
  2. +76 −41 compiler/deSugar/DsMeta.hs
  3. +10 −5 compiler/hsSyn/Convert.lhs
  4. +33 −39 compiler/hsSyn/HsDecls.lhs
  5. +14 −13 compiler/iface/BinIface.hs
  6. +1 −1 compiler/iface/BuildTyCl.lhs
  7. +1 −1 compiler/iface/IfaceEnv.lhs
  8. +51 −23 compiler/iface/IfaceSyn.lhs
  9. +1 −1 compiler/iface/IfaceType.lhs
  10. +29 −16 compiler/iface/MkIface.lhs
  11. +27 −17 compiler/iface/TcIface.lhs
  12. +2 −2 compiler/iface/TcIface.lhs-boot
  13. +3 −3 compiler/main/GHC.hs
  14. +1 −1 compiler/main/HscMain.hs
  15. +9 −7 compiler/main/HscTypes.lhs
  16. +2 −2 compiler/main/InteractiveEval.hs
  17. +9 −4 compiler/main/PprTyThing.hs
  18. +1 −1 compiler/main/TidyPgm.lhs
  19. +12 −9 compiler/parser/Parser.y.pp
  20. +12 −20 compiler/parser/RdrHsSyn.lhs
  21. +1 −0 compiler/prelude/TysPrim.lhs
  22. +20 −10 compiler/rename/RnSource.lhs
  23. +45 −56 compiler/typecheck/FamInst.lhs
  24. +9 −12 compiler/typecheck/TcDeriv.lhs
  25. +3 −2 compiler/typecheck/TcEnv.lhs
  26. +1 −2 compiler/typecheck/TcExpr.lhs
  27. +2 −3 compiler/typecheck/TcGenDeriv.lhs
  28. +4 −6 compiler/typecheck/TcGenGenerics.lhs
  29. +1 −1 compiler/typecheck/TcHsType.lhs
  30. +24 −46 compiler/typecheck/TcInstDcls.lhs
  31. +5 −10 compiler/typecheck/TcInteract.lhs
  32. +12 −16 compiler/typecheck/TcRnDriver.lhs
  33. +1 −1 compiler/typecheck/TcRnTypes.lhs
  34. +26 −3 compiler/typecheck/TcSMonad.lhs
  35. +34 −33 compiler/typecheck/TcSplice.lhs
  36. +115 −47 compiler/typecheck/TcTyClsDecls.lhs
  37. +17 −1 compiler/typecheck/TcValidity.lhs
  38. +61 −23 compiler/types/CoAxiom.lhs
  39. +3 −57 compiler/types/Coercion.lhs
  40. +431 −445 compiler/types/FamInstEnv.lhs
  41. +12 −11 compiler/types/OptCoercion.lhs
  42. +46 −26 compiler/types/TyCon.lhs
  43. +74 −36 compiler/types/Unify.lhs
  44. +1 −2 compiler/vectorise/Vectorise.hs
  45. +1 −1 compiler/vectorise/Vectorise/Env.hs
  46. +2 −2 compiler/vectorise/Vectorise/Generic/PAMethods.hs
  47. +4 −5 compiler/vectorise/Vectorise/Generic/PData.hs
  48. +1 −1 compiler/vectorise/Vectorise/Monad/InstEnv.hs
  49. +1 −1 compiler/vectorise/Vectorise/Type/Env.hs
  50. +1 −5 compiler/vectorise/Vectorise/Utils/Base.hs
  51. +1 −1 compiler/vectorise/Vectorise/Utils/PADict.hs
  52. +24 −8 docs/core-spec/CoreLint.ott
  53. +3 −1 docs/core-spec/CoreSyn.ott
  54. +1 −0 docs/core-spec/Makefile
  55. +14 −1 docs/core-spec/core-spec.mng
  56. BIN docs/core-spec/core-spec.pdf
  57. +130 −81 docs/users_guide/glasgow_exts.xml
  58. +2 −2 ghc/InteractiveUI.hs
@@ -939,7 +939,7 @@ lintCoercion co@(AxiomInstCo con ind cos)
; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs
; case checkAxInstCo co of
- Just bad_index -> bad_ax $ ptext (sLit "inconsistent with") <+> (ppr bad_index)
+ Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch)
Nothing -> return ()
; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
where
View
@@ -258,18 +258,29 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
+repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
fdLName = tc,
fdTyVars = tvs,
fdKindSig = opt_kind }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- do { flav <- repFamilyFlavour flavour
- ; case opt_kind of
- Nothing -> repFamilyNoKind flav tc1 bndrs
- Just ki -> do { ki1 <- repLKind ki
- ; repFamilyKind flav tc1 bndrs ki1 }
- }
+ case (opt_kind, info) of
+ (Nothing, ClosedTypeFamily eqns) ->
+ do { eqns1 <- mapM repTyFamEqn eqns
+ ; eqns2 <- coreList tySynEqnQTyConName eqns1
+ ; repClosedFamilyNoKind tc1 bndrs eqns2 }
+ (Just ki, ClosedTypeFamily eqns) ->
+ do { eqns1 <- mapM repTyFamEqn eqns
+ ; eqns2 <- coreList tySynEqnQTyConName eqns1
+ ; ki1 <- repLKind ki
+ ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
+ (Nothing, _) ->
+ do { info' <- repFamilyInfo info
+ ; repFamilyNoKind info' tc1 bndrs }
+ (Just ki, _) ->
+ do { info' <- repFamilyInfo info
+ ; ki1 <- repLKind ki
+ ; repFamilyKind info' tc1 bndrs ki1 }
; return (loc, dec)
}
@@ -317,9 +328,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
-- represent family declaration flavours
--
-repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
-repFamilyFlavour TypeFamily = rep2 typeFamName []
-repFamilyFlavour DataFamily = rep2 dataFamName []
+repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
+repFamilyInfo OpenTypeFamily = rep2 typeFamName []
+repFamilyInfo DataFamily = rep2 dataFamName []
+repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
-- Represent instance declarations
--
@@ -362,12 +374,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
-repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
+repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
= do { let tc_name = tyFamInstDeclLName decl
- ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- ; eqns1 <- mapM repTyFamEqn eqns
- ; eqns2 <- coreList tySynEqnQTyConName eqns1
- ; repTySynInst tc eqns2 }
+ ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
+ ; eqn1 <- repTyFamEqn eqn
+ ; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
@@ -1688,9 +1699,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
= rep2 familyKindDName [flav, nm, tvs, ki]
-repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ)
-repTySynInst (MkC nm) (MkC eqns)
- = rep2 tySynInstDName [nm, eqns]
+repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst (MkC nm) (MkC eqn)
+ = rep2 tySynInstDName [nm, eqn]
+
+repClosedFamilyNoKind :: Core TH.Name
+ -> Core [TH.TyVarBndr]
+ -> Core [TH.TySynEqnQ]
+ -> DsM (Core TH.DecQ)
+repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
+ = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
+
+repClosedFamilyKind :: Core TH.Name
+ -> Core [TH.TyVarBndr]
+ -> Core TH.Kind
+ -> Core [TH.TySynEqnQ]
+ -> DsM (Core TH.DecQ)
+repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
+ = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
repTySynEqn (MkC lhs) (MkC rhs)
@@ -1994,7 +2020,8 @@ templateHaskellNames = [
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName,
familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
- tySynInstDName, infixLDName, infixRDName, infixNDName,
+ tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
+ infixLDName, infixRDName, infixNDName,
-- Cxt
cxtName,
-- Pred
@@ -2207,6 +2234,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
+ closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
infixLDName, infixRDName, infixNDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
@@ -2227,6 +2255,10 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
+closedTypeFamilyKindDName
+ = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey
+closedTypeFamilyNoKindDName
+ = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey
infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey
@@ -2543,29 +2575,32 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
+ closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
-funDIdKey = mkPreludeMiscIdUnique 330
-valDIdKey = mkPreludeMiscIdUnique 331
-dataDIdKey = mkPreludeMiscIdUnique 332
-newtypeDIdKey = mkPreludeMiscIdUnique 333
-tySynDIdKey = mkPreludeMiscIdUnique 334
-classDIdKey = mkPreludeMiscIdUnique 335
-instanceDIdKey = mkPreludeMiscIdUnique 336
-sigDIdKey = mkPreludeMiscIdUnique 337
-forImpDIdKey = mkPreludeMiscIdUnique 338
-pragInlDIdKey = mkPreludeMiscIdUnique 339
-pragSpecDIdKey = mkPreludeMiscIdUnique 340
-pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
-pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
-pragRuleDIdKey = mkPreludeMiscIdUnique 413
-familyNoKindDIdKey = mkPreludeMiscIdUnique 342
-familyKindDIdKey = mkPreludeMiscIdUnique 343
-dataInstDIdKey = mkPreludeMiscIdUnique 344
-newtypeInstDIdKey = mkPreludeMiscIdUnique 345
-tySynInstDIdKey = mkPreludeMiscIdUnique 346
-infixLDIdKey = mkPreludeMiscIdUnique 347
-infixRDIdKey = mkPreludeMiscIdUnique 348
-infixNDIdKey = mkPreludeMiscIdUnique 349
+funDIdKey = mkPreludeMiscIdUnique 330
+valDIdKey = mkPreludeMiscIdUnique 331
+dataDIdKey = mkPreludeMiscIdUnique 332
+newtypeDIdKey = mkPreludeMiscIdUnique 333
+tySynDIdKey = mkPreludeMiscIdUnique 334
+classDIdKey = mkPreludeMiscIdUnique 335
+instanceDIdKey = mkPreludeMiscIdUnique 336
+sigDIdKey = mkPreludeMiscIdUnique 337
+forImpDIdKey = mkPreludeMiscIdUnique 338
+pragInlDIdKey = mkPreludeMiscIdUnique 339
+pragSpecDIdKey = mkPreludeMiscIdUnique 340
+pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
+pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
+pragRuleDIdKey = mkPreludeMiscIdUnique 413
+familyNoKindDIdKey = mkPreludeMiscIdUnique 342
+familyKindDIdKey = mkPreludeMiscIdUnique 343
+dataInstDIdKey = mkPreludeMiscIdUnique 344
+newtypeInstDIdKey = mkPreludeMiscIdUnique 345
+tySynInstDIdKey = mkPreludeMiscIdUnique 346
+closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347
+closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
+infixLDIdKey = mkPreludeMiscIdUnique 349
+infixRDIdKey = mkPreludeMiscIdUnique 350
+infixNDIdKey = mkPreludeMiscIdUnique 351
-- type Cxt = ...
cxtIdKey :: Unique
View
@@ -215,7 +215,7 @@ cvtDec (FamilyD flav tc tvs kind)
; kind' <- cvtMaybeKind kind
; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
where
- cvtFamFlavour TypeFam = TypeFamily
+ cvtFamFlavour TypeFam = OpenTypeFamily
cvtFamFlavour DataFam = DataFamily
cvtDec (DataInstD ctxt tc tys constrs derivs)
@@ -243,13 +243,18 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn, dfid_fvs = placeHolderNames } }}
-cvtDec (TySynInstD tc eqns)
+cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
- ; eqns' <- mapM (cvtTySynEqn tc') eqns
+ ; eqn' <- cvtTySynEqn tc' eqn
; returnL $ InstD $ TyFamInstD
- { tfid_inst = TyFamInstDecl { tfid_eqns = eqns'
- , tfid_group = (length eqns' /= 1)
+ { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames } } }
+
+cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
+ = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
+ ; mkind' <- cvtMaybeKind mkind
+ ; eqns' <- mapM (cvtTySynEqn tc') eqns
+ ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
View
@@ -24,7 +24,7 @@ module HsDecls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
- InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
+ InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
TyFamInstEqn(..), LTyFamInstEqn,
@@ -470,16 +470,17 @@ data TyClDecl name
type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl
- { fdFlavour :: FamilyFlavour -- type or data
+ { fdInfo :: FamilyInfo name -- type or data, closed or open
, fdLName :: Located name -- type constructor
, fdTyVars :: LHsTyVarBndrs name -- type variables
, fdKindSig :: Maybe (LHsKind name) } -- result kind
deriving( Data, Typeable )
-data FamilyFlavour
- = TypeFamily
- | DataFamily
- deriving( Data, Typeable, Eq )
+data FamilyInfo name
+ = DataFamily
+ | OpenTypeFamily
+ | ClosedTypeFamily [LTyFamInstEqn name]
+ deriving( Data, Typeable )
\end{code}
@@ -510,12 +511,15 @@ isFamilyDecl _other = False
-- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool
-isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily
-isTypeFamilyDecl _other = False
+isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
+ OpenTypeFamily -> True
+ ClosedTypeFamily {} -> True
+ _ -> False
+isTypeFamilyDecl _ = False
-- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool
-isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily
+isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
isDataFamilyDecl _other = False
\end{code}
@@ -528,11 +532,9 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: OutputableBndr name
=> TyFamInstDecl name -> Located name
-tyFamInstDeclLName (TyFamInstDecl { tfid_eqns =
- (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ })
- -- there may be more than one equation, but grab the name from the first
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
+ (L _ (TyFamInstEqn { tfie_tycon = ln })) })
= ln
-tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
tyClDeclLName :: TyClDecl name -> Located name
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
@@ -598,17 +600,26 @@ instance OutputableBndr name
<+> pprFundeps (map unLoc fds)
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
- ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon,
+ ppr (FamilyDecl { fdInfo = info, fdLName = ltycon,
fdTyVars = tyvars, fdKindSig = mb_kind})
- = ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
+ = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where
+ , nest 2 $ pp_eqns ]
where
pp_kind = case mb_kind of
Nothing -> empty
Just kind -> dcolon <+> ppr kind
+ (pp_where, pp_eqns) = case info of
+ ClosedTypeFamily eqns -> ( ptext (sLit "where")
+ , vcat $ map ppr eqns )
+ _ -> (empty, empty)
+
+pprFlavour :: FamilyInfo name -> SDoc
+pprFlavour DataFamily = ptext (sLit "data family")
+pprFlavour OpenTypeFamily = ptext (sLit "type family")
+pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family")
-instance Outputable FamilyFlavour where
- ppr TypeFamily = ptext (sLit "type family")
- ppr DataFamily = ptext (sLit "data family")
+instance Outputable (FamilyInfo name) where
+ ppr = pprFlavour
pp_vanilla_decl_head :: OutputableBndr name
=> Located name
@@ -838,10 +849,9 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
\begin{code}
----------------- Type synonym family instances -------------
--- See note [Family instance equation groups]
type LTyFamInstEqn name = Located (TyFamInstEqn name)
--- | One equation in a family instance declaration
+-- | One equation in a type family instance declaration
data TyFamInstEqn name
= TyFamInstEqn
{ tfie_tycon :: Located name
@@ -854,15 +864,10 @@ data TyFamInstEqn name
type LTyFamInstDecl name = Located (TyFamInstDecl name)
data TyFamInstDecl name
= TyFamInstDecl
- { tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns
- -- Always non-empty
- , tfid_group :: Bool -- Was this declared with the "where" syntax?
- , tfid_fvs :: NameSet } -- The group is type-checked as one,
- -- so one NameSet will do
- -- INVARIANT: tfid_group == False --> length tfid_eqns == 1
+ { tfid_eqn :: LTyFamInstEqn name
+ , tfid_fvs :: NameSet }
deriving( Typeable, Data )
-
----------------- Data family instances -------------
type LDataFamInstDecl name = Located (DataFamInstDecl name)
@@ -925,24 +930,13 @@ tvs are fv(pat_tys), *including* ones that are already in scope
so that we can compare the type patter in the 'instance' decl and
in the associated 'type' decl
-Note [Family instance equation groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A TyFamInstDecl contains a list of FamInstEqn's, one for each
-equation defined in the instance group. For a standalone
-instance declaration, this list contains exactly one element.
-It is not possible for this list to have 0 elements --
-'type instance where' without anything else is not allowed.
-
\begin{code}
instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
ppr = pprTyFamInstDecl TopLevel
pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = [eqn] })
+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns })
- = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext (sLit "where"))
- 2 (vcat (map ppr eqns))
ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = ptext (sLit "instance")
Oops, something went wrong.

0 comments on commit 569b265

Please sign in to comment.