diff options
Diffstat (limited to 'src/Haddock/Backends/Hoogle.hs')
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 142 |
1 files changed, 77 insertions, 65 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 6e3e306a..4949daa1 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -34,24 +34,25 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ - docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ version | version /= ""] ++ - concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8 hPutStr h (unlines contents) hClose h -ppModule :: Interface -> [String] -ppModule iface = "" : doc (ifaceDoc iface) ++ - ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap ppExport (ifaceExportItems iface) ++ - concatMap ppInstance (ifaceInstances iface) +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface = + "" : ppDocumentation dflags (ifaceDoc iface) ++ + ["module " ++ moduleString (ifaceMod iface)] ++ + concatMap (ppExport dflags) (ifaceExportItems iface) ++ + concatMap (ppInstance dflags) (ifaceInstances iface) --------------------------------------------------------------------- @@ -74,8 +75,8 @@ dropHsDocTy = f f (HsDocTy a _) = f $ unL a f x = x -outHsType :: OutputableBndr a => HsType a -> String -outHsType = out . dropHsDocTy +outHsType :: OutputableBndr a => DynFlags -> HsType a -> String +outHsType dflags = out dflags . dropHsDocTy makeExplicit :: HsType a -> HsType a @@ -92,8 +93,8 @@ dropComment (x:xs) = x : dropComment xs dropComment [] = [] -out :: Outputable a => a -> String -out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr +out :: Outputable a => DynFlags -> a -> String +out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr where f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs @@ -101,111 +102,121 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr operator :: String -> String -operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")" +operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x --------------------------------------------------------------------- -- How to print each export -ppExport :: ExportItem Name -> [String] -ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) +ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl) where - f (TyClD d@TyData{}) = ppData d subdocs - 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 + f (TyClD d@TyDecl{}) + | isDataDecl d = ppData dflags d subdocs + | otherwise = ppSynonym dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (SigD sig) = ppSig dflags sig f _ = [] -ppExport _ = [] +ppExport _ _ = [] -ppSig :: Sig Name -> [String] -ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags (TypeSig names sig) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where - prettyNames = concat . intersperse ", " $ map out names + prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x -ppSig _ = [] - - -ppSynonym :: TyClDecl Name -> [String] -ppSynonym x = [out x] +ppSig _ _ = [] -- note: does not yet output documentation for class methods -ppClass :: TyClDecl Name -> [String] -ppClass x = out x{tcdSigs=[]} : - concatMap (ppSig . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [String] +ppClass dflags x = out dflags x{tcdSigs=[]} : + concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) addContext _ = error "expected TypeSig" f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d - f t = HsForAllTy Implicit [] (reL [context]) (reL t) + f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (unL $ tcdLName x) - (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x)) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x))) + +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = [dropComment $ out dflags x] -ppInstance :: Instance -> [String] -ppInstance x = [dropComment $ out x] +ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym dflags x = [out dflags x] -ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : - concatMap (ppCtor x subdocs . unL) (tcdCons x) +ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs + = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} : + concatMap (ppCtor dflags 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 where - xs = words $ out d - nam = out $ tcdLName d + xs = words $ out dflags d + nam = out dflags $ 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) -lookupCon subdocs (L _ name) = case lookup name subdocs of - Just (d, _) -> d - _ -> Nothing +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon dflags subdocs (L _ name) = case lookup name subdocs of + Just (d, _) -> ppDocumentation dflags d + _ -> [] -ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) +ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) ++ f (con_details con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat - [doc (lookupCon subdocs (cd_fld_name r)) ++ - [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] + [lookupCon dflags subdocs (cd_fld_name r) ++ + [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] | r <- recs] funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds) - name = out $ unL $ con_name con + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + name = out dflags $ unL $ con_name con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [hsTyVarName v | v@UserTyVar {} <- map unL $ tcdTyVars dat] + ResTyH98 -> apps $ map (reL . HsTyVar) $ + unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat] ResTyGADT x -> x --------------------------------------------------------------------- -- DOCUMENTATION -doc :: Outputable o => Maybe (Doc o) -> [String] -doc = docWith "" +ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] +ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w + + +doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] +doc dflags = docWith dflags "" -docWith :: Outputable o => String -> Maybe (Doc o) -> [String] -docWith [] Nothing = [] -docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ +docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] +docWith _ [] Nothing = [] +docWith dflags header d + = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ - maybe [] (showTags . markup markupTag) d + maybe [] (showTags . markup (markupTag dflags)) d data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String @@ -226,15 +237,16 @@ str a = [Str a] -- or inlne for others (a,i,tt) -- entities (&,>,<) should always be appropriately escaped -markupTag :: Outputable o => DocMarkup o [Tag] -markupTag = Markup { +markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] +markupTag dflags = Markup { markupParagraph = box TagP, markupEmpty = str "", markupString = str, markupAppend = (++), - markupIdentifier = box (TagInline "a") . str . out, - markupIdentifierUnchecked = box (TagInline "a") . str . out . snd, + markupIdentifier = box (TagInline "a") . str . out dflags, + markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"), markupPic = const $ str " ", @@ -242,7 +254,7 @@ markupTag = Markup { markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, - markupURL = box (TagInline "a") . str, + markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), markupAName = const $ str "", markupExample = box TagPre . str . unlines . map exampleToString } |