diff options
Diffstat (limited to 'src/Haddock/Interface')
| -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 |
3 files changed, 101 insertions, 41 deletions
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 |