{-# LANGUAGE CPP #-}

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

import HDocs.Ghc.Compat

-- | Documentation in module
type ModuleDocMap = Map String (Doc String)

-- | Run action with initialized packages
withInitializedPackages :: [String] -> (DynFlags -> IO a) -> IO a
withInitializedPackages ghcOpts cont = runGhc (Just libdir) $ do
        fs <- getSessionDynFlags
        cleanupHandler fs $ do
                (fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
                _ <- setSessionDynFlags fs'
                (result, _) <- GHC.liftIO $ initPackages fs'
                GHC.liftIO $ cont result

-- | Config GHC session
configSession :: [String] -> IO DynFlags
configSession ghcOpts = runGhc (Just libdir) $ do
        fs <- getSessionDynFlags
        cleanupHandler fs $ do
                (fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
                _ <- setSessionDynFlags fs'
                (result, _) <- GHC.liftIO $ initPackages fs'
                return result

-- | Format documentation to plain text.
formatDoc :: Doc String -> String
formatDoc = trim . go where
        go :: Doc String -> String
        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
#if MIN_VERSION_haddock_library(1,4,0)
        go (DocMathInline m) = m
        go (DocMathDisplay m) = m
#endif
        go (DocAName name) = name
        go (DocProperty prop) = prop
        go (DocExamples exs) = unlines (map formatExample exs)
        go (DocHeader h) = foldMap go h
        go _ = ""

        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

-- | Format docs to plain text
formatDocs :: ModuleDocMap -> Map String String
formatDocs = M.map formatDoc