module Documentation.Haddock.Docs where
import Control.Arrow
import Control.Monad
import Control.Monad.Loops
import Data.Char
import Data.Either
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Documentation.Haddock
import GHC hiding (verbosity)
import GHC.Paths (libdir)
import Module
import Name
import PackageConfig
import Packages
#if __GLASGOW_HASKELL__ < 706
import DynFlags (defaultLogAction)
#else
import DynFlags (defaultFlushOut, defaultFatalMessager)
#endif
printDocumentationInitialized :: String -> ModuleName -> Maybe String -> IO Bool
printDocumentationInitialized x y z =
withInitializedPackages $ \d ->
printDocumentation d x y z Nothing
printDocumentation :: DynFlags -> String -> ModuleName -> Maybe String -> Maybe PackageConfig -> IO Bool
printDocumentation d name mname mpname previous = do
result <- getPackagesByModule d mname
case result of
Left _suggestions -> error "Couldn't find that module. Suggestions are forthcoming."
Right [package] -> printWithPackage d False name mname package
Right packages ->
case mpname of
Nothing -> do
putStrLn $ "Ambiguous module, belongs to more than one package: " ++
unwords (map (showPackageName . sourcePackageId) packages) ++
"\nContinuing anyway... "
anyM (printWithPackage d True name mname) (filter (not . isPrevious) packages)
Just pname -> do
case find ((== pname) . showPackageName . sourcePackageId) packages of
Nothing -> error "Unable to find that module/package combination."
Just package -> printWithPackage d False name mname package
where isPrevious m = Just (sourcePackageId m) == fmap sourcePackageId previous
showPackageName :: PackageIdentifier -> String
showPackageName = packageIdString . mkPackageId
printWithPackage :: DynFlags -> Bool -> String -> ModuleName -> PackageConfig -> IO Bool
printWithPackage d printPackage name mname package = do
interfaceFiles <- getHaddockInterfacesByPackage package
case (lefts interfaceFiles,rights interfaceFiles) of
([],[]) -> error "Found no interface files."
(errs@(_:_),_) -> error $ "Couldn't parse interface file(s): " ++ unlines errs
(_,files) ->
flip anyM files $ \interfaceFile ->
case filter ((==mname) . moduleName . instMod) (ifInstalledIfaces interfaceFile) of
[] -> error "Couldn't find an interface for that module in the package description."
interfaces -> anyM (printWithInterface d printPackage package name) interfaces
printWithInterface :: DynFlags -> Bool -> PackageConfig -> String -> InstalledInterface
-> IO Bool
printWithInterface df printPackage package name interface = do
case M.lookup name docMap of
Nothing -> do
case lookup name (map (getOccString &&& id) (instExports interface)) of
Just subname
| moduleName (nameModule subname) /= moduleName (instMod interface) ->
descendSearch df name subname package
_ -> do
putStrLn $ "Couldn't find name ``" ++ name ++ "'' in Haddock interface: " ++
moduleNameString (moduleName (instMod interface))
return False
Just d -> do when printPackage $
putStrLn $ "Package: " ++ showPackageName (sourcePackageId package)
putStrLn (formatDoc d)
printArgs interface name
return True
where docMap = interfaceNameMap interface
printArgs :: InstalledInterface -> String -> IO ()
printArgs interface name = do
case M.lookup name (interfaceArgMap interface) of
Nothing -> return ()
Just argMap ->
putStr $ unlines
$ map (\(i,x) -> formatArg i x)
(map (second (fmap getOccString)) (M.toList argMap))
where formatArg i x = prefix ++
indentAfter (length prefix) (formatDoc x)
where prefix = show i ++ ": "
indentAfter :: Int -> String -> String
indentAfter i xs = intercalate "\n" (take 1 l ++ map (replicate (i1) ' ' ++) (drop 1 l))
where l = lines xs
descendSearch :: DynFlags -> String -> Name -> PackageConfig -> IO Bool
descendSearch d name qname package = do
printDocumentation d name (moduleName (nameModule qname)) Nothing (Just package)
formatDoc :: Doc String -> String
formatDoc = trim . doc where
doc :: Doc String -> String
doc DocEmpty = ""
doc (DocAppend a b) = doc a ++ doc b
doc (DocString str) = normalize str
doc (DocParagraph p) = doc p ++ "\n"
doc (DocModule m) = m
doc (DocEmphasis e) = "*" ++ doc e ++ "*"
doc (DocMonospaced e) = "`" ++ doc e ++ "`"
doc (DocUnorderedList i) = unlines (map (("* " ++) . doc) i)
doc (DocOrderedList i) = unlines (zipWith (\j x -> show j ++ ". " ++ doc x) [1 :: Int ..] i)
doc (DocDefList xs) = unlines (map (\(i,x) -> doc i ++ ". " ++ doc x) xs)
doc (DocCodeBlock block) = unlines (map (" " ++) (lines (doc block))) ++ "\n"
doc (DocAName name) = name
doc (DocExamples exs) = unlines (map formatExample exs)
#if MIN_VERSION_haddock(2,10,0)
doc (DocIdentifier i) = i
doc (DocWarning d) = "Warning: " ++ doc d
#else
doc (DocPic pic) = pic
doc (DocIdentifier i) = intercalate "." i
#endif
#if MIN_VERSION_haddock(2,11,0)
doc (DocIdentifierUnchecked (mname,occname)) =
moduleNameString mname ++ "." ++ occNameString occname
doc (DocPic pic) = show pic
#endif
#if MIN_VERSION_haddock(2,13,0)
doc (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label
doc (DocProperty p) = "Property: " ++ p
#else
doc (DocURL url) = url
#endif
#if MIN_VERSION_haddock(2,14,0)
doc (DocBold d) = "**" ++ doc d ++ "**"
doc (DocHeader _) = ""
#endif
normalize :: [Char] -> [Char]
normalize = go where
go (' ':' ':cs) = go (' ':cs)
go (c:cs) = c : go cs
go [] = []
trim :: [Char] -> [Char]
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
formatExample :: Example -> String
formatExample (Example expression result) =
" > " ++ expression ++
unlines (map (" " ++) result)
interfaceNameMap :: InstalledInterface -> Map String (Doc String)
#if MIN_VERSION_haddock(2,10,0)
interfaceNameMap iface =
M.fromList (map (second (fmap getOccString) . first getOccString)
(M.toList (instDocMap iface)))
#else
interfaceNameMap iface =
M.fromList (map (second (fmap getOccString . maybe DocEmpty id . fst) . first getOccString)
(M.toList (instDocMap iface)))
#endif
interfaceArgMap :: InstalledInterface -> Map String (Map Int (Doc Name))
#if MIN_VERSION_haddock(2,10,0)
interfaceArgMap iface =
M.fromList (map (first getOccString) (M.toList (instArgMap iface)))
#else
interfaceArgMap iface = M.fromList (map (second (const M.empty) . first getOccString)
(M.toList (instDocMap iface)))
#endif
getPackagesByModule :: DynFlags -> ModuleName -> IO (Either [Module] [PackageConfig])
getPackagesByModule d m =
return (fmap (map fst) (lookupModuleWithSuggestions d m))
getHaddockInterfacesByPackage :: PackageConfig -> IO [Either String InterfaceFile]
getHaddockInterfacesByPackage = mapM (readInterfaceFile freshNameCache) . haddockInterfaces
withInitializedPackages :: (DynFlags -> IO a) -> IO a
withInitializedPackages cont = do
dflags <- run (do dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags
return dflags)
(dflags',_packageids) <- initPackages dflags
cont dflags'
#if __GLASGOW_HASKELL__ < 706
run :: Ghc a -> IO a
run = defaultErrorHandler defaultLogAction . runGhc (Just libdir)
#else
run :: Ghc a -> IO a
run = defaultErrorHandler defaultFatalMessager defaultFlushOut . runGhc (Just libdir)
#endif