diff options
-rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Backends/Html.hs | 125 | ||||
-rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 11 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 114 | ||||
-rw-r--r-- | src/Haddock/Interface/Rename.hs | 17 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 3 | ||||
-rw-r--r-- | tests/tests/TypeFamilies.hs | 28 |
7 files changed, 217 insertions, 83 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index cd5e9161..ccf92d8c 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -80,7 +80,7 @@ typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds) -- How to print each export ppExport :: ExportItem Name -> [String] -ppExport (ExportDecl name decl dc _) = doc dc ++ f (unL decl) +ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl) where f (TyClD d@TyData{}) = ppData d f (TyClD d@ClassDecl{}) = ppClass d diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index 5940f8bb..50db3cc3 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -1,4 +1,4 @@ --- + -- Haddock - A Haskell Documentation Tool -- -- (c) Simon Marlow 2003 @@ -549,7 +549,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface exports = numberSectionHeadings (ifaceRnExportItems iface) - has_doc (ExportDecl _ _ doc _) = isJust doc + has_doc (ExportDecl _ doc _) = isJust doc has_doc (ExportNoDecl _ _ _) = False has_doc (ExportModule _) = False has_doc _ = True @@ -626,8 +626,8 @@ numberSectionHeadings exports = go 1 exports processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable processExport _ _ _ (ExportGroup lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary links docMap (ExportDecl x decl doc insts) - = doDecl summary links x decl doc insts docMap +processExport summary links docMap (ExportDecl decl doc insts) + = ppDecl summary links decl doc insts docMap processExport summmary _ _ (ExportNoDecl _ y []) = declBox (ppDocName y) processExport summmary _ _ (ExportNoDecl _ y subs) @@ -655,20 +655,21 @@ declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm ht declWithDoc False links loc nm (Just doc) html_decl = topDeclBox links loc nm html_decl </> docBox (docToHtml doc) -doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable -doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d - where - doDecl (TyClD d) = doTyClD d - doDecl (SigD (TypeSig (L _ n) (L _ t))) = - ppFunSig summary links loc mbDoc (docNameOrig n) t - doDecl (ForD d) = ppFor summary links loc mbDoc d - - doTyClD d0@(TyFamily {}) = ppTyFam summary False links loc mbDoc d0 - doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0 - doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0 - doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0 +ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> + Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable +ppDecl summ links (L loc decl) mbDoc instances docMap = case decl of + TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d + TyClD d@(TyData {}) + | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d + | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d + TyClD d@(TySynonym {}) + | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d + | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap d + SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc (docNameOrig n) t + ForD d -> ppFor summ links loc mbDoc d + InstD d -> Html.emptyTable ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Name -> HsType DocName -> HtmlTable @@ -786,36 +787,84 @@ ppTyFam summary associated links loc mbDoc decl | associated, isJust mbDoc = header </> bodyBox << doc | associated = header - | null instances, isNothing mbDoc = header - | otherwise = header </> bodyBox << (doc </> instancesBit) + | null instances, isJust mbDoc = header </> bodyBox << doc + | null instances = header + | isJust mbDoc = header </> bodyBox << (doc </> instancesBit) + | otherwise = header </> bodyBox << instancesBit where name = docNameOrig . tcdName $ decl header = topDeclBox links loc name (ppTyFamHeader summary associated decl) - doc = case mbDoc of - Just d -> ndocBox (docToHtml d) - Nothing -> Html.emptyTable + doc = ndocBox . docToHtml . fromJust $ mbDoc instId = collapseId name - instancesBit - | null instances = Html.emptyTable - | otherwise - = instHdr instId </> - tda [theclass "body"] << - collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead) instances) + instancesBit = instHdr instId </> + tda [theclass "body"] << + collapsed thediv instId ( + spacedTable1 << ( + aboves (map (declBox . ppInstHead) instances) + ) ) - ) -- TODO: get the instances instances = [] -------------------------------------------------------------------------------- +-- Indexed data types +-------------------------------------------------------------------------------- + + +ppDataInst = undefined + + +-------------------------------------------------------------------------------- +-- Indexed newtypes +-------------------------------------------------------------------------------- + + +ppNewTyInst = undefined + + +-------------------------------------------------------------------------------- +-- Indexed types +-------------------------------------------------------------------------------- + + +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> + TyClDecl DocName -> HtmlTable +ppTyInst summary associated links loc mbDoc decl + + | summary = declWithDoc summary links loc name mbDoc + (ppTyInstHeader True associated decl) + + | isJust mbDoc = header </> bodyBox << doc + | otherwise = header + + where + name = docNameOrig . tcdName $ decl + + header = topDeclBox links loc name (ppTyInstHeader summary associated decl) + + doc = case mbDoc of + Just d -> ndocBox (docToHtml d) + Nothing -> Html.emptyTable + + +ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Html +ppTyInstHeader summary associated decl = + + keyword "type instance" <+> + + ppAppNameTypes (tcdName decl) typeArgs + where + typeArgs = map unLoc . fromJust . tcdTyPats $ decl + + +-------------------------------------------------------------------------------- -- Associated Types -------------------------------------------------------------------------------- @@ -942,10 +991,10 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc -ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan -> - Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> - HtmlTable -ppClassDecl summary links instances orig_c loc mbDoc docMap +ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan -> + Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> + HtmlTable +ppClassDecl summary links instances loc mbDoc docMap decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) | summary = ppShortClassDecl summary links decl loc docMap | otherwise = classheader </> bodyBox << (classdoc </> body </> instancesBit) @@ -954,7 +1003,7 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap | null lsigs = topDeclBox links loc nm hdr | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") - nm = docNameOrig . unLoc $ lname + nm = docNameOrig . unLoc $ tcdLName decl ctxt = unLoc lctxt hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds @@ -1036,9 +1085,9 @@ ppShortDataDecl summary links loc mbDoc dataDecl cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons -ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> +ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable -ppDataDecl summary links instances x loc mbDoc dataDecl +ppDataDecl summary links instances loc mbDoc dataDecl | summary = declWithDoc summary links loc name mbDoc (ppShortDataDecl summary links loc mbDoc dataDecl) diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index aed832bb..38fef6b4 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -43,11 +43,12 @@ attachInstances modules filterNames = map attach modules where newItems = map attachExport (ifaceExportItems mod) - attachExport (ExportDecl n decl doc _) = - ExportDecl n decl doc (case Map.lookup n instMap of - Nothing -> [] - Just instheads -> instheads) - attachExport otherExport = otherExport + attachExport (ExportDecl decl@(L _ (TyClD d)) doc _) + | isClassDecl d || isDataDecl d || isFamilyDecl d = + ExportDecl decl doc (case Map.lookup (tcdName d) instMap of + Nothing -> [] + Just instheads -> instheads) + attachExport export = export -------------------------------------------------------------------------------- diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 24def155..7320af21 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -20,6 +20,7 @@ import Data.Maybe import Data.Char import Data.Ord import Control.Monad +import Control.Arrow import GHC import Outputable @@ -55,16 +56,18 @@ createInterface ghcMod flags modMap = do subMap = mkSubMap group decls = topDecls group declMap = mkDeclMap decls + famMap = Map.empty --mkFamMap decls ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod origEnv = Map.fromList [ (nameOccName n, n) | n <- exportedNames ] + instances = ghcInstances ghcMod visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope ghcMod) subMap exports opts declMap - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) - decls declMap subMap opts exports ignoreExps + exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod)decls declMap + famMap subMap opts exports ignoreExps instances -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. @@ -121,27 +124,51 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- --- Extract declarations +-- Declarations -------------------------------------------------------------------------------- +type DeclWithDoc = (LHsDecl Name, Maybe (HsDoc Name)) + + +-- | A list of type or data instance declarations with an optional family +-- declaration. +type Family = (Maybe DeclWithDoc, [DeclWithDoc]) + -- | Make a map from names to declarations with documentation. The map excludes -- all kinds of instance declarations (including type family instances) and -- documentation declarations. -- Subordinate names are mapped to the parent declaration, but with the doc -- for the subordinate declaration. +mkDeclMap :: [DeclWithDoc] -> Map Name DeclWithDoc mkDeclMap decls = Map.fromList [ (n, (L loc d, doc)) | (L loc d, doc) <- decls , (n, doc) <- (declName d, doc) : subordinates d - , notDocOrInstance d ] + , not (isDoc d), not (isInstance d) ] + + +-- | Group type family instances together. Include the family declaration +-- if found. +{-mkFamMap :: [DeclWithDoc] -> Map Name Family +mkFamMap decls = + Map.fromList [ (tcdName $ ex $ head $ g, family g) | g <- groups ] + where + family g = first listToMaybe $ partition (isFamilyDecl . ex) g + groups = groupBy (comparing (tcdName . ex)) $ + filter (isTyClD . unLoc . fst) decls + ex ((L _ (TyClD d)), _) = d +-} + +isTyClD (TyClD _) = True +isTyClD _ = False + + +isDoc (DocD _) = True +isDoc _ = False -notDocOrInstance (InstD _) = False -notDocOrInstance (TyClD (d@TyData {})) - | Just _ <- tcdTyPats d = False -notDocOrInstance (TyClD (d@TySynonym {})) - | Just _ <- tcdTyPats d = False -notDocOrInstance (DocD _) = False -notDocOrInstance _ = True +isInstance (InstD _) = True +isInstance (TyClD d) = isFamInstDecl d +isInstance _ = False subordinates (TyClD d) = classDataSubs d @@ -184,9 +211,11 @@ declName (SigD sig) = fromJust $ sigNameNoLoc sig -- All the top-level declarations of a module, ordered by source location, --- with documentation attached if it exists -topDecls :: HsGroup Name -> [(LHsDecl Name, Maybe (HsDoc Name))] -topDecls = collectDocs . sortByLoc . declsFromGroup +-- with documentation attached if it exists. +-- TEMP hack to filter out all instances (we don't want them until +-- rendering is completely implemented). +topDecls :: HsGroup Name -> [DeclWithDoc] +topDecls = filter (\(L _ d, _) -> not (isInstance d)) . collectDocs . sortByLoc . declsFromGroup -- | Pick out the declarations that we want from a group @@ -195,12 +224,13 @@ declsFromGroup group = decls hs_tyclds TyClD group ++ decls hs_fords ForD group ++ decls hs_docs DocD group ++ + decls hs_instds InstD group ++ decls (sigs . hs_valds) SigD group where sigs (ValBindsOut _ x) = x --- | Takes a field of declarations from a data structure and creates HsDecls +-- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor decls field con struct = [ L loc (con decl) | L loc decl <- field struct ] @@ -210,6 +240,19 @@ sortByLoc = sortBy (comparing getLoc) -------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +{- +matchingInsts :: Name -> [Instances] -> [Instances] +matchingInsts name instances = filter ((==) name . is_cls) instances + + +instToData :: Instance -> LHsDecl Name +instToData inst = TyData { +-} + +-------------------------------------------------------------------------------- -- Collect docs -- -- To be able to attach the right Haddock comment to the right declaration, @@ -219,11 +262,11 @@ sortByLoc = sortBy (comparing getLoc) -- | Collect the docs and attach them to the right declaration -collectDocs :: [LHsDecl Name] -> [(LHsDecl Name, Maybe (HsDoc Name))] +collectDocs :: [LHsDecl Name] -> [DeclWithDoc] collectDocs decls = collect Nothing DocEmpty decls -collect :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [(LHsDecl Name, Maybe (HsDoc Name))] +collect :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [DeclWithDoc] collect d doc_so_far [] = case d of Nothing -> [] @@ -245,8 +288,7 @@ collect d doc_so_far (e:es) = | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es) -finishedDoc :: LHsDecl Name -> HsDoc Name -> [(LHsDecl Name, Maybe (HsDoc Name))] -> - [(LHsDecl Name, Maybe (HsDoc Name))] +finishedDoc :: LHsDecl Name -> HsDoc Name -> [DeclWithDoc] -> [DeclWithDoc] finishedDoc d DocEmpty rest = (d, Nothing) : rest finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest where @@ -257,7 +299,7 @@ finishedDoc _ _ rest = rest sameDecl d1 d2 = getLoc d1 == getLoc d2 - + mkSubMap :: HsGroup Name -> Map Name [Name] mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group, let name:subs = map unLoc (tyClDeclNames tycld) ] @@ -270,29 +312,37 @@ mkExportItems :: ModuleMap -> Module -- this module -> [Name] -- exported names (orig) - -> [(LHsDecl Name, Maybe (HsDoc Name))] - -> Map Name (LHsDecl Name, Maybe (HsDoc Name)) -- maps local names to declarations + -> [DeclWithDoc] + -> Map Name DeclWithDoc -- maps local names to declarations + -> Map Name Family -> Map Name [Name] -- sub-map for this module -> [DocOption] -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag + -> [Instance] -> ErrMsgM [ExportItem Name] -mkExportItems modMap this_mod exported_names decls declMap sub_map - opts maybe_exps ignore_all_exports +mkExportItems modMap this_mod exported_names decls declMap famMap sub_map + opts maybe_exps ignore_all_exports instances | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported - | Just specs <- maybe_exps = do - exps <- mapM lookupExport specs - return (concat exps) + | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs where + instances = [ d | d@(L _ decl, _) <- decls, isInstance decl ] + everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod decls) packageId = modulePackageId this_mod - lookupExport (IEVar x) = declWith x - lookupExport (IEThingAbs t) = declWith t + lookupExport (IEVar x) = declWith x + lookupExport (IEThingAbs t) = declWith t + -- | Just fam <- Map.lookup t famMap = absFam fam + -- | otherwise = declWith t + -- where + -- absFam (Just (famDecl, doc), instances) = return $ [ ExportDecl famDecl doc [] ] ++ matchingInsts t + -- absFam (Nothing, instances) = + lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t cs) = declWith t lookupExport (IEModuleContents m) = fullContentsOf (mkModule packageId m) @@ -307,7 +357,7 @@ mkExportItems modMap this_mod exported_names decls declMap sub_map declWith :: Name -> ErrMsgM [ ExportItem Name ] declWith t | Just (decl, maybeDoc) <- findDecl t - = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ] + = return [ ExportDecl (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ] | otherwise = return [] where @@ -340,7 +390,7 @@ fullContentsOfThisModule :: Module -> [(LHsDecl Name, Maybe (HsDoc Name))] -> [E fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls) where mkExportItem (L _ (DocD (DocGroup lev doc)), _) = Just $ ExportGroup lev "" doc - mkExportItem (decl, doc) = Just $ ExportDecl (declName (unLoc decl)) decl doc [] + mkExportItem (decl, doc) = Just $ ExportDecl decl doc [] -- mkExportItem _ = Nothing -- TODO: see if this is really needed @@ -407,7 +457,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = -- Pruning pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems items = filter hasDoc items - where hasDoc (ExportDecl _ _ d _) = isJust d + where hasDoc (ExportDecl _ d _) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index f6ffd7ab..d9488ac2 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -292,6 +292,9 @@ renameDecl d = case d of ForD d -> do d' <- renameForD d return (ForD d') + InstD d -> do + d' <- renameInstD d + return (InstD d') _ -> error "renameDecl" @@ -318,11 +321,11 @@ renameTyClD d = case d of return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing) TySynonym lname ltyvars typats ltype -> do + lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars ltype' <- renameLType ltype typats' <- mapM (mapM renameLType) typats - -- We skip type patterns here as well. - return (TySynonym (keepL lname) ltyvars' typats' ltype') + return (TySynonym lname' ltyvars' typats' ltype') ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do lcontext' <- renameLContext lcontext @@ -379,17 +382,23 @@ renameForD (ForeignExport lname ltype x) = do return (ForeignExport (keepL lname) ltype' x) +renameInstD (InstDecl ltype _ _ lATs) = do + ltype <- renameLType ltype + lATs' <- mapM renameLTyClD lATs + return (InstDecl ltype emptyBag [] lATs') + + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mod -> return (ExportModule mod) ExportGroup lev id doc -> do doc' <- renameDoc doc return (ExportGroup lev id doc') - ExportDecl x decl doc instances -> do + ExportDecl decl doc instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc instances' <- mapM renameInstHead instances - return (ExportDecl x decl' doc' instances') + return (ExportDecl decl' doc' instances') ExportNoDecl x y subs -> do y' <- lookupRn id y subs' <- mapM (lookupRn id) subs diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index e91f28cc..49150b64 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -37,9 +37,6 @@ data ExportItem name = ExportDecl { - -- | The original name - expItemName :: Name, - -- | A declaration expItemDecl :: LHsDecl name, diff --git a/tests/tests/TypeFamilies.hs b/tests/tests/TypeFamilies.hs new file mode 100644 index 00000000..561f95fd --- /dev/null +++ b/tests/tests/TypeFamilies.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeFamilies where + +-- | Type family G +type family G a :: * + +-- | A class with an associated type +class A a where + -- | An associated type + data B a :: * -> * + -- | A method + f :: B a Int + +-- | Doc for family +type family F a + + +-- | Doc for G Int +type instance G Int = Bool +type instance G Float = Int + + +instance A Int where + data B Int x = Con x + f = Con 3 + +g = Con 5 |