diff options
Diffstat (limited to 'src/HaddockUtil.hs')
| -rw-r--r-- | src/HaddockUtil.hs | 336 |
1 files changed, 66 insertions, 270 deletions
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index b4121752..8a0edc11 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -8,9 +8,8 @@ module HaddockUtil ( -- * Misc utilities - nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, - splitTyConApp, restrictTo, declDoc, freeTyCons, unbang, - addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, unQual, + restrictTo, + toDescription, -- * Filename utilities basename, dirname, splitFilename3, @@ -30,13 +29,11 @@ module HaddockUtil ( idMarkup, ) where -import Binary2 import HaddockTypes -import HsSyn2 hiding ( DocMarkup(..), markup, idMarkup ) -import Map ( Map ) -import qualified Map hiding ( Map ) +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) -import qualified GHC as GHC +import GHC import SrcLoc import Name import OccName @@ -55,186 +52,49 @@ import System.IO.Unsafe ( unsafePerformIO ) -- ----------------------------------------------------------------------------- -- Some Utilities -nameOfQName :: HsQName -> HsName -nameOfQName (Qual _ n) = n -nameOfQName (UnQual n) = n - -unQual :: HsQName -> HsQName -unQual (Qual _ n) = UnQual n -unQual n = n - -collectNames :: [HsDecl] -> [HsName] -collectNames ds = concat (map declBinders ds) - -unbang :: HsBangType -> HsType -unbang (HsUnBangedTy ty) = ty -unbang (HsBangedTy ty) = ty - -declBinders :: HsDecl -> [HsName] -declBinders d = maybeToList (declMainBinder d) ++ declSubBinders d - -declMainBinder :: HsDecl -> Maybe HsName -declMainBinder d = - case d of - HsTypeDecl _ n _ _ _ -> Just n - HsDataDecl _ _ n _ _ _ _ -> Just n - HsNewTypeDecl _ _ n _ _ _ _ -> Just n - HsClassDecl _ _ n _ _ _ _ -> Just n - HsTypeSig _ [n] _ _ -> Just n - HsTypeSig _ _ _ _ -> error "declMainBinder" - HsForeignImport _ _ _ _ n _ _ -> Just n - _ -> Nothing - -declSubBinders :: HsDecl -> [HsName] -declSubBinders d = - case d of - HsTypeDecl _ _ _ _ _ -> [] - HsDataDecl _ _ _ _ cons _ _ -> concat (map conDeclBinders cons) - HsNewTypeDecl _ _ _ _ con _ _ -> conDeclBinders con - HsClassDecl _ _ _ _ _ decls _ -> collectNames decls - HsTypeSig _ _ _ _ -> [] - HsForeignImport _ _ _ _ _ _ _ -> [] - _ -> [] - -conDeclBinders :: HsConDecl -> [HsName] -conDeclBinders (HsConDecl _ n _ _ _ _) = [n] -conDeclBinders (HsRecDecl _ n _ _ fields _) = - n : concat (map fieldDeclBinders fields) - -fieldDeclBinders :: HsFieldDecl -> [HsName] -fieldDeclBinders (HsFieldDecl ns _ _) = ns - -splitTyConApp :: HsType -> (HsQName, [HsType]) -splitTyConApp t0 = split t0 [] - where - split :: HsType -> [HsType] -> (HsQName,[HsType]) - split (HsTyApp t u) ts = split t (u:ts) - split (HsTyCon t) ts = (t,ts) - split _ _ = error "splitTyConApp" - -freeTyCons :: HsType -> [HsQName] -freeTyCons ty = go ty [] - where go (HsForAllType _ _ t) r = go t r - go (HsTyApp t u) r = go t (go u r) - go (HsTyCon c) r = c : r - go (HsTyFun f a) r = go f (go a r) - go (HsTyTuple _ ts) r = foldr go r ts - go (HsTyVar _) r = r - go (HsTyDoc t _) r = go t r - -- | extract a module's short description. -toDescription :: HaddockModule -> Maybe (GHC.HsDoc GHC.Name) -toDescription = GHC.hmi_description . hmod_info - --- ----------------------------------------------------------------------------- --- Adding documentation to record fields (used in parsing). - -addFieldDoc :: HsFieldDecl -> Maybe Doc -> HsFieldDecl -addFieldDoc (HsFieldDecl ns ty doc1) doc2 = - HsFieldDecl ns ty (doc1 `mplus` doc2) - -addFieldDocs :: [HsFieldDecl] -> Maybe Doc -> [HsFieldDecl] -addFieldDocs [] _ = [] -addFieldDocs (x:xs) doc = addFieldDoc x doc : xs - -addConDoc :: HsConDecl -> Maybe Doc -> HsConDecl -addConDoc (HsConDecl pos nm tvs ctxt typeList doc1) doc2 = - HsConDecl pos nm tvs ctxt typeList (doc1 `mplus` doc2) -addConDoc (HsRecDecl pos nm tvs ctxt fields doc1) doc2= - HsRecDecl pos nm tvs ctxt fields (doc1 `mplus` doc2) - -addConDocs :: [HsConDecl] -> Maybe Doc -> [HsConDecl] -addConDocs [] _ = [] -addConDocs (x:xs) doc = addConDoc x doc : xs +toDescription :: HaddockModule -> Maybe (HsDoc Name) +toDescription = hmi_description . hmod_info -- --------------------------------------------------------------------------- -- Making abstract declarations -restrictTo :: [GHC.Name] -> (GHC.LHsDecl GHC.Name) -> (GHC.LHsDecl GHC.Name) +restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name) restrictTo names (L loc decl) = L loc $ case decl of - GHC.TyClD d | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType -> - GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) }) - GHC.TyClD d | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType -> - case restrictCons names (GHC.tcdCons d) of - [] -> GHC.TyClD (d { GHC.tcdND = GHC.DataType, GHC.tcdCons = [] }) - [con] -> GHC.TyClD (d { GHC.tcdCons = [con] }) - GHC.TyClD d | GHC.isClassDecl d -> - GHC.TyClD (d { GHC.tcdSigs = restrictDecls names (GHC.tcdSigs d) }) + 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] }) + TyClD d | isClassDecl d -> + TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) }) _ -> decl -restrictCons :: [GHC.Name] -> [GHC.LConDecl GHC.Name] -> [GHC.LConDecl GHC.Name] +restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p (fromJust (keep d)) | L p d <- decls, isJust (keep d) ] - where keep d | unLoc (GHC.con_name d) `elem` names = - case GHC.con_details d of - GHC.PrefixCon _ -> Just d - GHC.RecCon fields + where keep d | unLoc (con_name d) `elem` names = + case con_details d of + PrefixCon _ -> Just d + RecCon fields | all field_avail fields -> Just d - | otherwise -> Just (d { GHC.con_details = GHC.PrefixCon (field_types fields) }) + | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. where - field_avail (GHC.HsRecField n _ _) = (unLoc n) `elem` names - field_types flds = [ ty | GHC.HsRecField n ty _ <- flds] + field_avail (HsRecField n _ _) = (unLoc n) `elem` names + field_types flds = [ ty | HsRecField n ty _ <- flds] keep d | otherwise = Nothing -restrictDecls :: [GHC.Name] -> [GHC.LSig GHC.Name] -> [GHC.LSig GHC.Name] +restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] restrictDecls names decls = filter keep decls - where keep d = fromJust (GHC.sigName d) `elem` names + where keep d = fromJust (sigName d) `elem` names -- has to have a name, since it's a class method type signature -{- -restrictTo :: [HsName] -> HsDecl -> HsDecl -restrictTo names decl = case decl of - HsDataDecl loc ctxt n xs cons drv doc -> - HsDataDecl loc ctxt n xs (restrictCons names cons) drv doc - decl@(HsNewTypeDecl loc ctxt n xs con drv doc) -> - case restrictCons names [con] of - [] -> HsDataDecl loc ctxt n xs [] drv doc - [con'] -> HsNewTypeDecl loc ctxt n xs con' drv doc - -- an abstract newtype decl appears as a data decl. - HsClassDecl loc ctxt n tys fds decls doc -> - HsClassDecl loc ctxt n tys fds (restrictDecls names decls) doc - _ -> decl - -restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl] -restrictCons names decls = [ d | Just d <- map keep decls ] - where keep d@(HsConDecl _ n _ _ _ _) - | n `elem` names = Just d - keep d@(HsRecDecl loc n tvs ctx fields doc) - | n `elem` names - = if all field_avail fields - then Just d - else Just (HsConDecl loc n tvs ctx confields doc) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - where - field_avail (HsFieldDecl ns _ _) = all (`elem` names) ns - confields = [ ty | HsFieldDecl ns ty doc <- fields, n <- ns ] - keep d = Nothing - -restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl] -restrictDecls names decls = filter keep decls - where keep d = not (null (declBinders d `intersect` names)) - -- ToDo: not really correct --} -- ----------------------------------------------------------------------------- --- Extract documentation from a declaration - -declDoc :: HsDecl -> Maybe Doc -declDoc (HsTypeDecl _ _ _ _ d) = d -declDoc (HsDataDecl _ _ _ _ _ _ d) = d -declDoc (HsNewTypeDecl _ _ _ _ _ _ d) = d -declDoc (HsClassDecl _ _ _ _ _ _ d) = d -declDoc (HsTypeSig _ _ _ d) = d -declDoc (HsForeignImport _ _ _ _ _ _ d) = d -declDoc _ = Nothing - --- ----------------------------------------------------------------------------- --- Filename mangling functions stolen from GHC's main/DriverUtil.lhs. +-- Filename mangling functions stolen from s main/DriverUtil.lhs. type Suffix = String @@ -280,13 +140,13 @@ isPathSeparator ch = moduleHtmlFile :: String -> FilePath moduleHtmlFile mdl = - case Map.lookup (GHC.mkModule mdl) html_xrefs of + case Map.lookup (mkModule mdl) html_xrefs of Nothing -> mdl' ++ ".html" Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] where mdl' = map (\c -> if c == '.' then '-' else c) mdl -nameHtmlRef :: String -> GHC.Name -> String +nameHtmlRef :: String -> Name -> String nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str) contentsHtmlFile, indexHtmlFile :: String @@ -369,120 +229,56 @@ escapeStr = escapeURIString isUnreserved -- being I'm going to use a write-once global variable. {-# NOINLINE html_xrefs_ref #-} -html_xrefs_ref :: IORef (Map GHC.Module FilePath) +html_xrefs_ref :: IORef (Map Module FilePath) html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) {-# NOINLINE html_xrefs #-} -html_xrefs :: Map GHC.Module FilePath +html_xrefs :: Map Module FilePath html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) ----------------------------------------------------------------------------- --- Binary instances for stuff - -instance Binary Module where - put_ bh (Module m) = putString bh m - get bh = do m <- getString bh; return $! (Module m) - -instance Binary HsQName where - put_ bh (Qual m s) = do putByte bh 0; put_ bh m; put_ bh s - put_ bh (UnQual s) = do putByte bh 1; put_ bh s - get bh = do b <- getByte bh - case b of - 0 -> do m <- get bh; s <- get bh; return (Qual m s) - _ -> do s <- get bh; return (UnQual s) - -instance Binary HsName where - put_ bh (HsTyClsName s) = do putByte bh 0; put_ bh s - put_ bh (HsVarName s) = do putByte bh 1; put_ bh s - get bh = do b <- getByte bh - case b of - 0 -> do s <- get bh; return (HsTyClsName s) - _ -> do s <- get bh; return (HsVarName s) - -instance Binary HsIdentifier where - put_ bh (HsIdent s) = do putByte bh 0; putString bh s - put_ bh (HsSymbol s) = do putByte bh 1; putString bh s - put_ bh (HsSpecial s) = do putByte bh 2; putString bh s - get bh = do b <- getByte bh - case b of - 0 -> do s <- getString bh; return (HsIdent s) - 1 -> do s <- getString bh; return (HsSymbol s) - _ -> do s <- getString bh; return (HsSpecial s) - -instance Binary id => Binary (GenDoc id) where - put_ bh DocEmpty = putByte bh 0 - put_ bh (DocAppend gd1 gd2) = do putByte bh 1;put_ bh gd1;put_ bh gd2 - put_ bh (DocString s) = do putByte bh 2;putString bh s - put_ bh (DocParagraph gd) = do putByte bh 3;put_ bh gd - put_ bh (DocIdentifier id) = do putByte bh 4;put_ bh id - put_ bh (DocModule s) = do putByte bh 5;putString bh s - put_ bh (DocEmphasis gd) = do putByte bh 6;put_ bh gd - put_ bh (DocMonospaced gd) = do putByte bh 7;put_ bh gd - put_ bh (DocUnorderedList gd) = do putByte bh 8;put_ bh gd - put_ bh (DocOrderedList gd) = do putByte bh 9;put_ bh gd - put_ bh (DocDefList gd) = do putByte bh 10;put_ bh gd - put_ bh (DocCodeBlock gd) = do putByte bh 11;put_ bh gd - put_ bh (DocURL s) = do putByte bh 12;putString bh s - put_ bh (DocAName s) = do putByte bh 13;putString bh s - get bh = do b <- getByte bh - case b of - 0 -> return DocEmpty - 1 -> do gd1 <- get bh;gd2 <- get bh;return (DocAppend gd1 gd2) - 2 -> do s <- getString bh;return (DocString s) - 3 -> do gd <- get bh;return (DocParagraph gd) - 4 -> do id <- get bh;return (DocIdentifier id) - 5 -> do s <- getString bh;return (DocModule s) - 6 -> do gd <- get bh;return (DocEmphasis gd) - 7 -> do gd <- get bh;return (DocMonospaced gd) - 8 -> do gd <- get bh;return (DocUnorderedList gd) - 9 -> do gd <- get bh;return (DocOrderedList gd) - 10 -> do gd <- get bh;return (DocDefList gd) - 11 -> do gd <- get bh;return (DocCodeBlock gd) - 12 -> do s <- getString bh;return (DocURL s) - 13 -> do s <- getString bh;return (DocAName s) - _ -> error ("Mysterious byte in document in interface" - ++ show b) - -markup :: DocMarkup id a -> GHC.HsDoc id -> a -markup m GHC.DocEmpty = markupEmpty m -markup m (GHC.DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (GHC.DocString s) = markupString m s -markup m (GHC.DocParagraph d) = markupParagraph m (markup m d) -markup m (GHC.DocIdentifier ids) = markupIdentifier m ids -markup m (GHC.DocModule mod0) = markupModule m mod0 -markup m (GHC.DocEmphasis d) = markupEmphasis m (markup m d) -markup m (GHC.DocMonospaced d) = markupMonospaced m (markup m d) -markup m (GHC.DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (GHC.DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (GHC.DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (GHC.DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (GHC.DocURL url) = markupURL m url -markup m (GHC.DocAName ref) = markupAName m ref - -markupPair :: DocMarkup id a -> (GHC.HsDoc id, GHC.HsDoc id) -> (a, a) +-- put here temporarily + +markup :: DocMarkup id a -> HsDoc id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier ids) = markupIdentifier m ids +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocURL url) = markupURL m url +markup m (DocAName ref) = markupAName m ref + +markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) -- | The identity markup -idMarkup :: DocMarkup a (GHC.HsDoc a) +idMarkup :: DocMarkup a (HsDoc a) idMarkup = Markup { - markupEmpty = GHC.DocEmpty, - markupString = GHC.DocString, - markupParagraph = GHC.DocParagraph, - markupAppend = GHC.DocAppend, - markupIdentifier = GHC.DocIdentifier, - markupModule = GHC.DocModule, - markupEmphasis = GHC.DocEmphasis, - markupMonospaced = GHC.DocMonospaced, - markupUnorderedList = GHC.DocUnorderedList, - markupOrderedList = GHC.DocOrderedList, - markupDefList = GHC.DocDefList, - markupCodeBlock = GHC.DocCodeBlock, - markupURL = GHC.DocURL, - markupAName = GHC.DocAName + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupModule = DocModule, + markupEmphasis = DocEmphasis, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupURL = DocURL, + markupAName = DocAName } -- | Since marking up is just a matter of mapping 'Doc' into some -- other type, we can \'rename\' documentation by marking up 'Doc' into -- the same thing, modifying only the identifiers embedded in it. -mapIdent :: ([a] -> GHC.HsDoc b) -> DocMarkup a (GHC.HsDoc b) + mapIdent f = idMarkup { markupIdentifier = f } |