From c84939c8428a9e9ae0753e75ca6b48fcbbc1ecd6 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 8 Apr 2018 16:21:27 +0200 Subject: Match GHC changes for TTG --- haddock-api/src/Haddock/Interface/Specialize.hs | 162 +++++++++++------------- 1 file changed, 75 insertions(+), 87 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Specialize.hs') diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 6d2888d3..18d93fae 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -28,20 +28,18 @@ import Data.Set (Set) import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => [(IdP name, HsType name)] -> a -> a +specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a specialize specs = go where go :: forall x. Data x => x -> x - go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var + go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var strip_kind_sig :: HsType name -> HsType name - strip_kind_sig (HsKindSig (L _ t) _) = t + strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ - specialize_ty_var :: HsType name -> HsType name - specialize_ty_var (HsTyVar _ (L _ name')) + specialize_ty_var :: HsType GhcRn -> HsType GhcRn + specialize_ty_var (HsTyVar _ _ (L _ name')) | Just t <- Map.lookup name' spec_map = t specialize_ty_var typ = typ -- This is a tricky recursive definition that is guaranteed to terminate @@ -54,35 +52,33 @@ specialize specs = go -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => LHsQTyVars name -> [HsType name] +specializeTyVarBndrs :: Data a + => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar (L _ name)) = name - bname (KindedTyVar (L _ name) _) = name + bname (UserTyVar _ (L _ name)) = name + bname (KindedTyVar _ (L _ name) _) = name + bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" -specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name +specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> PseudoFamilyDecl GhcRn + -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> Sig name - -> Sig name +specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> Sig GhcRn + -> Sig GhcRn specializeSig bndrs typs (TypeSig lnames typ) = TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where - true_type :: HsType name + true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) - typ' :: HsType name + typ' :: HsType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig @@ -90,8 +86,7 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => InstHead name -> InstHead name +specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } where @@ -110,27 +105,26 @@ specializeInstHead ihd = ihd -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> HsType name +sugar :: HsType GhcRn -> HsType GhcRn sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing (IdP name) => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp +sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp where name' = getName name strName = occNameString . nameOccName $ name' sugarLists typ = typ -sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name +sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ = aux [] typ where - aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp - aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy _ (L _ typ')) = aux apps typ' + aux apps (HsTyVar _ _ (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -140,10 +134,10 @@ sugarTuples typ = aux _ _ = typ -sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) +sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb where name' = getName name sugarOperators typ = typ @@ -208,15 +202,14 @@ setInternalOccName occ name = -- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> Set Name +freeVariables :: HsType GhcRn -> Set Name freeVariables = everythingWithState Set.empty Set.union query where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy bndrs _) -> + query term ctx = case cast term :: Maybe (HsType GhcRn) of + Just (HsForAllTy _ bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar _ (L _ name)) + Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) @@ -231,8 +224,7 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: (Eq (IdP name), DataId name, SetName (IdP name)) - => Set Name-> HsType name -> HsType name +rename :: Set Name -> HsType GhcRn -> HsType GhcRn rename fv typ = evalState (renameType typ) env where env = RenameEnv @@ -252,63 +244,58 @@ data RenameEnv name = RenameEnv } -renameType :: (Eq (IdP name), SetName (IdP name)) - => HsType name -> Rename (IdP name) (HsType name) -renameType (HsForAllTy bndrs lt) = - HsForAllTy +renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) +renameType (HsForAllTy x bndrs lt) = + HsForAllTy x <$> mapM (located renameBinder) bndrs <*> renameLType lt -renameType (HsQualTy lctxt lt) = - HsQualTy +renameType (HsQualTy x lctxt lt) = + HsQualTy x <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name -renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la -renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr -renameType (HsListTy lt) = HsListTy <$> renameLType lt -renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt -renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt -renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt -renameType (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb -renameType (HsParTy lt) = HsParTy <$> renameLType lt -renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt -renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb -renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la +renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +renameType (HsListTy x lt) = HsListTy x <$> renameLType lt +renameType (HsPArrTy x lt) = HsPArrTy x <$> renameLType lt +renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt +renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt +renameType (HsOpTy x la lop lb) = + HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb +renameType (HsParTy x lt) = HsParTy x <$> renameLType lt +renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt +renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb +renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc -renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt -renameType t@(HsRecTy _) = pure t -renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ip ph ltys) = - HsExplicitListTy ip ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t +renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc +renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt +renameType t@(HsRecTy _ _) = pure t +renameType t@(XHsType (NHsCoreTy _)) = pure t +renameType (HsExplicitListTy x ip ltys) = + HsExplicitListTy x ip <$> renameLTypes ltys +renameType (HsExplicitTupleTy x ltys) = + HsExplicitTupleTy x <$> renameLTypes ltys +renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) -renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" +renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming" -renameLType :: (Eq (IdP name), SetName (IdP name)) - => LHsType name -> Rename (IdP name) (LHsType name) +renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType -renameLTypes :: (Eq (IdP name), SetName (IdP name)) - => [LHsType name] -> Rename (IdP name) [LHsType name] +renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType -renameContext :: (Eq (IdP name), SetName (IdP name)) - => HsContext name -> Rename (IdP name) (HsContext name) +renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: (Eq (IdP name), SetName (IdP name)) - => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) -renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname -renameBinder (KindedTyVar lname lkind) = - KindedTyVar <$> located renameName lname <*> located renameType lkind - +renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) +renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname +renameBinder (KindedTyVar x lname lkind) = + KindedTyVar x <$> located renameName lname <*> located renameType lkind +renameBinder (XTyVarBndr _) = error "haddock:renameBinder" -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -363,5 +350,6 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar name) = unLoc name -tyVarName (KindedTyVar (L _ name) _) = name +tyVarName (UserTyVar _ name) = unLoc name +tyVarName (KindedTyVar _ (L _ name) _) = name +tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" -- cgit v1.2.3 From a8ca2ae8737d29145fe57a7709e59be8cb7a00dc Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 2 Apr 2018 23:37:50 +0200 Subject: Match GHC for TTG implemented on HsBinds, D4581 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 24 ++++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 20 +++++----- haddock-api/src/Haddock/Convert.hs | 10 ++--- haddock-api/src/Haddock/GhcUtils.hs | 44 +++++++++++----------- haddock-api/src/Haddock/Interface/Create.hs | 16 ++++---- haddock-api/src/Haddock/Interface/Rename.hs | 20 +++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 4 +- haddock-api/src/Haddock/Types.hs | 7 ++++ haddock-api/src/Haddock/Utils.hs | 10 ++--- 11 files changed, 86 insertions(+), 79 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Specialize.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9e0b5102..09f62a19 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -138,7 +138,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs +ppSigWithDoc dflags (TypeSig _ names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) @@ -262,7 +262,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3d7575eb..19d638d9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -114,7 +114,7 @@ binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) _ -> empty pat term = case cast term of @@ -150,7 +150,7 @@ decls (group, _, _, _) = concatMap ($ group) GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -169,7 +169,7 @@ decls (group, _, _, _) = concatMap ($ group) Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field Nothing -> empty - sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1229a8d3..4535979e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -216,7 +216,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -257,8 +257,8 @@ declNames :: LHsDecl DocNameI ) declNames (L _ decl) = case decl of TyClD d -> (empty, [tcdName d]) - SigD (TypeSig lnames _ ) -> (empty, map unLoc lnames) - SigD (PatSynSig lnames _) -> (text "pattern", map unLoc lnames) + SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -300,13 +300,13 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- TyClD d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD (TypeSig lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode - SigD (PatSynSig lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ -> empty + DerivD _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False @@ -548,7 +548,7 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig lnames typ) <- lsigs + | L _ (TypeSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode - | (SigD (PatSynSig lnames typ), d) <- pats + | (SigD (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a4f2a4a5..5f253cbd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,9 +58,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigType lty) fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml @@ -513,7 +513,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t [ ppFunSig summary links loc doc names (hsSigWcType typ) [] splice unicode qual - | L _ (TypeSig lnames typ) <- sigs + | L _ (TypeSig _ lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -561,7 +561,7 @@ ppClassDecl summary links instances fixities loc d subdocs methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) subfixs splice unicode qual - | L _ (ClassOpSig _ lnames typ) <- lsigs + | L _ (ClassOpSig _ _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -570,15 +570,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. - minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of + minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] + sort [getName n | TypeSig _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -679,7 +679,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames typ <- sigs + TypeSig _ lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ -- Instance methods signatures are synified and thus don't have a useful @@ -746,7 +746,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig lnames typ),_) <- pats + | (SigD (PatSynSig _ lnames typ),_) <- pats ] @@ -793,7 +793,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats patternBit = subPatterns qual [ ppSideBySidePat subfixs unicode qual lnames typ d - | (SigD (PatSynSig lnames typ), d) <- pats + | (SigD (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fac448a2..fd9f0089 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -85,7 +85,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -102,11 +102,11 @@ tyThingToLHsDecl t = case t of ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -331,10 +331,10 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) +synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) +synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 48a9f99e..14111a6a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -74,30 +74,30 @@ getInstLoc (TyFamInstD (TyFamInstDecl -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name) -filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p (FixSig (FixitySig ns ty)) = +filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p)) +filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig (FixitySig filtered ty)) -filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty) = + filtered -> Just (FixSig noExt (FixitySig noExt filtered ty)) +filterSigNames _ orig@(MinimalSig _ _ _) = Just orig +filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) -filterSigNames p (ClassOpSig is_default ns ty) = + filtered -> Just (TypeSig noExt filtered ty) +filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig is_default filtered ty) -filterSigNames p (PatSynSig ns ty) = + filtered -> Just (ClassOpSig noExt is_default filtered ty) +filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig filtered ty) -filterSigNames _ _ = Nothing + filtered -> Just (PatSynSig noExt filtered ty) +filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just @@ -107,13 +107,13 @@ sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig ns _) = map unLoc ns -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] -- | Was this signature given by the user? isUserLSig :: LSig name -> Bool @@ -258,7 +258,7 @@ instance Parent (TyClDecl GhcRn) where $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 88b8bc67..c119f3c3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -481,9 +481,9 @@ conArgDocs con = case getConArgs con of -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD (TypeSig _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD (ClassOpSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD (PatSynSig _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) declTypeDocs _ = M.empty @@ -519,7 +519,7 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig ns f) <- hs_fixds group_, + | L _ (FixitySig _ ns f) <- hs_fixds group_, L _ n <- ns ] @@ -729,7 +729,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ @@ -1022,7 +1022,7 @@ extractDecl declMap name decl matchesMethod = [ lsig | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig + , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig ] @@ -1097,7 +1097,7 @@ extractPatternSyn nm t tvs cons = ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) _ -> typ typ'' = noLoc (HsQualTy noExt (noLoc []) typ') - in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs @@ -1113,7 +1113,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) + L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index c8d9cb7d..0652ae47 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -480,24 +480,24 @@ renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of - TypeSig lnames ltype -> do + TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig lnames' ltype') - ClassOpSig is_default lnames sig_ty -> do + return (TypeSig noExt lnames' ltype') + ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig is_default lnames' ltype') - PatSynSig lnames sig_ty -> do + return (ClassOpSig noExt is_default lnames' ltype') + PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig lnames' sig_ty' - FixSig (FixitySig lnames fixity) -> do + return $ PatSynSig noExt lnames' sig_ty' + FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames - return $ FixSig (FixitySig lnames' fixity) - MinimalSig src (L l s) -> do + return $ FixSig noExt (FixitySig noExt lnames' fixity) + MinimalSig _ src (L l s) -> do s' <- traverse renameL s - return $ MinimalSig src (L l s') + return $ MinimalSig noExt src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 18d93fae..b84a676f 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -73,8 +73,8 @@ specializePseudoFamilyDecl bndrs typs decl = specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn -specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) +specializeSig bndrs typs (TypeSig _ lnames typ) = + TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b4b16d62..2234894c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -696,3 +696,10 @@ type instance XXTyVarBndr DocNameI = PlaceHolder type instance XFieldOcc DocNameI = DocName type instance XXFieldOcc DocNameI = PlaceHolder + +type instance XFixitySig DocNameI = PlaceHolder +type instance XFixSig DocNameI = PlaceHolder +type instance XPatSynSig DocNameI = PlaceHolder +type instance XClassOpSig DocNameI = PlaceHolder +type instance XTypeSig DocNameI = PlaceHolder +type instance XMinimalSig DocNameI = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 5de539c0..1ebf7ffa 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -131,18 +131,18 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) - = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_xforall = PlaceHolder + = L loc (HsForAllTy { hst_xforall = noExt , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) -- cgit v1.2.3 From 271a9cb0c7a070deef8df2d4fb54ebe47a0bf560 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 19 Apr 2018 14:04:04 +0200 Subject: Match changes in GHC for TTG --- haddock-api/src/Haddock/Backends/Hoogle.hs | 21 +-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 18 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 43 +++--- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 49 ++++--- haddock-api/src/Haddock/Convert.hs | 77 +++++----- haddock-api/src/Haddock/GhcUtils.hs | 44 +++--- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 118 ++++++++-------- haddock-api/src/Haddock/Interface/Rename.hs | 155 ++++++++++++--------- haddock-api/src/Haddock/Interface/Specialize.hs | 6 +- haddock-api/src/Haddock/Types.hs | 124 ++++++++++------- haddock-api/src/Haddock/Utils.hs | 26 ++-- 13 files changed, 386 insertions(+), 299 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Specialize.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 09f62a19..2c7be079 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -126,12 +126,12 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (SigD sig) = ppSig dflags sig ++ ppFixities + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (SigD _ sig) = ppSig dflags sig ++ ppFixities f _ = [] ppFixities = concatMap (ppFixity dflags) fixities @@ -189,7 +189,7 @@ ppClass dflags decl subdocs = , tcdTyVars = feqn_pats tfe , tcdFixity = feqn_fixity tfe , tcdRhs = feqn_rhs tfe - , tcdFVs = emptyNameSet + , tcdSExt = emptyNameSet } @@ -241,8 +241,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy PlaceHolder x y) - apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y) + funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -250,7 +250,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $ + resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@(ConDeclGADT { }) @@ -260,6 +260,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con +ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 19d638d9..56137f51 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified Outputable as GHC import Control.Applicative import Control.Monad (guard) @@ -146,9 +147,10 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ _ -> pure . decl $ name - GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.SynDecl _ name _ _ _ -> pure . decl $ name + GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs + GHC.XTyClDecl {} -> GHC.panic "haddock:decls" fun term = case cast term of (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) @@ -159,10 +161,10 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of @@ -183,10 +185,10 @@ imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith t _ vs _fls)) -> + (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingWith _ t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4535979e..1b2515fa 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -216,7 +216,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -256,11 +256,11 @@ declNames :: LHsDecl DocNameI , [DocName] -- ^ names being declared ) declNames (L _ decl) = case decl of - TyClD d -> (empty, [tcdName d]) - SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) - SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) - ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) - ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) + TyClD _ d -> (empty, [tcdName d]) + SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) + ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) + ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -293,20 +293,20 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD d@FamDecl {} -> ppTyFam False doc d unicode - TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode - TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode + TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@TySynonym{} +-- TyClD _ d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode - SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD _ d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ _ -> empty + DerivD _ _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False @@ -318,7 +318,7 @@ ppTyFam _ _ _ _ = ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX -ppFor doc (ForeignImport (L _ name) typ _ _) unicode = +ppFor doc (ForeignImport _ (L _ name) typ _) unicode = ppFunSig doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode - | (SigD (PatSynSig _ lnames typ), d) <- pats + | (SigD _ (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" @@ -726,6 +726,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -759,6 +760,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ] + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -- don't use "con_doc con", in case it's reconstructed from a .hi file, @@ -771,13 +773,14 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst +ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" -- | Pretty-print a bundled pattern synonym diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 00937245..464c166b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -663,7 +663,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5f253cbd..8ac3d91b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,6 +39,7 @@ import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) +import Outputable ( panic ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -54,18 +55,18 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigType lty) fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual - InstD _ -> noHtml - DerivD _ -> noHtml - _ -> error "declaration not supported by ppDecl" + ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ _ -> noHtml + DerivD _ _ -> noHtml + _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> @@ -225,7 +226,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities +ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode qual = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -318,12 +319,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ClosedTypeFamily _ -> keyword "where ..." _ -> mempty ) +ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + NoSig _ -> noHtml + KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + XFamilyResultSig _ -> panic "haddock:ppResultSig" ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html @@ -367,6 +370,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) + ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" + ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" @@ -399,6 +404,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) +ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html @@ -740,13 +746,14 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig _ lnames typ),_) <- pats + | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -772,6 +779,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -793,7 +801,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats patternBit = subPatterns qual [ ppSideBySidePat subfixs unicode qual lnames typ d - | (SigD (PatSynSig _ lnames typ), d) <- pats + | (SigD _ (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] @@ -854,6 +862,7 @@ ppShortConstrParts summary dataInst con unicode qual , noHtml , noHtml ) + XConDecl {} -> panic "haddock:ppShortConstrParts" where occ = map (nameOccName . getName . unLoc) $ getConNames con @@ -923,6 +932,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -951,6 +961,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. @@ -980,7 +991,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) | L _ name <- names , let field = (unLoc . rdrNameFieldOcc) name @@ -994,12 +1005,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst +ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html -ppShortField summary unicode qual (ConDeclField names ltype _) +ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" -- | Pretty print an expanded pattern (for bundled patterns) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fd9f0089..b4804758 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -62,14 +62,14 @@ tyThingToLHsDecl t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl d) = return $ noLoc d + extractFamilyDecl (FamDecl _ d) = return $ noLoc d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" @@ -77,7 +77,7 @@ tyThingToLHsDecl t = case t of atFamDecls = map extractFamilyDecl (rights atTyClDecls) tyClErrors = lefts atTyClDecls famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl + in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) @@ -93,20 +93,20 @@ tyThingToLHsDecl t = case t of , tcdATs = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNamesTc } + , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD + -> synifyTyCon Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -119,9 +119,10 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType rhs - in HsIB { hsib_vars = map tyVarName tkvs - , hsib_closed = True - , hsib_body = FamEqn { feqn_tycon = name + in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs + , hsib_closed = True } + , hsib_body = FamEqn { feqn_ext = noExt + , feqn_tycon = name , feqn_pats = annot_typats , feqn_fixity = Prefix , feqn_rhs = hs_rhs } } @@ -132,13 +133,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD - $ TyFamInstD + = return $ InstD noExt + $ TyFamInstD noExt $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD + = synifyTyCon (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" @@ -153,14 +154,17 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_implicit = [] -- No kind polymorphism + in HsQTvs { hsq_ext = + HsQTvsRn { hsq_implicit = [] -- No kind polymorphism + , hsq_dependent = emptyNameSet } , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * - , hsq_dependent = emptyNameSet } + } , tcdFixity = Prefix - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + , tcdDataDefn = HsDataDefn { dd_ext = noExt + , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing @@ -168,8 +172,7 @@ synifyTyCon _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } - , tcdDataCusk = False - , tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } synifyTyCon _coax tc | Just flav <- famTyConFlav_maybe tc @@ -190,8 +193,9 @@ synifyTyCon _coax tc -> mkFamDecl DataFamily where resultVar = famTcResVar tc - mkFamDecl i = return $ FamDecl $ - FamilyDecl { fdInfo = i + mkFamDecl i = return $ FamDecl noExt $ + FamilyDecl { fdExt = noExt + , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = Prefix @@ -204,11 +208,11 @@ synifyTyCon _coax tc synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc - = return $ SynDecl { tcdLName = synifyName tc + = return $ SynDecl { tcdSExt = emptyNameSet + , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNamesTc } + , tcdRhs = synifyType WithinType ty } | otherwise = -- (closed) newtype and data let @@ -241,7 +245,8 @@ synifyTyCon coax tc cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = noLoc [] - defn = HsDataDefn { dd_ND = alg_nd + defn = HsDataDefn { dd_ext = noExt + , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig @@ -251,7 +256,7 @@ synifyTyCon coax tc [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity @@ -264,9 +269,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) = synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = - noLoc $ KindSig (synifyKindSig kind) + noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -297,7 +302,7 @@ synifyDataCon use_gadt_syntax dc = field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $ - ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy + ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -311,7 +316,8 @@ synifyDataCon use_gadt_syntax dc = \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_names = [name] + ConDeclGADT { con_g_ext = noExt + , con_names = [name] , con_forall = True , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) , con_mb_cxt = Just ctx @@ -319,7 +325,8 @@ synifyDataCon use_gadt_syntax dc = , con_res_ty = synifyType WithinType res_ty , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_name = name + ConDeclH98 { con_ext = noExt + , con_name = name , con_forall = True , con_ex_tvs = map synifyTyVar ex_tvs , con_mb_cxt = Just ctx @@ -341,9 +348,9 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn -synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs - , hsq_dependent = emptyNameSet } +synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] + , hsq_dependent = emptyNameSet } + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv @@ -546,7 +553,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls pure $ mkPseudoFamilyDecl fam } } diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 14111a6a..2d254414 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -47,28 +47,36 @@ isConSym = isLexConSym . occNameFS getMainDeclBinder :: HsDecl name -> [IdP name] -getMainDeclBinder (TyClD d) = [tcdName d] -getMainDeclBinder (ValD d) = +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl +getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) +getInstLoc (DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l -getInstLoc (TyFamInstD (TyFamInstDecl +getInstLoc (TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l +getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (XInstDecl _) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" + + -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. @@ -124,16 +132,16 @@ isUserLSig _ = False isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d +isClassD (TyClD _ d) = isClassDecl d isClassD _ = False isValD :: HsDecl a -> Bool -isValD (ValD _) = True +isValD (ValD _ _) = True isValD _ = False declATs :: HsDecl a -> [IdP a] -declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d +declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -165,13 +173,13 @@ getGADTConType (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -184,6 +192,7 @@ getGADTConType (ConDeclGADT { con_forall = has_forall getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT +getGADTConType (XConDecl {}) = panic "getGADTConType" -- ------------------------------------- @@ -196,13 +205,13 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -213,8 +222,9 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall mkFunTy a b = noLoc (HsFunTy noExt a b) -getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType" +getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT +getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG" ------------------------------------------------------------------------------- -- * Located @@ -286,7 +296,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration parents :: Name -> HsDecl GhcRn -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 4fd9d264..286907e5 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -87,7 +87,7 @@ attachToExportItem -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c119f3c3..bc93449f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,7 +125,7 @@ createInterface tm flags modMap instIfaceMap = do $ map getName instances ++ map getName fam_instances -- Locations of all TH splices - splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) @@ -406,9 +406,9 @@ mkMaps dflags gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] names :: SrcSpan -> HsDecl GhcRn -> [Name] - names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of - TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs + TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -433,16 +433,16 @@ subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of - InstD (ClsInstD d) -> do + InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) -> dataSubs (feqn_rhs d) - TyClD d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd @@ -456,7 +456,7 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConArgs cons - , L _ (ConDeclField ns _ doc) <- (unLoc flds) + , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) | HsIB { hsib_body = L l (HsDocTy _ _ doc) } @@ -481,11 +481,11 @@ conArgDocs con = case getConArgs con of -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) +declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) declTypeDocs _ = M.empty -- | Extract function argument docs from inside types. @@ -505,10 +505,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ + docs = mkDecls tcdDocs (DocD noExt) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ + sigs = mkDecls tcdSigs (SigD noExt) class_ + ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ -- | The top-level declarations of a module that we care about, @@ -526,14 +526,14 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ + mkDecls hs_derivds (DerivD noExt) group_ ++ + mkDecls hs_defds (DefD noExt) group_ ++ + mkDecls hs_fords (ForD noExt) group_ ++ + mkDecls hs_docs (DocD noExt) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExt) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" @@ -564,14 +564,14 @@ sortByLoc = sortBy (comparing getLoc) filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where - isHandled (ForD (ForeignImport {})) = True + isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True - isHandled (SigD d) = isUserLSig (reL d) - isHandled (ValD _) = True + isHandled (SigD _ d) = isUserLSig (reL d) + isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs - isHandled (DocD _) = True + isHandled (DocD {}) = True isHandled _ = False @@ -580,8 +580,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where - filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } + filterClass (TyClD x c) = + TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -600,10 +600,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD (DocCommentNext str)) : ds) + go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -644,22 +644,22 @@ mkExportItems decls maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do + lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre docStr return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr, _) = liftErrMsg $ do + lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEDocNamed str, _) = liftErrMsg $ + lookupExport (IEDocNamed _ str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEModuleContents (L _ mod_name), _) + lookupExport (IEModuleContents _ (L _ mod_name), _) -- only consider exporting a module if we are sure we -- are really exporting the whole module and not some -- subset. We also look through module aliases here. @@ -696,7 +696,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let t = availName avail r <- findDecl avail case r of - ([L l (ValD _)], (doc, _)) -> do + ([L l (ValD _ _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] @@ -721,17 +721,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. - L loc (SigD sig) -> + L loc (SigD _ sig) -> -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. - let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig + let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD cl@ClassDecl{}) -> do + L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -994,7 +994,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames for (getMainDeclBinder (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail - | L _ (ValD valDecl) <- decl + | L _ (ValD _ valDecl) <- decl , (name:_) <- collectHsBindBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> pure [] @@ -1017,7 +1017,7 @@ extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of - TyClD d@ClassDecl {} -> + TyClD _ d@ClassDecl {} -> let matchesMethod = [ lsig @@ -1037,8 +1037,8 @@ extractDecl declMap name decl in case (matchesMethod, matchesAssociatedType) of ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) - (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + in L pos (SigD noExt sig) + (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap @@ -1047,21 +1047,21 @@ extractDecl declMap name decl O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) - TyClD d@DataDecl {} -> + TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) - else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) - TyClD FamDecl {} + then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_pats = tys , feqn_rhs = defn }}))) -> - SigD <$> extractRecSel name n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> + SigD noExt <$> extractRecSel name n tys (dd_cons defn) + InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) @@ -1071,7 +1071,7 @@ extractDecl declMap name decl , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" @@ -1112,12 +1112,12 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of - RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] - matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds , L l n <- ns, extFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty @@ -1142,8 +1142,8 @@ mkVisibleNames (_, _, _, instMap) exports opts where subs = map fst (expItemSubDocs e) patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of - InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap - decl -> getMainDeclBinder decl + InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1184,7 +1184,7 @@ findNamedDoc name = search search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search (DocD (DocCommentNamed name' doc) : rest) + search (DocD _ (DocCommentNamed name' doc) : rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0652ae47..5b588964 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -21,6 +21,7 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name +import Outputable ( panic ) import Control.Applicative import Control.Monad hiding (mapM) @@ -188,14 +189,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) -renameFamilyResultSig (L loc NoSig) - = return (L loc NoSig) -renameFamilyResultSig (L loc (KindSig ki)) +renameFamilyResultSig (L loc (NoSig _)) + = return (L loc (NoSig noExt)) +renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig ki')) } -renameFamilyResultSig (L loc (TyVarSig bndr)) + ; return (L loc (KindSig noExt ki')) } +renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig bndr')) } + ; return (L loc (TyVarSig noExt bndr')) } +renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig" renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -212,55 +214,55 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy PlaceHolder a' b') + return (HsAppTy NoExt a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy PlaceHolder a' b') + return (HsFunTy NoExt a' b') - HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty - HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty) - HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty + HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) + HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2) - HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy PlaceHolder a' (L loc op') b') + return (HsOpTy NoExt a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig PlaceHolder ty' k') + return (HsKindSig NoExt ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy PlaceHolder ty' doc') + return (HsDocTy NoExt ty' doc') - HsTyLit _ x -> return (HsTyLit PlaceHolder x) + HsTyLit _ x -> return (HsTyLit NoExt x) - HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b @@ -269,10 +271,11 @@ renameType t = case t of HsAppsTy _ _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) -renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) +renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } - -- This is rather bogus, but I'm not sure what else to do + ; return (HsQTvs { hsq_ext = noExt + , hsq_explicit = tvs' }) } +renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars" renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar x (L l n))) @@ -289,8 +292,8 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) -renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo +renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do @@ -321,21 +324,21 @@ renamePats = mapM renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of - TyClD d -> do + TyClD _ d -> do d' <- renameTyClD d - return (TyClD d') - SigD s -> do + return (TyClD noExt d') + SigD _ s -> do s' <- renameSig s - return (SigD s') - ForD d -> do + return (SigD noExt s') + ForD _ d -> do d' <- renameForD d - return (ForD d') - InstD d -> do + return (ForD noExt d') + InstD _ d -> do d' <- renameInstD d - return (InstD d') - DerivD d -> do + return (InstD noExt d') + DerivD _ d -> do d' <- renameDerivD d - return (DerivD d') + return (DerivD noExt d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) @@ -346,19 +349,21 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFam = decl' }) + return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames }) + return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdRhs = rhs' }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -373,7 +378,8 @@ renameTyClD d = case d of return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt }) + XTyClDecl _ -> panic "haddock:renameTyClD" where renameLFunDep (L loc (xs, ys)) = do @@ -394,11 +400,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) +renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl" renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -424,9 +431,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + return (HsDataDefn { dd_ext = noExt + , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) +renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn" renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -437,7 +446,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_ex_tvs = ltyvars' + return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_args = details', con_doc = mbldoc' }) @@ -451,9 +460,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars' + return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) +renameCon (XConDecl _) = panic "haddock:renameCon" renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do @@ -466,11 +476,12 @@ renameDetails (InfixCon a b) = do return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) -renameConDeclFieldField (L l (ConDeclField names t doc)) = do +renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField names' t' doc') + return $ L l (ConDeclField noExt names' t' doc') +renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField" renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -503,35 +514,39 @@ renameSig sig = case sig of renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) -renameForD (ForeignImport lname ltype co x) = do +renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignImport lname' ltype' co x) -renameForD (ForeignExport lname ltype co x) = do + return (ForeignImport noExt lname' ltype' x) +renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignExport lname' ltype' co x) + return (ForeignExport noExt lname' ltype' x) +renameForD (XForeignDecl _) = panic "haddock:renameForD" renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_inst = d' }) + return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' }) +renameInstD (XInstDecl _) = panic "haddock:renameInstD" renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do ty' <- renameLSigWcType ty - return (DerivDecl { deriv_type = ty' + return (DerivDecl { deriv_ext = noExt + , deriv_type = ty' , deriv_strategy = strat , deriv_overlap_mode = omode }) +renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -540,10 +555,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) +renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD" renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -563,10 +579,12 @@ renameTyFamInstEqn eqn = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } + rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn" renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs @@ -574,10 +592,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs - ; return (L loc (FamEqn { feqn_tycon = tc' + ; return (L loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } +renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn" renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) @@ -592,10 +612,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; defn' <- renameDataDefn defn - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } + rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD" renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -603,8 +625,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder }) } + , hsib_ext = noExt }) } +renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit" renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -612,7 +634,8 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder }) } + , hswc_ext = noExt }) } +renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc" renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index b84a676f..c49663db 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -110,7 +110,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp + | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp where name' = getName name strName = occNameString . nameOccName $ name' @@ -124,7 +124,7 @@ sugarTuples typ = aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -137,7 +137,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 2234894c..99fccf2a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -381,11 +381,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl } where mkType (KindedTyVar _ (L loc name) lkind) = - HsKindSig PlaceHolder tvar lkind + HsKindSig NoExt tvar lkind where - tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name + tvar = L loc (HsTyVar NoExt NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" +mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl" -- | An instance head that may have documentation and a source location. @@ -652,54 +653,77 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocNameI NameSet = PlaceHolder -type instance PostRn DocNameI Fixity = PlaceHolder -type instance PostRn DocNameI Bool = PlaceHolder -type instance PostRn DocNameI Name = DocName -type instance PostRn DocNameI (Located Name) = Located DocName -type instance PostRn DocNameI [Name] = PlaceHolder -type instance PostRn DocNameI DocName = DocName - -type instance PostTc DocNameI Kind = PlaceHolder -type instance PostTc DocNameI Type = PlaceHolder -type instance PostTc DocNameI Coercion = PlaceHolder - - -type instance XForAllTy DocNameI = PlaceHolder -type instance XQualTy DocNameI = PlaceHolder -type instance XTyVar DocNameI = PlaceHolder -type instance XAppsTy DocNameI = PlaceHolder -type instance XAppTy DocNameI = PlaceHolder -type instance XFunTy DocNameI = PlaceHolder -type instance XListTy DocNameI = PlaceHolder -type instance XPArrTy DocNameI = PlaceHolder -type instance XTupleTy DocNameI = PlaceHolder -type instance XSumTy DocNameI = PlaceHolder -type instance XOpTy DocNameI = PlaceHolder -type instance XParTy DocNameI = PlaceHolder -type instance XIParamTy DocNameI = PlaceHolder -type instance XEqTy DocNameI = PlaceHolder -type instance XKindSig DocNameI = PlaceHolder -type instance XSpliceTy DocNameI = PlaceHolder -type instance XDocTy DocNameI = PlaceHolder -type instance XBangTy DocNameI = PlaceHolder -type instance XRecTy DocNameI = PlaceHolder -type instance XExplicitListTy DocNameI = PlaceHolder -type instance XExplicitTupleTy DocNameI = PlaceHolder -type instance XTyLit DocNameI = PlaceHolder -type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI +type instance XForAllTy DocNameI = NoExt +type instance XQualTy DocNameI = NoExt +type instance XTyVar DocNameI = NoExt +type instance XAppsTy DocNameI = NoExt +type instance XAppTy DocNameI = NoExt +type instance XFunTy DocNameI = NoExt +type instance XListTy DocNameI = NoExt +type instance XPArrTy DocNameI = NoExt +type instance XTupleTy DocNameI = NoExt +type instance XSumTy DocNameI = NoExt +type instance XOpTy DocNameI = NoExt +type instance XParTy DocNameI = NoExt +type instance XIParamTy DocNameI = NoExt +type instance XEqTy DocNameI = NoExt +type instance XKindSig DocNameI = NoExt +type instance XSpliceTy DocNameI = NoExt +type instance XDocTy DocNameI = NoExt +type instance XBangTy DocNameI = NoExt +type instance XRecTy DocNameI = NoExt +type instance XExplicitListTy DocNameI = NoExt +type instance XExplicitTupleTy DocNameI = NoExt +type instance XTyLit DocNameI = NoExt +type instance XWildCardTy DocNameI = HsWildCardInfo type instance XXType DocNameI = NewHsTypeX -type instance XUserTyVar DocNameI = PlaceHolder -type instance XKindedTyVar DocNameI = PlaceHolder -type instance XXTyVarBndr DocNameI = PlaceHolder +type instance XUserTyVar DocNameI = NoExt +type instance XKindedTyVar DocNameI = NoExt +type instance XXTyVarBndr DocNameI = NoExt type instance XFieldOcc DocNameI = DocName -type instance XXFieldOcc DocNameI = PlaceHolder - -type instance XFixitySig DocNameI = PlaceHolder -type instance XFixSig DocNameI = PlaceHolder -type instance XPatSynSig DocNameI = PlaceHolder -type instance XClassOpSig DocNameI = PlaceHolder -type instance XTypeSig DocNameI = PlaceHolder -type instance XMinimalSig DocNameI = PlaceHolder +type instance XXFieldOcc DocNameI = NoExt + +type instance XFixitySig DocNameI = NoExt +type instance XFixSig DocNameI = NoExt +type instance XPatSynSig DocNameI = NoExt +type instance XClassOpSig DocNameI = NoExt +type instance XTypeSig DocNameI = NoExt +type instance XMinimalSig DocNameI = NoExt + +type instance XForeignExport DocNameI = NoExt +type instance XForeignImport DocNameI = NoExt +type instance XConDeclGADT DocNameI = NoExt +type instance XConDeclH98 DocNameI = NoExt + +type instance XDerivD DocNameI = NoExt +type instance XInstD DocNameI = NoExt +type instance XForD DocNameI = NoExt +type instance XSigD DocNameI = NoExt +type instance XTyClD DocNameI = NoExt + +type instance XNoSig DocNameI = NoExt +type instance XCKindSig DocNameI = NoExt +type instance XTyVarSig DocNameI = NoExt + +type instance XCFamEqn DocNameI _ _ = NoExt + +type instance XCClsInstDecl DocNameI = NoExt +type instance XCDerivDecl DocNameI = NoExt +type instance XDataFamInstD DocNameI = NoExt +type instance XTyFamInstD DocNameI = NoExt +type instance XClsInstD DocNameI = NoExt +type instance XCHsDataDefn DocNameI = NoExt +type instance XCFamilyDecl DocNameI = NoExt +type instance XClassDecl DocNameI = NoExt +type instance XDataDecl DocNameI = NoExt +type instance XSynDecl DocNameI = NoExt +type instance XFamDecl DocNameI = NoExt + +type instance XHsIB DocNameI _ = NoExt +type instance XHsWC DocNameI _ = NoExt + +type instance XHsQTvs DocNameI = NoExt +type instance XConDeclField DocNameI = NoExt + diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1ebf7ffa..e3cc9655 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -64,6 +64,7 @@ import GHC import Name import NameSet ( emptyNameSet ) import HsTypes (extFieldOcc) +import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -152,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -162,10 +163,10 @@ lHsQTyVarsToTypes tvs restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl @@ -178,6 +179,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -195,9 +197,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] InfixCon _ _ -> Just d where field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField fs _ _)) + field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ t _ <- flds ] + field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail" + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing @@ -208,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsQTyVars Name +emptyHsQTvs :: LHsQTyVars GhcRn -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] - , hsq_dependent = error "haddock:emptyHsQTvs" } +emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_dependent = error "haddock:emptyHsQTvs" } + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3