module HDocs.Base (
ModuleDocMap,
withInitializedPackages, configSession,
formatDoc, formatDocs
) where
import Data.Char (isSpace)
import Data.Map (Map)
import Data.Foldable (foldMap)
import qualified Data.Map as M
import Documentation.Haddock
import DynFlags
import GHC
import GHC.Paths
import qualified GhcMonad as GHC (liftIO)
import Name (occNameString)
import Packages
type ModuleDocMap = Map String (Doc String)
withInitializedPackages :: [String] -> (DynFlags -> IO a) -> IO a
withInitializedPackages ghcOpts cont = do
runGhc (Just libdir) $ do
fs <- getSessionDynFlags
defaultCleanupHandler fs $ do
(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
setSessionDynFlags fs'
(result, _) <- GHC.liftIO $ initPackages fs'
GHC.liftIO $ cont result
configSession :: [String] -> IO DynFlags
configSession ghcOpts = do
runGhc (Just libdir) $ do
fs <- getSessionDynFlags
defaultCleanupHandler fs $ do
(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
setSessionDynFlags fs'
(result, _) <- GHC.liftIO $ initPackages fs'
return result
formatDoc :: Doc String -> String
formatDoc = trim . go where
go :: Doc String -> String
go DocEmpty = ""
go (DocAppend a b) = go a ++ go b
go (DocString str) = trimSpaces str
go (DocParagraph p) = go p ++ "\n"
go (DocIdentifier i) = i
go (DocIdentifierUnchecked (mname, occname)) = moduleNameString mname ++ "." ++ occNameString occname
go (DocModule m) = m
go (DocWarning w) = go w
go (DocEmphasis e) = "*" ++ go e ++ "*"
go (DocMonospaced e) = "`" ++ go e ++ "`"
go (DocBold b) = "*" ++ go b ++ "*"
go (DocUnorderedList i) = unlines (map (("* " ++) . go) i)
go (DocOrderedList i) = unlines (zipWith (\i' x -> show i' ++ ". " ++ go x) ([1..] :: [Integer]) i)
go (DocDefList xs) = unlines (map (\(i,x) -> go i ++ ". " ++ go x) xs)
go (DocCodeBlock block) = unlines (map (" " ++) (lines (go block))) ++ "\n"
go (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label
go (DocPic pic) = show pic
go (DocAName name) = name
go (DocProperty prop) = prop
go (DocExamples exs) = unlines (map formatExample exs)
go (DocHeader h) = foldMap go h
formatExample :: Example -> String
formatExample (Example expr result) = ">>> " ++ expr ++ "\n" ++ unlines result
trimSpaces [] = []
trimSpaces [s] = [s]
trimSpaces (' ':' ':ss) = trimSpaces (' ':ss)
trimSpaces (x:y:ss) = x : trimSpaces(y:ss)
trim :: String -> String
trim = p . p where
p = reverse . dropWhile isSpace
formatDocs :: ModuleDocMap -> Map String String
formatDocs = M.map formatDoc