diff options
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 32 |
1 files changed, 20 insertions, 12 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 99b93847..242d075c 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -12,7 +12,6 @@ module Haddock.Backends.Hoogle ( ) where -import Haddock.GHC import Haddock.GHC.Utils import Haddock.Types import Haddock.Utils hiding (out) @@ -24,10 +23,10 @@ import Control.Monad import Data.Char import Data.List import Data.Maybe -import qualified Data.Set as Set import System.FilePath +prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""] @@ -68,19 +67,22 @@ dropHsDocTy = f 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 b) = f $ unL a + f (HsDocTy a _) = f $ unL a f x = x outHsType :: OutputableBndr a => HsType a -> String outHsType = out . 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 [] = [] @@ -134,14 +136,16 @@ ppClass x = out x{tcdSigs=[]} : concatMap (ppSig . 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 : unL con) d - f x = HsForAllTy Implicit [] (reL [context]) (reL x) + f t = HsForAllTy Implicit [] (reL [context]) (reL t) context = reL $ HsClassP (unL $ tcdLName x) (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x)) - tyVar (UserTyVar x) = x - tyVar (KindedTyVar x _) = x + tyVar (UserTyVar v) = v + tyVar (KindedTyVar v _) = v ppInstance :: Instance -> [String] @@ -154,11 +158,11 @@ ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} : where -- GHC gives out "data Bar =", we want to delete the equals -- also writes data : a b, when we want data (:) a b - showData x = unwords $ map f $ if last xs == "=" then init xs else xs + showData d = unwords $ map f $ if last xs == "=" then init xs else xs where - xs = words $ out x - nam = out $ tcdLName x - f x = if x == nam then operator nam else x + xs = words $ out d + nam = out $ tcdLName d + f w = if w == nam then operator nam else w ppCtor :: TyClDecl Name -> ConDecl Name -> [String] @@ -174,7 +178,7 @@ ppCtor dat con = ldoc (con_doc con) ++ f (con_details con) funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig name flds = operator name ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds) name = out $ unL $ con_name con resType = case con_res con of @@ -204,7 +208,10 @@ data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | 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 @@ -247,6 +254,7 @@ 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] @@ -282,7 +290,7 @@ showPre = trimFront . trimLines . lines . concatMap f unwordsWrap :: Int -> [String] -> [String] unwordsWrap n = f n [] where - f i s [] = [g s | s /= []] + 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 |