diff options
Diffstat (limited to 'src/Haddock/Backends/Hoogle.hs')
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 111 |
1 files changed, 57 insertions, 54 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 78e81d11..9c5d57c3 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) ++ +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface + = "" : doc dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap ppExport (ifaceExportItems iface) ++ - concatMap ppInstance (ifaceInstances 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 @@ -108,34 +109,35 @@ 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 _) = doc dflags (fst dc) ++ f (unL decl) where f (TyClD d@TyDecl{}) - | isDataDecl d = ppData d subdocs - | otherwise = ppSynonym d - f (TyClD d@ClassDecl{}) = ppClass d - f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ - f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ - f (SigD sig) = ppSig sig + | 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 = concat . intersperse ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x -ppSig _ = [] +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" @@ -147,27 +149,27 @@ ppClass x = out x{tcdSigs=[]} : (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x))) -ppInstance :: ClsInst -> [String] -ppInstance x = [dropComment $ out x] +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = [dropComment $ out dflags x] -ppSynonym :: TyClDecl Name -> [String] -ppSynonym x = [out x] +ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym dflags x = [out dflags x] -ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppData decl@(TyDecl { tcdTyDefn = defn }) subdocs +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 decl subdocs . unL) (td_cons defn) + 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" +ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) @@ -175,22 +177,22 @@ lookupCon subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> d _ -> Nothing -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 = doc dflags (lookupCon 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]] + [doc dflags (lookupCon 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) $ @@ -201,15 +203,16 @@ ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) --------------------------------------------------------------------- -- DOCUMENTATION -doc :: Outputable o => Maybe (Doc o) -> [String] -doc = docWith "" +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 @@ -230,14 +233,14 @@ 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, markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"), |