diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hoogle.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 331 |
1 files changed, 331 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs new file mode 100644 index 00000000..628e1cd0 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -0,0 +1,331 @@ +----------------------------------------------------------------------------- +-- | +-- 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] |