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