diff options
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 19 | ||||
| -rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 56 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 8 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 78 | ||||
| -rw-r--r-- | src/Haddock/Convert.hs | 77 | ||||
| -rw-r--r-- | src/Haddock/GhcUtils.hs | 7 | ||||
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 12 | ||||
| -rw-r--r-- | src/Haddock/Interface/Rename.hs | 80 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 20 |
9 files changed, 152 insertions, 205 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 593f03bc..c0569006 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -111,9 +111,10 @@ operator x = x ppExport :: ExportItem Name -> [String] ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) where - f (TyClD d@TyData{}) = ppData d subdocs + f (TyClD d@TyDecl{}) + | isDataDecl d = ppData d subdocs + | otherwise = ppSynonym d f (TyClD d@ClassDecl{}) = ppClass d - f (TyClD d@TySynonym{}) = ppSynonym d f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ f (SigD sig) = ppSig sig @@ -131,10 +132,6 @@ ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] ppSig _ = [] -ppSynonym :: TyClDecl Name -> [String] -ppSynonym x = [out x] - - -- note: does not yet output documentation for class methods ppClass :: TyClDecl Name -> [String] ppClass x = out x{tcdSigs=[]} : @@ -154,10 +151,15 @@ ppInstance :: ClsInst -> [String] ppInstance x = [dropComment $ out x] +ppSynonym :: TyClDecl Name -> [String] +ppSynonym x = [out x] + ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : - concatMap (ppCtor x subdocs . unL) (tcdCons x) +ppData decl@(TyDecl { tcdTyDefn = defn }) subdocs + = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} : + concatMap (ppCtor decl subdocs . unL) (td_cons defn) where + -- GHC gives out "data Bar =", we want to delete the equals -- also writes data : a b, when we want data (:) a b showData d = unwords $ map f $ if last xs == "=" then init xs else xs @@ -165,6 +167,7 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : xs = words $ out d nam = out $ tcdLName d f w = if w == nam then operator nam else w +ppData _ _ = panic "ppData" -- | for constructors, and named-fields... lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index deb224a8..c3a8faa0 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -278,12 +278,14 @@ ppDecl :: LHsDecl DocName ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode - TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode - | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d - TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode - | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode + TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl instances subdocs loc mbDoc d unicode + | otherwise -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode +-- | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d +-- Family instances happen via FamInst now +-- TyClD d@(TySynonym {}) +-- | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode +-- Family instances happen via FamInst now TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode @@ -299,17 +301,6 @@ ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppDataInst :: a -ppDataInst = - error "data instance declarations are currently not supported by --latex" - - -ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> LaTeX -ppTyInst _ _ _ _ _ = - error "type instance declarations are currently not supported by --latex" - - ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX ppFor _ _ _ _ = error "foreign declarations are currently not supported by --latex" @@ -323,7 +314,8 @@ ppFor _ _ _ _ = -- we skip type patterns for now ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX -ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype _) unicode +ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) @@ -559,7 +551,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode $$ instancesBit where - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons body = catMaybes [constrBit, fmap docToLaTeX mbDoc] @@ -705,27 +697,15 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX -ppDataHeader decl unicode - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> +ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars + , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext (tcdCtxt decl) unicode <+> + ppLContext ctxt unicode <+> -- T a b c ..., or a :+: b - ppTyClBinderWithVars False decl - - --------------------------------------------------------------------------------- --- * TyClDecl helpers --------------------------------------------------------------------------------- - - --- | Print a type family / newtype / data / class binder and its variables -ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX -ppTyClBinderWithVars summ decl = - ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) - + ppAppDocNameNames False name (tyvarNames tyvars) +ppDataHeader _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Type applications diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 52bde5b6..50aad789 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -562,12 +562,8 @@ processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of (TyFamily{}) -> [ppTyFamHeader True False d unicode qual] - (TyData{tcdTyPats = ps}) - | Nothing <- ps -> [keyword "data" <+> b] - | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b] - (TySynonym{tcdTyPats = ps}) - | Nothing <- ps -> [keyword "type" <+> b] - | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b] + (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b] + (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] _ -> [] SigD (TypeSig lnames (L _ _)) -> diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 28955c22..ee0223c2 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -29,7 +29,6 @@ import Haddock.Types import Control.Monad ( join ) import Data.List ( intersperse ) import qualified Data.Map as Map -import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -43,12 +42,9 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual - TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual - | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d - TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual - | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual + TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual + | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual @@ -121,7 +117,9 @@ ppFor _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype _) unicode qual +ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdTyDefn = TySynonym { td_synRhs = ltype } }) + unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual where @@ -187,50 +185,6 @@ ppTyFam summary associated links loc mbDoc decl unicode qual -------------------------------------------------------------------------------- --- * Indexed data types --------------------------------------------------------------------------------- - - -ppDataInst :: a -ppDataInst = undefined - - --------------------------------------------------------------------------------- --- * Indexed newtypes --------------------------------------------------------------------------------- - --- TODO --- ppNewTyInst = undefined - - --------------------------------------------------------------------------------- --- * Indexed types --------------------------------------------------------------------------------- - - -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInst summary associated links loc mbDoc decl unicode qual - - | summary = ppTyInstHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc - - where - docname = tcdName decl - - header_ = topDeclElem links loc [docname] - (ppTyInstHeader summary associated decl unicode qual) - - -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInstHeader _ _ decl unicode qual = - keyword "type instance" <+> - ppAppNameTypes (tcdName decl) typeArgs unicode qual - where - typeArgs = map unLoc . fromJust . tcdTyPats $ decl - - --------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -240,7 +194,6 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> B ppAssocType summ links doc (L loc decl) unicode qual = case decl of TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual - TySynonym {} -> ppTySyn summ links loc doc decl unicode qual _ -> error "declaration type not supported by ppAssocType" @@ -353,6 +306,8 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) lo [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + -- ToDo: add associated type defaults + [ ppFunSig summary links loc doc names typ unicode qual | L _ (TypeSig lnames (L _ typ)) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -385,6 +340,7 @@ ppClassDecl summary links instances loc mbDoc subdocs hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + -- ToDo: add assocatied typ defaults atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] @@ -448,7 +404,7 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons @@ -463,7 +419,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual where docname = unLoc . tcdLName $ dataDecl - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual @@ -618,15 +574,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataHeader summary decl unicode qual - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> +ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) + unicode qual + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext (tcdCtxt decl) unicode qual <+> + ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 3dad9a2c..0470a5f5 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -69,61 +69,57 @@ tyThingToLHsDecl t = noLoc $ case t of -- 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 -> TyClD (synifyAxiom ax) + ACoAxiom ax -> InstD (FamInstD (synifyAxiom ax)) -- a data-constructor alone just gets rendered as a function: ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) -synifyATDefault :: TyCon -> LTyClDecl Name +synifyATDefault :: TyCon -> LFamInstDecl Name synifyATDefault tc = noLoc (synifyAxiom ax) where Just ax = tyConFamilyCoercion_maybe tc -synifyAxiom :: CoAxiom -> TyClDecl Name +synifyAxiom :: CoAxiom -> FamInstDecl Name synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) | Just (tc, args) <- tcSplitTyConApp_maybe lhs = let name = synifyName tc - tyvars = synifyTyVars tvs typats = map (synifyType WithinType) args hs_rhs_ty = synifyType WithinType rhs - in TySynonym name tyvars (Just typats) hs_rhs_ty placeHolderNames + in FamInstDecl { fid_tycon = name + , fid_pats = HsBSig typats (map tyVarName tvs) + , fid_defn = TySynonym hs_rhs_ty } | otherwise = error "synifyAxiom" synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc - | isFunTyCon tc || isPrimTyCon tc = - TyData - -- arbitrary lie, they are neither algebraic data nor newtype: - DataType - -- no built-in type has any stupidTheta: - (noLoc []) - (synifyName tc) - Nothing - -- tyConTyVars doesn't work on fun/prim, but we can make them up: - (zipWith - (\fakeTyVar realKind -> noLoc $ - KindedTyVar (getName fakeTyVar) - (synifyKindSig realKind)) - alphaTyVars --a, b, c... which are unfortunately all kind * - (fst . splitKindFunTys $ tyConKind tc) - ) - -- assume primitive types aren't members of data/newtype families: - Nothing - -- we have their kind accurately: - (Just (synifyKindSig (tyConKind tc))) - -- no algebraic constructors: - [] - -- "deriving" needn't be specified: - Nothing - | isSynFamilyTyCon tc = - case synTyConRhs tc of + | isFunTyCon tc || isPrimTyCon tc + = TyDecl { tcdLName = synifyName tc + , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: + zipWith + (\fakeTyVar realKind -> noLoc $ + KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind)) + alphaTyVars --a, b, c... which are unfortunately all kind * + (fst . splitKindFunTys $ tyConKind tc) + , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither + -- algebraic data nor newtype: + , td_ctxt = noLoc [] + , td_cType = Nothing + , td_kindSig = Just (synifyKindSig (tyConKind tc)) + -- we have their kind accurately: + , td_cons = [] -- No constructors + , td_derivs = Nothing } + , tcdFVs = placeHolderNames } + | isSynFamilyTyCon tc + = case synTyConRhs tc of SynFamilyTyCon -> TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) (Just (synifyKindSig (synTyConResKind tc))) _ -> error "synifyTyCon: impossible open type synonym?" - | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of + | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?) + case algTyConRhs tc of DataFamilyTyCon -> TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing --always kind '*' @@ -139,9 +135,6 @@ synifyTyCon tc alg_ctx = synifyCtx (tyConStupidTheta tc) name = synifyName tc tyvars = synifyTyVars (tyConTyVars tc) - typats = case tyConFamInst_maybe tc of - Nothing -> Nothing - Just (_, indexes) -> Just (map (synifyType WithinType) indexes) alg_kindSig = Just (tyConKind tc) -- The data constructors. -- @@ -164,10 +157,14 @@ synifyTyCon tc -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing syn_type = synifyType WithinType (synTyConType tc) - in if isSynTyCon tc - then TySynonym name tyvars typats syn_type placeHolderNames - else TyData alg_nd alg_ctx name Nothing tyvars typats (fmap synifyKindSig alg_kindSig) alg_cons alg_deriv - + defn | isSynTyCon tc = TySynonym syn_type + | otherwise = TyData { td_ND = alg_nd, td_ctxt = alg_ctx + , td_cType = Nothing + , td_kindSig = fmap synifyKindSig alg_kindSig + , td_cons = alg_cons + , td_derivs = alg_deriv } + in TyDecl { tcdLName = name, tcdTyVars = tyvars, tcdTyDefn = defn + , tcdFVs = placeHolderNames } -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index fc04351b..c38bf9e5 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -78,7 +78,7 @@ isVarSym = isLexVarSym . occNameFS getMainDeclBinder :: HsDecl name -> [name] -getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d] +getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> [] @@ -138,7 +138,6 @@ isDocD _ = False isInstD :: HsDecl a -> Bool isInstD (InstD _) = True -isInstD (TyClD d) = isFamInstDecl d isInstD _ = False @@ -216,7 +215,7 @@ instance Parent (ConDecl Name) where instance Parent (TyClDecl Name) where children d - | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d + | isDataDecl d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d | isClassDecl d = map (tcdName . unL) (tcdATs d) ++ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] @@ -232,7 +231,7 @@ family = getName &&& children -- child to its grand-children, recursively. families :: TyClDecl Name -> [(Name, [Name])] families d - | isDataDecl d = family d : map (family . unL) (tcdCons d) + | isDataDecl d = family d : map (family . unL) (td_cons (tcdTyDefn d)) | isClassDecl d = family d : concatMap (families . unL) (tcdATs d) | otherwise = [] diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 00f1319c..5029dce8 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -188,7 +188,7 @@ mkMaps dflags gre instances exports decls = do let subNames = map fst subDocs let names = case d of - InstD (ClsInstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. + InstD (ClsInstD (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. _ -> filter (`elem` exports) (getMainDeclBinder d) let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs)) @@ -217,7 +217,7 @@ subordinates (TyClD decl) ] dataSubs = constrs ++ fields where - cons = map unL $ tcdCons decl + cons = map unL $ (td_cons (tcdTyDefn decl)) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) @@ -233,7 +233,7 @@ typeDocs d = case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty) + TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) @@ -295,7 +295,7 @@ warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () warnAboutFilteredDecls mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ tcdName d | L _ (InstD (FamInstDecl d)) <- decls ] + nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD d)) <- decls ] unless (null typeInstances) $ tell [ @@ -304,7 +304,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (ClsInstDecl i _ _ ats)) <- decls + let instances = nub [ pretty i | L _ (InstD (ClsInstD i _ _ ats)) <- decls , not (null ats) ] unless (null instances) $ @@ -644,7 +644,7 @@ extractDecl name mdl decl _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) + L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 6034688e..7417d234 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -325,22 +325,11 @@ renameTyClD d = case d of -- return (TyFamily flav lname' ltyvars' kind' tckind) return (TyFamily flav lname' ltyvars' tckind') - TyData x lcontext lname cType ltyvars typats k cons _ -> do - lcontext' <- renameLContext lcontext + TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - typats' <- mapM (mapM renameLType) typats - k' <- renameMaybeLKind k - cons' <- mapM renameLCon cons - -- I don't think we need the derivings, so we return Nothing - return (TyData x lcontext' lname' cType ltyvars' typats' k' cons' Nothing) - - TySynonym lname ltyvars typats ltype fvs -> do - lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - ltype' <- renameLType ltype - typats' <- mapM (mapM renameLType) typats - return (TySynonym lname' ltyvars' typats' ltype' fvs) + tyvars' <- mapM renameLTyVarBndr tyvars + defn' <- renameTyDefn defn + return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs }) ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do lcontext' <- renameLContext lcontext @@ -349,15 +338,36 @@ renameTyClD d = case d of lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats - at_defs' <- mapM renameLTyClD at_defs + at_defs' <- mapM (mapM renameFamInstD) at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' []) where - renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName) +renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType + , td_kindSig = k, td_cons = cons }) = do + lcontext' <- renameLContext lcontext + k' <- renameMaybeLKind k + cons' <- mapM (mapM renameCon) cons + -- I don't think we need the derivings, so we return Nothing + return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType + , td_kindSig = k', td_cons = cons', td_derivs = Nothing }) + +renameTyDefn (TySynonym { td_synRhs = ltype }) = do + ltype' <- renameLType ltype + return (TySynonym { td_synRhs = ltype' }) + +renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- renameLContext lcontext @@ -366,7 +376,7 @@ renameTyClD d = case d of mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' }) - + where renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do @@ -383,14 +393,6 @@ renameTyClD d = case d of renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - - renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do @@ -413,14 +415,22 @@ renameForD (ForeignExport lname ltype co x) = do renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (ClsInstDecl ltype _ _ lATs) = do +renameInstD (ClsInstD ltype _ _ lATs) = do ltype' <- renameLType ltype - lATs' <- mapM renameLTyClD lATs - return (ClsInstDecl ltype' emptyBag [] lATs') + lATs' <- mapM (mapM renameFamInstD) lATs + return (ClsInstD ltype' emptyBag [] lATs') + +renameInstD (FamInstD d) = do + d' <- renameFamInstD d + return (FamInstD d') + +renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName) +renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = HsBSig pats fvs, fid_defn = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; defn' <- renameTyDefn defn + ; return (FamInstDecl { fid_tycon = tc', fid_pats = HsBSig pats' fvs, fid_defn = defn' }) } -renameInstD (FamInstDecl d) = do - d' <- renameTyClD d - return (FamInstDecl d') renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index de97ef85..3814b97e 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -125,18 +125,24 @@ toInstalledDescription = hmi_description . instInfo restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d && tcdND d == DataType -> - TyClD (d { tcdCons = restrictCons names (tcdCons d) }) - TyClD d | isDataDecl d && tcdND d == NewType -> - case restrictCons names (tcdCons d) of - [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) - [con] -> TyClD (d { tcdCons = [con] }) - _ -> error "Should not happen" + TyClD d | isDataDecl d -> + TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn d) }) TyClD d | isClassDecl d -> TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl +restrictTyDefn :: [Name] -> HsTyDefn Name -> HsTyDefn Name +restrictTyDefn _ defn@(TySynonym {}) + = defn +restrictTyDefn names defn@(TyData { td_ND = new_or_data, td_cons = cons }) + | DataType <- new_or_data + = defn { td_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { td_ND = DataType, td_cons = [] } + [con] -> defn { td_cons = [con] } + _ -> error "Should not happen" restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] |