diff options
Diffstat (limited to 'compiler/hsSyn/HsDecls.hs')
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 1309 |
1 files changed, 781 insertions, 528 deletions
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 8b7d9c6a40..2d2e911645 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -10,7 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Abstract syntax of global declarations. -- @@ -18,11 +18,11 @@ -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module HsDecls ( -- * Toplevel declarations - HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, - HsDerivingClause(..), LHsDerivingClause, + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, + HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, -- ** Class or type declarations - TyClDecl(..), LTyClDecl, + TyClDecl(..), LTyClDecl, DataDeclRn(..), TyClGroup(..), mkTyClGroup, emptyTyClGroup, tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, isClassDecl, isDataDecl, isSynDecl, tcdName, @@ -35,22 +35,23 @@ module HsDecls ( FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), + InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, - DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, - TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, + DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS, + FamInstEqn, LFamInstEqn, FamEqn(..), + TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, HsTyPats, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, + -- ** Deriving strategies + DerivStrategy(..), LDerivStrategy, derivStrategyName, -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, + LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..), + RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, flattenRuleDecls, pprFullRuleName, - -- ** @VECTORISE@ declarations - VectDecl(..), LVectDecl, - lvectDeclName, lvectInstDecl, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice @@ -58,14 +59,11 @@ module HsDecls ( SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), - noForeignImportCoercionYet, noForeignExportCoercionYet, CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, - HsConDeclDetails, hsConDeclArgTys, - getConNames, - getConDetails, - gadtDeclDetails, + HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, + getConNames, getConArgs, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations @@ -86,7 +84,9 @@ module HsDecls ( ) where -- friends: -import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, +import GhcPrelude + +import {-# SOURCE #-} HsExpr( HsExpr, HsSplice, pprExpr, pprSpliceDecl ) -- Because Expr imports Decls via HsBracket @@ -94,20 +94,18 @@ import HsBinds import HsTypes import HsDoc import TyCon -import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PlaceHolder(..) ) import HsExtension import NameSet -- others: -import InstEnv import Class import Outputable import Util import SrcLoc +import Type import Bag import Maybes @@ -121,7 +119,7 @@ import Data.Data hiding (TyCon,Fixity, Infix) ************************************************************************ -} -type LHsDecl id = Located (HsDecl id) +type LHsDecl p = Located (HsDecl p) -- ^ When in a list this may have -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' @@ -130,24 +128,37 @@ type LHsDecl id = Located (HsDecl id) -- For details on above see note [Api annotations] in ApiAnnotation -- | A Haskell Declaration -data HsDecl id - = TyClD (TyClDecl id) -- ^ Type or Class Declaration - | InstD (InstDecl id) -- ^ Instance declaration - | DerivD (DerivDecl id) -- ^ Deriving declaration - | ValD (HsBind id) -- ^ Value declaration - | SigD (Sig id) -- ^ Signature declaration - | DefD (DefaultDecl id) -- ^ 'default' declaration - | ForD (ForeignDecl id) -- ^ Foreign declaration - | WarningD (WarnDecls id) -- ^ Warning declaration - | AnnD (AnnDecl id) -- ^ Annotation declaration - | RuleD (RuleDecls id) -- ^ Rule declaration - | VectD (VectDecl id) -- ^ Vectorise declaration - | SpliceD (SpliceDecl id) -- ^ Splice declaration - -- (Includes quasi-quotes) - | DocD (DocDecl) -- ^ Documentation comment declaration - | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration -deriving instance (DataId id) => Data (HsDecl id) - +data HsDecl p + = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration + | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration + | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration + | ValD (XValD p) (HsBind p) -- ^ Value declaration + | SigD (XSigD p) (Sig p) -- ^ Signature declaration + | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration + | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration + | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration + | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration + | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration + | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration + -- (Includes quasi-quotes) + | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration + | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration + | XHsDecl (XXHsDecl p) + +type instance XTyClD (GhcPass _) = NoExt +type instance XInstD (GhcPass _) = NoExt +type instance XDerivD (GhcPass _) = NoExt +type instance XValD (GhcPass _) = NoExt +type instance XSigD (GhcPass _) = NoExt +type instance XDefD (GhcPass _) = NoExt +type instance XForD (GhcPass _) = NoExt +type instance XWarningD (GhcPass _) = NoExt +type instance XAnnD (GhcPass _) = NoExt +type instance XRuleD (GhcPass _) = NoExt +type instance XSpliceD (GhcPass _) = NoExt +type instance XDocD (GhcPass _) = NoExt +type instance XRoleAnnotD (GhcPass _) = NoExt +type instance XXHsDecl (GhcPass _) = NoExt -- NB: all top-level fixity decls are contained EITHER -- EITHER SigDs @@ -166,50 +177,56 @@ deriving instance (DataId id) => Data (HsDecl id) -- -- A 'HsDecl' is categorised into a 'HsGroup' before being -- fed to the renamer. -data HsGroup id +data HsGroup p = HsGroup { - hs_valds :: HsValBinds id, - hs_splcds :: [LSpliceDecl id], + hs_ext :: XCHsGroup p, + hs_valds :: HsValBinds p, + hs_splcds :: [LSpliceDecl p], - hs_tyclds :: [TyClGroup id], + hs_tyclds :: [TyClGroup p], -- A list of mutually-recursive groups; -- This includes `InstDecl`s as well; -- Parser generates a singleton list; -- renamer does dependency analysis - hs_derivds :: [LDerivDecl id], + hs_derivds :: [LDerivDecl p], - hs_fixds :: [LFixitySig id], + hs_fixds :: [LFixitySig p], -- Snaffled out of both top-level fixity signatures, -- and those in class declarations - hs_defds :: [LDefaultDecl id], - hs_fords :: [LForeignDecl id], - hs_warnds :: [LWarnDecls id], - hs_annds :: [LAnnDecl id], - hs_ruleds :: [LRuleDecls id], - hs_vects :: [LVectDecl id], + hs_defds :: [LDefaultDecl p], + hs_fords :: [LForeignDecl p], + hs_warnds :: [LWarnDecls p], + hs_annds :: [LAnnDecl p], + hs_ruleds :: [LRuleDecls p], hs_docs :: [LDocDecl] - } -deriving instance (DataId id) => Data (HsGroup id) + } + | XHsGroup (XXHsGroup p) -emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a +type instance XCHsGroup (GhcPass _) = NoExt +type instance XXHsGroup (GhcPass _) = NoExt + + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } hsGroupInstDecls :: HsGroup id -> [LInstDecl id] hsGroupInstDecls = (=<<) group_instds . hs_tyclds -emptyGroup = HsGroup { hs_tyclds = [], +emptyGroup = HsGroup { hs_ext = noExt, + hs_tyclds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], - hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_valds = error "emptyGroup hs_valds: Can't happen", hs_splcds = [], hs_docs = [] } -appendGroups :: HsGroup a -> HsGroup a -> HsGroup a +appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) + -> HsGroup (GhcPass p) appendGroups HsGroup { hs_valds = val_groups1, @@ -222,8 +239,7 @@ appendGroups hs_fords = fords1, hs_warnds = warnds1, hs_ruleds = rulds1, - hs_vects = vects1, - hs_docs = docs1 } + hs_docs = docs1 } HsGroup { hs_valds = val_groups2, hs_splcds = spliceds2, @@ -235,10 +251,10 @@ appendGroups hs_fords = fords2, hs_warnds = warnds2, hs_ruleds = rulds2, - hs_vects = vects2, hs_docs = docs2 } = HsGroup { + hs_ext = noExt, hs_valds = val_groups1 `plusHsValBinds` val_groups2, hs_splcds = spliceds1 ++ spliceds2, hs_tyclds = tyclds1 ++ tyclds2, @@ -249,28 +265,26 @@ appendGroups hs_fords = fords1 ++ fords2, hs_warnds = warnds1 ++ warnds2, hs_ruleds = rulds1 ++ rulds2, - hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } - -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsDecl pass) where - ppr (TyClD dcl) = ppr dcl - ppr (ValD binds) = ppr binds - ppr (DefD def) = ppr def - ppr (InstD inst) = ppr inst - ppr (DerivD deriv) = ppr deriv - ppr (ForD fd) = ppr fd - ppr (SigD sd) = ppr sd - ppr (RuleD rd) = ppr rd - ppr (VectD vect) = ppr vect - ppr (WarningD wd) = ppr wd - ppr (AnnD ad) = ppr ad - ppr (SpliceD dd) = ppr dd - ppr (DocD doc) = ppr doc - ppr (RoleAnnotD ra) = ppr ra - -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsGroup pass) where +appendGroups _ _ = panic "appendGroups" + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where + ppr (TyClD _ dcl) = ppr dcl + ppr (ValD _ binds) = ppr binds + ppr (DefD _ def) = ppr def + ppr (InstD _ inst) = ppr inst + ppr (DerivD _ deriv) = ppr deriv + ppr (ForD _ fd) = ppr fd + ppr (SigD _ sd) = ppr sd + ppr (RuleD _ rd) = ppr rd + ppr (WarningD _ wd) = ppr wd + ppr (AnnD _ ad) = ppr ad + ppr (SpliceD _ dd) = ppr dd + ppr (DocD _ doc) = ppr doc + ppr (RoleAnnotD _ ra) = ppr ra + ppr (XHsDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -279,13 +293,11 @@ instance (SourceTextX pass, OutputableBndrId pass) hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls }) + hs_ruleds = rule_decls }) = vcat_mb empty [ppr_ds fix_decls, ppr_ds default_decls, ppr_ds deprec_decls, ppr_ds ann_decls, ppr_ds rule_decls, - ppr_ds vect_decls, if isEmptyValBinds val_decls then Nothing else Just (ppr val_decls), @@ -303,20 +315,26 @@ instance (SourceTextX pass, OutputableBndrId pass) vcat_mb _ [] = empty vcat_mb gap (Nothing : ds) = vcat_mb gap ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds + ppr (XHsGroup x) = ppr x -- | Located Splice Declaration type LSpliceDecl pass = Located (SpliceDecl pass) -- | Splice Declaration -data SpliceDecl id +data SpliceDecl p = SpliceDecl -- Top level splice - (Located (HsSplice id)) + (XSpliceDecl p) + (Located (HsSplice p)) SpliceExplicitFlag -deriving instance (DataId id) => Data (SpliceDecl id) + | XSpliceDecl (XXSpliceDecl p) + +type instance XSpliceDecl (GhcPass _) = NoExt +type instance XXSpliceDecl (GhcPass _) = NoExt -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (SpliceDecl pass) where - ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (SpliceDecl p) where + ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f + ppr (XSpliceDecl x) = ppr x {- ************************************************************************ @@ -473,7 +491,7 @@ data TyClDecl pass -- 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation - FamDecl { tcdFam :: FamilyDecl pass } + FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } | -- | @type@ declaration -- @@ -481,13 +499,13 @@ data TyClDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these -- include outer binders , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType pass -- ^ RHS of type declaration - , tcdFVs :: PostRn pass NameSet } + , tcdRhs :: LHsType pass } -- ^ RHS of type declaration | -- | @data@ declaration -- @@ -498,33 +516,24 @@ data TyClDecl pass -- 'ApiAnnotation.AnnWhere', -- For details on above see note [Api annotations] in ApiAnnotation - DataDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor - , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an - -- associated type - -- these include outer binders - -- Eg class T a where - -- type F a :: * - -- type F a = a -> a - -- Here the type decl for 'f' - -- includes 'a' in its tcdTyVars - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdDataDefn :: HsDataDefn pass - , tcdDataCusk :: PostRn pass Bool -- ^ does this have a CUSK? - , tcdFVs :: PostRn pass NameSet } - - | ClassDecl { tcdCtxt :: LHsContext pass, -- ^ Context... + DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables + -- See Note [TyVar binders for associated declarations] + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdDataDefn :: HsDataDefn pass } + + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... tcdLName :: Located (IdP pass), -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located (IdP pass)))], - -- ^ Functional deps + tcdFDs :: [LHsFunDep pass], -- ^ Functional deps tcdSigs :: [LSig pass], -- ^ Methods' signatures tcdMeths :: LHsBinds pass, -- ^ Default methods tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn pass], - -- ^ Associated type defaults - tcdDocs :: [LDocDecl], -- ^ Haddock docs - tcdFVs :: PostRn pass NameSet + tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults + tcdDocs :: [LDocDecl] -- ^ Haddock docs } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', @@ -534,9 +543,51 @@ data TyClDecl pass -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation + | XTyClDecl (XXTyClDecl pass) + +type LHsFunDep pass = Located (FunDep (Located (IdP pass))) + +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + , tcdFVs :: NameSet } + deriving Data + +{- Note [TyVar binders for associated decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For an /associated/ data, newtype, or type-family decl, the LHsQTyVars +/includes/ outer binders. For example + class T a where + data D a c + type F a b :: * + type F a b = a -> a +Here the data decl for 'D', and type-family decl for 'F', both include 'a' +in their LHsQTyVars (tcdTyVars and fdTyVars resp). + +Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars. + +The idea is that the associated type is really a top-level decl in its +own right. However we are careful to use the same name 'a', so that +we can match things up. + +c.f. Note [Associated type tyvar names] in Class.hs + Note [Family instance declaration binders] +-} + +type instance XFamDecl (GhcPass _) = NoExt -deriving instance (DataId id) => Data (TyClDecl id) +type instance XSynDecl GhcPs = NoExt +type instance XSynDecl GhcRn = NameSet -- FVs +type instance XSynDecl GhcTc = NameSet -- FVs +type instance XDataDecl GhcPs = NoExt +type instance XDataDecl GhcRn = DataDeclRn +type instance XDataDecl GhcTc = DataDeclRn + +type instance XClassDecl GhcPs = NoExt +type instance XClassDecl GhcRn = NameSet -- FVs +type instance XClassDecl GhcTc = NameSet -- FVs + +type instance XXTyClDecl (GhcPass _) = NoExt -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -564,7 +615,7 @@ isFamilyDecl _other = False -- | type family declaration isTypeFamilyDecl :: TyClDecl pass -> Bool -isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of +isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of OpenTypeFamily -> True ClosedTypeFamily {} -> True _ -> False @@ -582,7 +633,7 @@ isClosedTypeFamilyInfo _ = False -- | data family declaration isDataFamilyDecl :: TyClDecl pass -> Bool -isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True +isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True isDataFamilyDecl _other = False -- Dealing with names @@ -592,8 +643,12 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = - (L _ (TyFamEqn { tfe_tycon = ln })) }) + (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) = ln +tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _))) + = panic "tyFamInstDeclLName" +tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _)) + = panic "tyFamInstDeclLName" tyClDeclLName :: TyClDecl pass -> Located (IdP pass) tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln @@ -622,7 +677,7 @@ countTyClDecls decls isNewTy _ = False -- | Does this declaration have a complete, user-supplied kind signature? --- See Note [Complete user-supplied kind signatures] +-- See Note [CUSKs: complete user-supplied kind signatures] hsDeclHasCusk :: TyClDecl GhcRn -> Bool hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) @@ -630,17 +685,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) = hsTvbAllKinded tyvars && rhs_annotated rhs where rhs_annotated (L _ ty) = case ty of - HsParTy lty -> rhs_annotated lty - HsKindSig {} -> True - _ -> False -hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk + HsParTy _ lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False +hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars +hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyClDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -670,9 +725,10 @@ instance (SourceTextX pass, OutputableBndrId pass) top_matter = text "class" <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) <+> pprFundeps (map unLoc fds) + ppr (XTyClDecl x) = ppr x -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyClGroup pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (TyClGroup p) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -681,62 +737,121 @@ instance (SourceTextX pass, OutputableBndrId pass) = ppr tyclds $$ ppr roles $$ ppr instds + ppr (XTyClGroup x) = ppr x -pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass) - => Located (IdP pass) - -> LHsQTyVars pass +pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) + => Located (IdP (GhcPass p)) + -> LHsQTyVars (GhcPass p) -> LexicalFixity - -> HsContext pass + -> HsContext (GhcPass p) -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) + | fixity == Infix && length varsr > 1 + = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) + , (ppr.unLoc) (head varsr), char ')' + , hsep (map (ppr.unLoc) (tail varsr))] | fixity == Infix = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) , hsep (map (ppr.unLoc) varsr)] | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (ppr.unLoc) (varl:varsr))] - pp_tyvars [] = ppr thing + pp_tyvars [] = pprPrefixOcc (unLoc thing) +pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x -pprTyClDeclFlavour :: TyClDecl a -> SDoc +pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc pprTyClDeclFlavour (ClassDecl {}) = text "class" pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" +pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x}) + = ppr x pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) + = ppr x +pprTyClDeclFlavour (XTyClDecl x) = ppr x -{- Note [Complete user-supplied kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [CUSKs: complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied kind signature (CUSK). This is because we can safely generalise a CUSKed declaration before checking all of the others, supporting polymorphic recursion. See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy and #9200 for lots of discussion of how we got here. -A declaration has a CUSK if we can know its complete kind without doing any -inference, at all. Here are the rules: - - - A class or datatype is said to have a CUSK if and only if all of its type -variables are annotated. Its result kind is, by construction, Constraint or * -respectively. - - - A type synonym has a CUSK if and only if all of its type variables and its -RHS are annotated with kinds. - - - A closed type family is said to have a CUSK if and only if all of its type -variables and its return type are annotated. - - - An open type family always has a CUSK -- unannotated type variables (and -return type) default to *. - - - Additionally, if -XTypeInType is on, then a data definition with a top-level - :: must explicitly bind all kind variables to the right of the ::. - See test dependent/should_compile/KindLevels, which requires this case. - (Naturally, any kind variable mentioned before the :: should not be bound - after it.) +PRINCIPLE: + a type declaration has a CUSK iff we could produce a separate kind signature + for it, just like a type signature for a function, + looking only at the header of the declaration. + +Examples: + * data T1 (a :: *->*) (b :: *) = .... + -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * + + * data T2 a b = ... + -- No CUSK; we do not want to guess T2 :: * -> * -> * + -- becuase the full decl might be data T a b = MkT (a b) + + * data T3 (a :: k -> *) (b :: *) = ... + -- CUSK; equivalent to T3 :: (k -> *) -> * -> * + -- We lexically generalise over k to get + -- T3 :: forall k. (k -> *) -> * -> * + -- The generalisation is here is purely lexical, just like + -- f3 :: a -> a + -- means + -- f3 :: forall a. a -> a + + * data T4 (a :: j k) = ... + -- CUSK; equivalent to T4 :: j k -> * + -- which we lexically generalise to T4 :: forall j k. j k -> * + -- and then, if PolyKinds is on, we further generalise to + -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> * + -- Again this is exactly like what happens as the term level + -- when you write + -- f4 :: forall a b. a b -> Int + +NOTE THAT + * A CUSK does /not/ mean that everything about the kind signature is + fully specified by the user. Look at T4 and f4: we had do do kind + inference to figure out the kind-quantification. But in both cases + (T4 and f4) that inference is done looking /only/ at the header of T4 + (or signature for f4), not at the definition thereof. + + * The CUSK completely fixes the kind of the type constructor, forever. + + * The precise rules, for each declaration form, for whethher a declaration + has a CUSK are given in the user manual section "Complete user-supplied + kind signatures and polymorphic recursion". BUt they simply implement + PRINCIPLE above. + + * Open type families are interesting: + type family T5 a b :: * + There simply /is/ no accompanying declaration, so that info is all + we'll ever get. So we it has a CUSK by definition, and we default + any un-fixed kind variables to *. + + * Associated types are a bit tricker: + class C6 a where + type family T6 a b :: * + op :: a Int -> Int + Here C6 does not have a CUSK (in fact we ultimately discover that + a :: * -> *). And hence neither does T6, the associated family, + because we can't fix its kind until we have settled C6. Another + way to say it: unlike a top-level, we /may/ discover more about + a's kind from C6's definition. + + * A data definition with a top-level :: must explicitly bind all + kind variables to the right of the ::. See test + dependent/should_compile/KindLevels, which requires this + case. (Naturally, any kind variable mentioned before the :: should + not be bound after it.) + + This last point is much more debatable than the others; see + Trac #15142 comment:22 -} @@ -773,13 +888,18 @@ in RnSource for more info. -- | Type or Class Group data TyClGroup pass -- See Note [TyClGroups and dependency analysis] - = TyClGroup { group_tyclds :: [LTyClDecl pass] + = TyClGroup { group_ext :: XCTyClGroup pass + , group_tyclds :: [LTyClDecl pass] , group_roles :: [LRoleAnnotDecl pass] , group_instds :: [LInstDecl pass] } -deriving instance (DataId id) => Data (TyClGroup id) + | XTyClGroup (XXTyClGroup pass) -emptyTyClGroup :: TyClGroup pass -emptyTyClGroup = TyClGroup [] [] [] +type instance XCTyClGroup (GhcPass _) = NoExt +type instance XXTyClGroup (GhcPass _) = NoExt + + +emptyTyClGroup :: TyClGroup (GhcPass p) +emptyTyClGroup = TyClGroup noExt [] [] [] tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] tyClGroupTyClDecls = concatMap group_tyclds @@ -790,9 +910,11 @@ tyClGroupInstDecls = concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] tyClGroupRoleDecls = concatMap group_roles -mkTyClGroup :: [LTyClDecl pass] -> [LInstDecl pass] -> TyClGroup pass +mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)] + -> TyClGroup (GhcPass p) mkTyClGroup decls instds = TyClGroup - { group_tyclds = decls + { group_ext = noExt + , group_tyclds = decls , group_roles = [] , group_instds = instds } @@ -873,39 +995,47 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass) -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig] - NoSig + NoSig (XNoSig pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- For details on above see note [Api annotations] in ApiAnnotation - | KindSig (LHsKind pass) + | KindSig (XCKindSig pass) (LHsKind pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP' -- For details on above see note [Api annotations] in ApiAnnotation - | TyVarSig (LHsTyVarBndr pass) + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' + | XFamilyResultSig (XXFamilyResultSig pass) -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (FamilyResultSig pass) +type instance XNoSig (GhcPass _) = NoExt +type instance XCKindSig (GhcPass _) = NoExt +type instance XTyVarSig (GhcPass _) = NoExt +type instance XXFamilyResultSig (GhcPass _) = NoExt + -- | Located type Family Declaration type LFamilyDecl pass = Located (FamilyDecl pass) -- | type Family Declaration data FamilyDecl pass = FamilyDecl - { fdInfo :: FamilyInfo pass -- type/data, closed/open + { fdExt :: XCFamilyDecl pass + , fdInfo :: FamilyInfo pass -- type/data, closed/open , fdLName :: Located (IdP pass) -- type constructor , fdTyVars :: LHsQTyVars pass -- type variables - , fdFixity :: LexicalFixity -- Fixity used in the declaration + -- See Note [TyVar binders for associated declarations] + , fdFixity :: LexicalFixity -- Fixity used in the declaration , fdResultSig :: LFamilyResultSig pass -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } + | XFamilyDecl (XXFamilyDecl pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', @@ -915,7 +1045,9 @@ data FamilyDecl pass = FamilyDecl -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId id) => Data (FamilyDecl id) +type instance XCFamilyDecl (GhcPass _) = NoExt +type instance XXFamilyDecl (GhcPass _) = NoExt + -- | Located Injectivity Annotation type LInjectivityAnn pass = Located (InjectivityAnn pass) @@ -934,7 +1066,6 @@ data InjectivityAnn pass -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (InjectivityAnn pass) data FamilyInfo pass = DataFamily @@ -942,9 +1073,9 @@ data FamilyInfo pass -- | 'Nothing' if we're in an hs-boot file and the user -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -deriving instance (DataId pass) => Data (FamilyInfo pass) -- | Does this family declaration have a complete, user-supplied kind signature? +-- See Note [CUSKs: complete user-supplied kind signatures] famDeclHasCusk :: Maybe Bool -- ^ if associated, does the enclosing class have a CUSK? -> FamilyDecl pass -> Bool @@ -953,25 +1084,25 @@ famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _ , fdResultSig = L _ resultSig }) = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True - -- all un-associated open families have CUSKs! + -- all un-associated open families have CUSKs -- | Does this family declaration have user-supplied return kind signature? hasReturnKindSignature :: FamilyResultSig a -> Bool -hasReturnKindSignature NoSig = False -hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False -hasReturnKindSignature _ = True +hasReturnKindSignature (NoSig _) = False +hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False +hasReturnKindSignature _ = True -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig a -> Maybe (IdP a) -resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig -resultVariableName _ = Nothing +resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig +resultVariableName _ = Nothing -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (FamilyDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FamilyDecl p) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass) - => TopLevelFlag -> FamilyDecl pass -> SDoc +pprFamilyDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity @@ -987,9 +1118,10 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon NotTopLevel -> empty pp_kind = case result of - NoSig -> empty - KindSig kind -> dcolon <+> ppr kind - TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr + NoSig _ -> empty + KindSig _ kind -> dcolon <+> ppr kind + TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr + XFamilyResultSig x -> ppr x pp_inj = case mb_inj of Just (L _ (InjectivityAnn lhs rhs)) -> hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] @@ -999,8 +1131,9 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon ( text "where" , case mb_eqns of Nothing -> text ".." - Just eqns -> vcat $ map ppr_fam_inst_eqn eqns ) + Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) _ -> (empty, empty) +pprFamilyDecl _ (XFamilyDecl x) = ppr x pprFlavour :: FamilyInfo pass -> SDoc pprFlavour DataFamily = text "data" @@ -1027,7 +1160,8 @@ data HsDataDefn pass -- The payload of a data type defn -- data/newtype T a = <constrs> -- data/newtype instance T [a] = <constrs> -- @ - HsDataDefn { dd_ND :: NewOrData, + HsDataDefn { dd_ext :: XCHsDataDefn pass, + dd_ND :: NewOrData, dd_ctxt :: LHsContext pass, -- ^ Context dd_cType :: Maybe (Located CType), dd_kindSig:: Maybe (LHsKind pass), @@ -1050,7 +1184,10 @@ data HsDataDefn pass -- The payload of a data type defn -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataId id) => Data (HsDataDefn id) + | XHsDataDefn (XXHsDataDefn pass) + +type instance XCHsDataDefn (GhcPass _) = NoExt +type instance XXHsDataDefn (GhcPass _) = NoExt -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1073,7 +1210,8 @@ type LHsDerivingClause pass = Located (HsDerivingClause pass) data HsDerivingClause pass -- See Note [Deriving strategies] in TcDeriv = HsDerivingClause - { deriv_clause_strategy :: Maybe (Located DerivStrategy) + { deriv_clause_ext :: XCHsDerivingClause pass + , deriv_clause_strategy :: Maybe (LDerivStrategy pass) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. , deriv_clause_tys :: Located [LHsSigType pass] @@ -1086,28 +1224,45 @@ data HsDerivingClause pass -- -- should produce a derived instance for @C [a] (T b)@. } -deriving instance (DataId id) => Data (HsDerivingClause id) + | XHsDerivingClause (XXHsDerivingClause pass) + +type instance XCHsDerivingClause (GhcPass _) = NoExt +type instance XXHsDerivingClause (GhcPass _) = NoExt -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsDerivingClause pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsDerivingClause p) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" - , ppDerivStrategy dcs - , pp_dct dct ] + , pp_strat_before + , pp_dct dct + , pp_strat_after ] where -- This complexity is to distinguish between -- deriving Show -- deriving (Show) - pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a) - pp_dct [a] = ppr a - pp_dct _ = parens (interpp'SP dct) + pp_dct [HsIB { hsib_body = ty }] + = ppr (parenthesizeHsType appPrec ty) + pp_dct _ = parens (interpp'SP dct) + + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case dcs of + Just (L _ via@ViaStrategy{}) -> (empty, ppr via) + _ -> (ppDerivStrategy dcs, empty) + ppr (XHsDerivingClause x) = ppr x data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ deriving( Eq, Data ) -- Needed because Demand derives Eq +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour NewType = NewtypeFlavour +newOrDataToFlavour DataType = DataTypeFlavour + -- | Located data Constructor Declaration type LConDecl pass = Located (ConDecl pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when @@ -1142,33 +1297,85 @@ type LConDecl pass = Located (ConDecl pass) -- | data Constructor Declaration data ConDecl pass = ConDeclGADT - { con_names :: [Located (IdP pass)] - , con_type :: LHsSigType pass - -- ^ The type after the ‘::’ + { con_g_ext :: XConDeclGADT pass + , con_names :: [Located (IdP pass)] + + -- The next four fields describe the type after the '::' + -- See Note [GADT abstract syntax] + -- The following field is Located to anchor API Annotations, + -- AnnForall and AnnDot. + , con_forall :: Located Bool -- ^ True <=> explicit forall + -- False => hsq_explicit is empty + , con_qvars :: LHsQTyVars pass + -- Whether or not there is an /explicit/ forall, we still + -- need to capture the implicitly-bound type/kind variables + + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon + , con_res_ty :: LHsType pass -- ^ Result type + , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } | ConDeclH98 - { con_name :: Located (IdP pass) - - , con_qvars :: Maybe (LHsQTyVars pass) - -- User-written forall (if any), and its implicit - -- kind variables - -- Non-Nothing needs -XExistentialQuantification - -- e.g. data T a = forall b. MkT b (b->a) - -- con_qvars = {b} - - , con_cxt :: Maybe (LHsContext pass) - -- ^ User-written context (if any) - - , con_details :: HsConDeclDetails pass - -- ^ Arguments + { con_ext :: XConDeclH98 pass + , con_name :: Located (IdP pass) + + , con_forall :: Located Bool + -- ^ True <=> explicit user-written forall + -- e.g. data T a = forall b. MkT b (b->a) + -- con_ex_tvs = {b} + -- False => con_ex_tvs is empty + , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -deriving instance (DataId pass) => Data (ConDecl pass) + | XConDecl (XXConDecl pass) + +type instance XConDeclGADT (GhcPass _) = NoExt +type instance XConDeclH98 (GhcPass _) = NoExt +type instance XXConDecl (GhcPass _) = NoExt + +{- Note [GADT abstract syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a wrinkle in ConDeclGADT + +* For record syntax, it's all uniform. Given: + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a + we make the a ConDeclGADT for K with + con_qvars = {a} + con_mb_cxt = Just [Ord a] + con_args = RecCon <the record fields> + con_res_ty = T a + + We need the RecCon before the reanmer, so we can find the record field + binders in HsUtils.hsConDeclsBinders. + +* However for a GADT constr declaration which is not a record, it can + be hard parse until we know operator fixities. Consider for example + C :: a :*: b -> a :*: b -> a :+: b + Initially this type will parse as + a :*: (b -> (a :*: (b -> (a :+: b)))) + so it's hard to split up the arguments until we've done the precedence + resolution (in the renamer). + + So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr + type into the res_ty for a ConDeclGADT for now, and use + PrefixCon [] + con_args = PrefixCon [] + con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) + + - In the renamer (RnSource.rnConDecl), we unravel it afer + operator fixities are sorted. So we generate. So we end + up with + con_args = PrefixCon [ a :*: b, a :*: b ] + con_res_ty = a :+: b +-} -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass @@ -1177,37 +1384,23 @@ type HsConDeclDetails pass getConNames :: ConDecl pass -> [Located (IdP pass)] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names +getConNames XConDecl {} = panic "getConNames" --- don't call with RdrNames, because it can't deal with HsAppsTy -getConDetails :: ConDecl pass -> HsConDeclDetails pass -getConDetails ConDeclH98 {con_details = details} = details -getConDetails ConDeclGADT {con_type = ty } = details - where - (details,_,_,_) = gadtDeclDetails ty - --- don't call with RdrNames, because it can't deal with HsAppsTy -gadtDeclDetails :: LHsSigType pass - -> ( HsConDeclDetails pass - , LHsType pass - , LHsContext pass - , [LHsTyVarBndr pass] ) -gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) - where - (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty - (details, res_ty) -- See Note [Sorting out the result type] - = case tau of - L _ (HsFunTy (L l (HsRecTy flds)) res_ty') - -> (RecCon (L l flds), res_ty') - _other -> (PrefixCon [], tau) +getConArgs :: ConDecl pass -> HsConDeclDetails pass +getConArgs d = con_args d hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) - => (HsContext pass -> SDoc) -- Printing the header - -> HsDataDefn pass +hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] +hsConDeclTheta Nothing = [] +hsConDeclTheta (Just (L _ theta)) = theta + +pp_data_defn :: (OutputableBndrId (GhcPass p)) + => (HsContext (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 , dd_cType = mb_ct @@ -1228,48 +1421,57 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) +pp_data_defn _ (XHsDataDefn x) = ppr x -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsDataDefn pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsDataDefn p) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (SourceTextX pass, OutputableBndrId pass) - => [LConDecl pass] -> SDoc +pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ConDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where ppr = pprConDecl -pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc +pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con - , con_qvars = mtvs - , con_cxt = mcxt - , con_details = details + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args , con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details] + = sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con : map (pprHsType . unLoc) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) - tvs = case mtvs of - Nothing -> [] - Just (HsQTvs { hsq_explicit = tvs }) -> tvs + cxt = fromMaybe (noLoc []) mcxt + +pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty, con_doc = doc }) + = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + <+> (sep [pprHsForAll (hsq_explicit qvars) cxt, + ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) + where + get_args (PrefixCon args) = map ppr args + get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] + get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) cxt = fromMaybe (noLoc []) mcxt -pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc }) - = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> ppr res_ty] + ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) + ppr_arrow_chain [] = empty + +pprConDecl (XConDecl x) = ppr x ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) @@ -1283,27 +1485,35 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) Note [Type family instance declarations in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The data type TyFamEqn represents one equation of a type family instance. -It is parameterised over its tfe_pats field: +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 TyFamInstEqn, with *type* in the tfe_pats field. + 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* in the tfe_pats - field. + It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in + the feqn_pats field. + +feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType +(for type family instances). -} ----------------- Type synonym family instances ------------- -- | Located Type Family Instance Equation -type LTyFamInstEqn pass = Located (TyFamInstEqn pass) +type LTyFamInstEqn pass = Located (TyFamInstEqn pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' -- when in a list @@ -1313,16 +1523,14 @@ type LTyFamInstEqn pass = Located (TyFamInstEqn pass) type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass) -- | Haskell Type Patterns -type HsTyPats pass = HsImplicitBndrs pass [LHsType pass] - -- ^ Type patterns (with kind and type bndrs) - -- See Note [Family instance declaration binders] +type HsTyPats pass = [LHsType pass] {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The HsTyPats field is LHS patterns or a type/data family instance. - -The hsib_vars of the HsImplicitBndrs are the template variables of the -type patterns, i.e. fv(pat_tys). Note in particular +For ordinary data/type family instances, the feqn_pats field of FamEqn stores +the LHS type (and kind) patterns. These type patterns can of course contain +type (and kind) variables, which are bound in the hsib_vars field of the +HsImplicitBndrs in FamInstEqn. Note in particular * The hsib_vars *includes* any anonymous wildcards. For example type instance F a _ = a @@ -1330,7 +1538,7 @@ type patterns, i.e. fv(pat_tys). Note in particular '_' gets its own unique. In this context wildcards behave just like an ordinary type variable, only anonymous. -* The hsib_vars *including* type variables that are already in scope +* The hsib_vars *includes* type variables that are already in scope Eg class C s t where type F t p :: * @@ -1344,45 +1552,31 @@ type patterns, i.e. fv(pat_tys). Note in particular type F (a8,b9) x10 = x10->a8 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] -} -- | Type Family Instance Equation -type TyFamInstEqn pass = TyFamEqn pass (HsTyPats pass) +type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) -- | Type Family Default Equation -type TyFamDefltEqn pass = TyFamEqn pass (LHsQTyVars pass) +type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass) -- See Note [Type family instance declarations in HsSyn] --- | Type Family Equation --- --- One equation in a type family instance declaration --- See Note [Type family instance declarations in HsSyn] -data TyFamEqn pass pats - = TyFamEqn - { tfe_tycon :: Located (IdP pass) - , tfe_pats :: pats - , tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , tfe_rhs :: LHsType pass } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - - -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass, Data pats) => Data (TyFamEqn pass pats) - -- | Located Type Family Instance Declaration type LTyFamInstDecl pass = Located (TyFamInstDecl pass) -- | Type Family Instance Declaration -data TyFamInstDecl pass - = TyFamInstDecl - { tfid_eqn :: LTyFamInstEqn pass - , tfid_fvs :: PostRn pass NameSet } +newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnInstance', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (TyFamInstDecl pass) ----------------- Data family instances ------------- @@ -1390,14 +1584,8 @@ deriving instance (DataId pass) => Data (TyFamInstDecl pass) type LDataFamInstDecl pass = Located (DataFamInstDecl pass) -- | Data Family Instance Declaration -data DataFamInstDecl pass - = DataFamInstDecl - { dfid_tycon :: Located (IdP pass) - , dfid_pats :: HsTyPats pass -- LHS - , dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , dfid_defn :: HsDataDefn pass -- RHS - , dfid_fvs :: PostRn pass NameSet } - -- Free vars for dependency analysis +newtype DataFamInstDecl pass + = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', @@ -1406,8 +1594,40 @@ data DataFamInstDecl pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (DataFamInstDecl pass) +----------------- Family instances (common types) ------------- + +-- | Located Family Instance Equation +type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs) + +-- | Family Instance Equation +type FamInstEqn pass rhs + = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) + -- ^ Here, the @pats@ are type patterns (with kind and type bndrs). + -- See Note [Family instance declaration binders] + +-- | Family Equation +-- +-- One equation in a type family instance declaration, data family instance +-- declaration, or type family default. +-- See Note [Type family instance declarations in HsSyn] +-- See Note [Family instance declaration binders] +data FamEqn pass pats rhs + = FamEqn + { feqn_ext :: XCFamEqn pass pats rhs + , feqn_tycon :: Located (IdP pass) + , feqn_pats :: pats + , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , feqn_rhs :: rhs + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + | XFamEqn (XXFamEqn pass pats 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 ----------------- Class instances ------------- @@ -1417,7 +1637,8 @@ type LClsInstDecl pass = Located (ClsInstDecl pass) -- | Class Instance Declaration data ClsInstDecl pass = ClsInstDecl - { cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type + { cid_ext :: XCClsInstDecl pass + , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. , cid_binds :: LHsBinds pass -- Class methods @@ -1436,8 +1657,10 @@ data ClsInstDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId id) => Data (ClsInstDecl id) + | XClsInstDecl (XXClsInstDecl pass) +type instance XCClsInstDecl (GhcPass _) = NoExt +type instance XXClsInstDecl (GhcPass _) = NoExt ----------------- Instances of all kinds ------------- @@ -1447,19 +1670,27 @@ type LInstDecl pass = Located (InstDecl pass) -- | Instance Declaration data InstDecl pass -- Both class and family instances = ClsInstD - { cid_inst :: ClsInstDecl pass } + { cid_d_ext :: XClsInstD pass + , cid_inst :: ClsInstDecl pass } | DataFamInstD -- data family instance - { dfid_inst :: DataFamInstDecl pass } + { dfid_ext :: XDataFamInstD pass + , dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance - { tfid_inst :: TyFamInstDecl pass } -deriving instance (DataId id) => Data (InstDecl id) + { tfid_ext :: XTyFamInstD pass + , tfid_inst :: TyFamInstDecl pass } + | XInstDecl (XXInstDecl pass) + +type instance XClsInstD (GhcPass _) = NoExt +type instance XDataFamInstD (GhcPass _) = NoExt +type instance XTyFamInstD (GhcPass _) = NoExt +type instance XXInstDecl (GhcPass _) = NoExt -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyFamInstDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (TyFamInstDecl p) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) - => TopLevelFlag -> TyFamInstDecl pass -> SDoc +pprTyFamInstDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1467,51 +1698,71 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass) - => LTyFamInstEqn pass -> SDoc -ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon - , tfe_pats = pats - , tfe_fixity = fixity - , tfe_rhs = rhs })) - = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs - -ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass) - => LTyFamDefltEqn pass -> SDoc -ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon - , tfe_pats = tvs - , tfe_fixity = fixity - , tfe_rhs = rhs })) +ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) + => TyFamInstEqn (GhcPass p) -> SDoc +ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }}) + = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs +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 [] <+> equals <+> ppr rhs +ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (DataFamInstDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DataFamInstDecl p) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) - => TopLevelFlag -> DataFamInstDecl pass -> SDoc -pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon - , dfid_pats = pats - , dfid_fixity = fixity - , dfid_defn = defn }) +pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = tycon + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn }}}) = pp_data_defn pp_hdr defn where pp_hdr ctxt = ppr_instance_keyword top_lvl - <+> pp_fam_inst_lhs tycon pats fixity ctxt - -pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc -pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) + <+> pprFamInstLHS tycon 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. +pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x + +pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd - -pp_fam_inst_lhs :: (SourceTextX pass, OutputableBndrId pass) - => Located (IdP pass) - -> HsTyPats pass +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = XHsDataDefn x}}}) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x + +pprFamInstLHS :: (OutputableBndrId (GhcPass p)) + => Located (IdP (GhcPass p)) + -> HsTyPats (GhcPass p) -> LexicalFixity - -> HsContext pass + -> HsContext (GhcPass p) + -> Maybe (LHsKind (GhcPass p)) -> SDoc -pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context +pprFamInstLHS thing typats fixity context mb_kind_sig -- explicit type patterns - = hsep [ pprHsContext context, pp_pats typats] + = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ] where pp_pats (patl:patsr) | fixity == Infix @@ -1519,10 +1770,16 @@ pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context , hsep (map (pprHsType.unLoc) patsr)] | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (pprHsType.unLoc) (patl:patsr))] - pp_pats [] = empty + pp_pats [] = pprPrefixOcc (unLoc thing) + + pp_kind_sig + | Just k <- mb_kind_sig + = dcolon <+> ppr k + | otherwise + = empty -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ClsInstDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ClsInstDecl p) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1539,8 +1796,10 @@ instance (SourceTextX pass, OutputableBndrId pass) where top_matter = text "instance" <+> ppOverlapPragma mbOverlap <+> ppr inst_ty + ppr (XClsInstDecl x) = ppr x -ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc +ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p) + => Maybe (LDerivStrategy p) -> SDoc ppDerivStrategy mb = case mb of Nothing -> empty @@ -1560,11 +1819,11 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (InstDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl + ppr (XInstDecl x) = ppr x -- Extract the declarations of associated data types from an instance @@ -1576,6 +1835,8 @@ instDeclDataFamInsts inst_decls = map unLoc fam_insts do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] + do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts" + do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts" {- ************************************************************************ @@ -1585,13 +1846,25 @@ instDeclDataFamInsts inst_decls ************************************************************************ -} --- | Located Deriving Declaration +-- | Located stand-alone 'deriving instance' declaration type LDerivDecl pass = Located (DerivDecl pass) --- | Deriving Declaration +-- | Stand-alone 'deriving instance' declaration data DerivDecl pass = DerivDecl - { deriv_type :: LHsSigType pass - , deriv_strategy :: Maybe (Located DerivStrategy) + { deriv_ext :: XCDerivDecl pass + , deriv_type :: LHsSigWcType pass + -- ^ The instance type to derive. + -- + -- It uses an 'LHsSigWcType' because the context is allowed to be a + -- single wildcard: + -- + -- > deriving instance _ => Eq (Foo a) + -- + -- Which signifies that the context should be inferred. + + -- See Note [Inferring the instance context] in TcDerivInfer. + + , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', @@ -1600,10 +1873,13 @@ data DerivDecl pass = DerivDecl -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataId pass) => Data (DerivDecl pass) + | XDerivDecl (XXDerivDecl pass) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (DerivDecl pass) where +type instance XCDerivDecl (GhcPass _) = NoExt +type instance XXDerivDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivDecl p) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1612,6 +1888,51 @@ instance (SourceTextX pass, OutputableBndrId pass) , text "instance" , ppOverlapPragma o , ppr ty ] + ppr (XDerivDecl x) = ppr x + +{- +************************************************************************ +* * + Deriving strategies +* * +************************************************************************ +-} + +-- | A 'Located' 'DerivStrategy'. +type LDerivStrategy pass = Located (DerivStrategy pass) + +-- | Which technique the user explicitly requested when deriving an instance. +data DerivStrategy pass + -- See Note [Deriving strategies] in TcDeriv + = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a + -- custom instance for the data type. This only works + -- for certain types that GHC knows about (e.g., 'Eq', + -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, + -- etc.) + | AnyclassStrategy -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy (XViaStrategy pass) + -- ^ @-XDerivingVia@ + +type instance XViaStrategy GhcPs = LHsSigType GhcPs +type instance XViaStrategy GhcRn = LHsSigType GhcRn +type instance XViaStrategy GhcTc = Type + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivStrategy p) where + ppr StockStrategy = text "stock" + ppr AnyclassStrategy = text "anyclass" + ppr NewtypeStrategy = text "newtype" + ppr (ViaStrategy ty) = text "via" <+> ppr ty + +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy = "stock" + go AnyclassStrategy = "anyclass" + go NewtypeStrategy = "newtype" + go (ViaStrategy {}) = "via" {- ************************************************************************ @@ -1630,18 +1951,21 @@ type LDefaultDecl pass = Located (DefaultDecl pass) -- | Default Declaration data DefaultDecl pass - = DefaultDecl [LHsType pass] + = DefaultDecl (XCDefaultDecl pass) [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (DefaultDecl pass) + | XDefaultDecl (XXDefaultDecl pass) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (DefaultDecl pass) where +type instance XCDefaultDecl (GhcPass _) = NoExt +type instance XXDefaultDecl (GhcPass _) = NoExt - ppr (DefaultDecl tys) +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DefaultDecl p) where + ppr (DefaultDecl _ tys) = text "default" <+> parens (interpp'SP tys) + ppr (XDefaultDecl x) = ppr x {- ************************************************************************ @@ -1663,15 +1987,15 @@ type LForeignDecl pass = Located (ForeignDecl pass) -- | Foreign Declaration data ForeignDecl pass = ForeignImport - { fd_name :: Located (IdP pass) -- defines this name + { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- defines this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty , fd_fi :: ForeignImport } | ForeignExport - { fd_name :: Located (IdP pass) -- uses this name + { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty , fd_fe :: ForeignExport } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', @@ -1679,8 +2003,8 @@ data ForeignDecl pass -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation + | XForeignDecl (XXForeignDecl pass) -deriving instance (DataId pass) => Data (ForeignDecl pass) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code @@ -1690,11 +2014,15 @@ deriving instance (DataId pass) => Data (ForeignDecl pass) such as Int and IO that we know how to make foreign calls with. -} -noForeignImportCoercionYet :: PlaceHolder -noForeignImportCoercionYet = PlaceHolder +type instance XForeignImport GhcPs = NoExt +type instance XForeignImport GhcRn = NoExt +type instance XForeignImport GhcTc = Coercion + +type instance XForeignExport GhcPs = NoExt +type instance XForeignExport GhcRn = NoExt +type instance XForeignExport GhcTc = Coercion -noForeignExportCoercionYet :: PlaceHolder -noForeignExportCoercionYet = PlaceHolder +type instance XXForeignDecl (GhcPass _) = NoExt -- Specification Of an imported external entity in dependence on the calling -- convention @@ -1741,14 +2069,15 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ForeignDecl pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ForeignDecl p) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) + ppr (XForeignDecl x) = ppr x instance Outputable ForeignImport where ppr (CImport cconv safety mHeader spec (L _ srcText)) = @@ -1795,9 +2124,13 @@ type LRuleDecls pass = Located (RuleDecls pass) -- Note [Pragma source text] in BasicTypes -- | Rule Declarations -data RuleDecls pass = HsRules { rds_src :: SourceText +data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass + , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } -deriving instance (DataId pass) => Data (RuleDecls pass) + | XRuleDecls (XXRuleDecls pass) + +type instance XCRuleDecls (GhcPass _) = NoExt +type instance XXRuleDecls (GhcPass _) = NoExt -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -1805,15 +2138,14 @@ type LRuleDecl pass = Located (RuleDecl pass) -- | Rule Declaration data RuleDecl pass = HsRule -- Source rule + (XHsRule pass) -- After renamer, free-vars from the LHS and RHS (Located (SourceText,RuleName)) -- Rule name -- Note [Pragma source text] in BasicTypes Activation [LRuleBndr pass] -- Forall'd vars; after typechecking this -- includes tyvars (Located (HsExpr pass)) -- LHS - (PostRn pass NameSet) -- Free-vars from the LHS (Located (HsExpr pass)) -- RHS - (PostRn pass NameSet) -- Free-vars from the RHS -- ^ -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', @@ -1823,7 +2155,16 @@ data RuleDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (RuleDecl pass) + | XRuleDecl (XXRuleDecl pass) + +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data + +type instance XHsRule GhcPs = NoExt +type instance XHsRule GhcRn = HsRuleRn +type instance XHsRule GhcTc = HsRuleRn + +type instance XXRuleDecl (GhcPass _) = NoExt flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -1833,157 +2174,46 @@ type LRuleBndr pass = Located (RuleBndr pass) -- | Rule Binder data RuleBndr pass - = RuleBndr (Located (IdP pass)) - | RuleBndrSig (Located (IdP pass)) (LHsSigWcType pass) + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) + | XRuleBndr (XXRuleBndr pass) -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (RuleBndr pass) + +type instance XCRuleBndr (GhcPass _) = NoExt +type instance XRuleBndrSig (GhcPass _) = NoExt +type instance XXRuleBndr (GhcPass _) = NoExt collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] -collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (RuleDecls pass) where - ppr (HsRules st rules) +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (RuleDecls p) where + ppr (HsRules _ st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + ppr (XRuleDecls x) = ppr x -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (RuleDecl pass) where - ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where + ppr (HsRule _ name act ns lhs rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] where pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot + ppr (XRuleDecl x) = ppr x -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (RuleBndr pass) where - ppr (RuleBndr name) = ppr name - ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) - -{- -************************************************************************ -* * -\subsection{Vectorisation declarations} -* * -************************************************************************ - -A vectorisation pragma, one of - - {-# VECTORISE f = closure1 g (scalar_map g) #-} - {-# VECTORISE SCALAR f #-} - {-# NOVECTORISE f #-} - - {-# VECTORISE type T = ty #-} - {-# VECTORISE SCALAR type T #-} --} - --- | Located Vectorise Declaration -type LVectDecl pass = Located (VectDecl pass) - --- | Vectorise Declaration -data VectDecl pass - = HsVect - SourceText -- Note [Pragma source text] in BasicTypes - (Located (IdP pass)) - (LHsExpr pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsNoVect - SourceText -- Note [Pragma source text] in BasicTypes - (Located (IdP pass)) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectTypeIn -- pre type-checking - SourceText -- Note [Pragma source text] in BasicTypes - Bool -- 'TRUE' => SCALAR declaration - (Located (IdP pass)) - (Maybe (Located (IdP pass))) -- 'Nothing' => no right-hand side - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnEqual' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectTypeOut -- post type-checking - Bool -- 'TRUE' => SCALAR declaration - TyCon - (Maybe TyCon) -- 'Nothing' => no right-hand side - | HsVectClassIn -- pre type-checking - SourceText -- Note [Pragma source text] in BasicTypes - (Located (IdP pass)) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectClassOut -- post type-checking - Class - | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now - (LHsSigType pass) - | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now - ClsInst -deriving instance (DataId pass) => Data (VectDecl pass) - -lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name -lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon -lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectClassOut cls)) = getName cls -lvectDeclName (L _ (HsVectInstIn _)) - = panic "HsDecls.lvectDeclName: HsVectInstIn" -lvectDeclName (L _ (HsVectInstOut _)) - = panic "HsDecls.lvectDeclName: HsVectInstOut" - -lvectInstDecl :: LVectDecl pass -> Bool -lvectInstDecl (L _ (HsVectInstIn _)) = True -lvectInstDecl (L _ (HsVectInstOut _)) = True -lvectInstDecl _ = False - -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (VectDecl pass) where - ppr (HsVect _ v rhs) - = sep [text "{-# VECTORISE" <+> ppr v, - nest 4 $ - pprExpr (unLoc rhs) <+> text "#-}" ] - ppr (HsNoVect _ v) - = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] - ppr (HsVectTypeIn _ False t Nothing) - = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn _ False t (Just t')) - = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeIn _ True t Nothing) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn _ True t (Just t')) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeOut False t Nothing) - = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeOut False t (Just t')) - = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeOut True t Nothing) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeOut True t (Just t')) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectClassIn _ c) - = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectClassOut c) - = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectInstIn ty) - = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ] - ppr (HsVectInstOut i) - = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ] +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where + ppr (RuleBndr _ name) = ppr name + ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) + ppr (XRuleBndr x) = ppr x {- ************************************************************************ @@ -2029,27 +2259,39 @@ type LWarnDecls pass = Located (WarnDecls pass) -- Note [Pragma source text] in BasicTypes -- | Warning pragma Declarations -data WarnDecls pass = Warnings { wd_src :: SourceText +data WarnDecls pass = Warnings { wd_ext :: XWarnings pass + , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } -deriving instance (DataId pass) => Data (WarnDecls pass) + | XWarnDecls (XXWarnDecls pass) + +type instance XWarnings (GhcPass _) = NoExt +type instance XXWarnDecls (GhcPass _) = NoExt -- | Located Warning pragma Declaration type LWarnDecl pass = Located (WarnDecl pass) -- | Warning pragma Declaration -data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt -deriving instance (DataId pass) => Data (WarnDecl pass) +data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt + | XWarnDecl (XXWarnDecl pass) + +type instance XWarning (GhcPass _) = NoExt +type instance XXWarnDecl (GhcPass _) = NoExt -instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where - ppr (Warnings (SourceText src) decls) + +instance (p ~ GhcPass pass,OutputableBndr (IdP p)) + => Outputable (WarnDecls p) where + ppr (Warnings _ (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" - ppr (Warnings NoSourceText _decls) = panic "WarnDecls" + ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" + ppr (XWarnDecls x) = ppr x -instance OutputableBndr (IdP pass) => Outputable (WarnDecl pass) where - ppr (Warning thing txt) +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (WarnDecl p) where + ppr (Warning _ thing txt) = hsep ( punctuate comma (map ppr thing)) <+> ppr txt + ppr (XWarnDecl x) = ppr x {- ************************************************************************ @@ -2064,6 +2306,7 @@ type LAnnDecl pass = Located (AnnDecl pass) -- | Annotation Declaration data AnnDecl pass = HsAnnotation + (XHsAnnotation pass) SourceText -- Note [Pragma source text] in BasicTypes (AnnProvenance (IdP pass)) (Located (HsExpr pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', @@ -2072,12 +2315,15 @@ data AnnDecl pass = HsAnnotation -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (AnnDecl pass) + | XAnnDecl (XXAnnDecl pass) + +type instance XHsAnnotation (GhcPass _) = NoExt +type instance XXAnnDecl (GhcPass _) = NoExt -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (AnnDecl pass) where - ppr (HsAnnotation _ provenance expr) +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where + ppr (HsAnnotation _ _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + ppr (XAnnDecl x) = ppr x -- | Annotation Provenance data AnnProvenance name = ValueAnnProvenance (Located name) @@ -2115,21 +2361,28 @@ type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) -- top-level declarations -- | Role Annotation Declaration data RoleAnnotDecl pass - = RoleAnnotDecl (Located (IdP pass)) -- type constructor + = RoleAnnotDecl (XCRoleAnnotDecl pass) + (Located (IdP pass)) -- type constructor [Located (Maybe Role)] -- optional annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnRole' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (RoleAnnotDecl pass) + | XRoleAnnotDecl (XXRoleAnnotDecl pass) + +type instance XCRoleAnnotDecl (GhcPass _) = NoExt +type instance XXRoleAnnotDecl (GhcPass _) = NoExt -instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where - ppr (RoleAnnotDecl ltycon roles) - = text "type role" <+> ppr ltycon <+> +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (RoleAnnotDecl p) where + ppr (RoleAnnotDecl _ ltycon roles) + = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> hsep (map (pp_role . unLoc) roles) where pp_role Nothing = underscore pp_role (Just r) = ppr r + ppr (XRoleAnnotDecl x) = ppr x roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass) -roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name +roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name +roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName" |