----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle -- Copyright : (c) Neil Mitchell 2006-2008 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable -- -- Write out Hoogle compatible documentation -- http://www.haskell.org/hoogle/ ----------------------------------------------------------------------------- module Haddock.Backends.Hoogle ( ppHoogle ) where import Haddock.GhcUtils import Haddock.Types import Haddock.Utils hiding (out) import GHC import Outputable import Data.Char import Data.List import Data.Maybe import System.FilePath import System.IO prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""] 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 dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ version | version /= ""] ++ 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 :: DynFlags -> Interface -> [String] ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ concatMap (ppInstance dflags) (ifaceInstances iface) --------------------------------------------------------------------- -- Utility functions dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) f (HsForAllTy a b c d) = HsForAllTy a b c (g d) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b) f (HsListTy a) = HsListTy (g a) f (HsPArrTy a) = HsPArrTy (g a) f (HsTupleTy a b) = HsTupleTy a (map g b) f (HsOpTy a b c) = HsOpTy (g a) b (g c) f (HsParTy a) = HsParTy (g a) f (HsKindSig a b) = HsKindSig (g a) b f (HsDocTy a _) = f $ unL a f x = x outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy makeExplicit :: HsType a -> HsType a makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c makeExplicit x = x makeExplicitL :: LHsType a -> LHsType a makeExplicitL (L src x) = L src (makeExplicit x) dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs dropComment [] = [] 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 f [] = [] operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x --------------------------------------------------------------------- -- How to print each export ppExport :: DynFlags -> ExportItem Name -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs } = ppDocumentation dflags dc ++ f decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = 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 _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] ppSig dflags (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x ppSig _ _ = [] -- note: does not yet output documentation for class methods 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 (MinimalSig sig) = MinimalSig sig addContext _ = error "expected TypeSig" f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (tcdName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = [dropComment $ out dflags x] ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : concatMap (ppCtor dflags decl subdocs . unL) (dd_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 dflags d nam = out dflags $ tyClDeclLName d f w = if w == nam then operator nam else w ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] 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 [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 dflags (makeExplicit $ unL $ funs flds) name = out dflags $ unL $ con_name con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] ResTyGADT x -> x --------------------------------------------------------------------- -- DOCUMENTATION 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 => DynFlags -> String -> Maybe (Doc o) -> [String] docWith _ [] Nothing = [] docWith dflags header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show type Tags = [Tag] box :: (a -> b) -> a -> [b] box f x = [f x] str :: String -> [Tag] str a = [Str a] -- want things like paragraph, pre etc to be handled by blank lines in the source document -- and things like \n and \t converted away -- much like blogger in HTML mode -- everything else wants to be included as tags, neatly nested for some (ul,li,ol) -- or inlne for others (a,i,tt) -- entities (&,>,<) should always be appropriately escaped markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] markupTag dflags = Markup { markupParagraph = box TagP, markupEmpty = str "", markupString = str, markupAppend = (++), 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"), markupBold = box (TagInline "b"), markupMonospaced = box (TagInline "tt"), markupPic = const $ str " ", markupUnorderedList = box (TagL 'u'), markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h } showTags :: [Tag] -> [String] showTags = intercalate [""] . map showBlock showBlock :: Tag -> [String] showBlock (TagP xs) = showInline xs showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"] where mid = concatMap (showInline . box (TagInline "li")) xs showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"] showBlock x = showInline [x] asInline :: Tag -> Tags asInline (TagP xs) = xs asInline (TagPre xs) = [TagInline "pre" xs] asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs] asInline x = [x] showInline :: [Tag] -> [String] showInline = unwordsWrap 70 . words . concatMap f where fs = concatMap f f (Str x) = escape x f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">" f x = fs $ asInline x trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse showPre :: [Tag] -> [String] showPre = trimFront . trimLines . lines . concatMap f where trimLines = dropWhile null . reverse . dropWhile null . reverse trimFront xs = map (drop i) xs where ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""] i = if null ns then 0 else minimum ns fs = concatMap f f (Str x) = escape x f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">" f x = fs $ asInline x unwordsWrap :: Int -> [String] -> [String] unwordsWrap n = f n [] where f _ s [] = [g s | s /= []] f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs | otherwise = f (i - nx - 1) (x:s) xs where nx = length x g = unwords . reverse escape :: String -> String escape = concatMap f where f '<' = "<" f '>' = ">" f '&' = "&" f x = [x]