-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Utils
-- Copyright   :  (c) The University of Glasgow 2001-2002,
--                    Simon Marlow 2003-2006,
--                    David Waern  2006-2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Utils (

  -- * Misc utilities
  restrictTo,
  toDescription, toInstalledDescription,

  -- * Filename utilities
  moduleHtmlFile,
  contentsHtmlFile, indexHtmlFile,
  frameIndexHtmlFile,
  moduleIndexFrameName, mainFrameName, synopsisFrameName,
  subIndexHtmlFile,
  jsFile, framesFile,

  -- * Anchor and URL utilities
  moduleNameUrl, moduleUrl,
  nameAnchorId,
  makeAnchorId,

  -- * Miscellaneous utilities
  getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,

  -- * HTML cross reference mapping
  html_xrefs_ref,

  -- * Doc markup 
  markup,
  idMarkup,

  -- * List utilities
  replace,
  spanWith,

  -- * MTL stuff
  MonadIO(..),

  -- * Logging
  parseVerbosity,
  out,

  -- * System tools
  getProcessID
 ) where


import Haddock.Types
import Haddock.GhcUtils

import GHC
import Name

import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
import Numeric ( showIntAtBase )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
import Data.Maybe ( fromJust )
import System.Environment ( getProgName )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( hPutStr, stderr )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
import Distribution.Verbosity
import Distribution.ReadE

#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
#endif

import MonadUtils ( MonadIO(..) )


--------------------------------------------------------------------------------
-- * Logging
--------------------------------------------------------------------------------


parseVerbosity :: String -> Either String Verbosity
parseVerbosity = runReadE :: ReadE a -> String -> Either ErrorMsg arunReadE flagToVerbosity :: ReadE VerbosityflagToVerbosity


-- | Print a message to stdout, if it is not too verbose
out :: MonadIO m
    => Verbosity -- ^ program verbosity
    -> Verbosity -- ^ message verbosity
    -> String -> m ()
out progVerbosity msgVerbosity msg
  | msgVerbosity :: VerbositymsgVerbosity (<=) :: Ord a => a -> a -> Bool<= progVerbosity :: VerbosityprogVerbosity = liftIO :: MonadIO m => forall a. IO a -> m aliftIO ($) :: (a -> b) -> a -> b$ putStrLn :: String -> IO ()putStrLn msg :: Stringmsg
  | otherwise :: Boolotherwise = return :: Monad m => forall a. a -> m areturn ()


--------------------------------------------------------------------------------
-- * Some Utilities
--------------------------------------------------------------------------------


-- | Extract a module's short description.
toDescription :: Interface -> Maybe (Doc Name)
toDescription = hmi_description :: HaddockModInfo name -> Maybe (Doc name)hmi_description (.) :: (b -> c) -> (a -> b) -> a -> c. ifaceInfo :: Interface -> HaddockModInfo NameifaceInfo


-- | Extract a module's short description.
toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)
toInstalledDescription = hmi_description :: HaddockModInfo name -> Maybe (Doc name)hmi_description (.) :: (b -> c) -> (a -> b) -> a -> c. instInfo :: InstalledInterface -> HaddockModInfo NameinstInfo


--------------------------------------------------------------------------------
-- * Making abstract declarations
--------------------------------------------------------------------------------


restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
restrictTo names (L loc decl) = L :: SrcSpan -> e -> Located eL loc :: SrcSpanloc ($) :: (a -> b) -> a -> b$ case decl :: HsDecl Namedecl of
  TyClD d | isDataDecl :: TyClDecl name -> BoolisDataDecl d :: TyClDecl Named (&&) :: Bool -> Bool -> Bool&& tcdND :: TyClDecl name -> NewOrDatatcdND d :: TyClDecl Named (==) :: Eq a => a -> a -> Bool== DataType :: NewOrDataDataType ->
    TyClD :: TyClDecl id -> HsDecl idTyClD (d :: TyClDecl Named { tcdCons = restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]restrictCons names :: [Name]names (tcdCons :: TyClDecl name -> [LConDecl name]tcdCons d :: TyClDecl Named) })
  TyClD d | isDataDecl :: TyClDecl name -> BoolisDataDecl d :: TyClDecl Named (&&) :: Bool -> Bool -> Bool&& tcdND :: TyClDecl name -> NewOrDatatcdND d :: TyClDecl Named (==) :: Eq a => a -> a -> Bool== NewType :: NewOrDataNewType ->
    case restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]restrictCons names :: [Name]names (tcdCons :: TyClDecl name -> [LConDecl name]tcdCons d :: TyClDecl Named) of
      []    -> TyClD :: TyClDecl id -> HsDecl idTyClD (d :: TyClDecl Named { tcdND = DataType :: NewOrDataDataType, tcdCons = [] :: [a][] })
      [con] -> TyClD :: TyClDecl id -> HsDecl idTyClD (d :: TyClDecl Named { tcdCons = [con :: LConDecl Namecon] })
      _ -> error :: [Char] -> aerror "Should not happen"
  TyClD d | isClassDecl :: TyClDecl name -> BoolisClassDecl d :: TyClDecl Named ->
    TyClD :: TyClDecl id -> HsDecl idTyClD (d :: TyClDecl Named { tcdSigs = restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]restrictDecls names :: [Name]names (tcdSigs :: TyClDecl name -> [LSig name]tcdSigs d :: TyClDecl Named),
               tcdATs = restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]restrictATs names :: [Name]names (tcdATs :: TyClDecl name -> [LTyClDecl name]tcdATs d :: TyClDecl Named) })
  _ -> decl :: HsDecl Namedecl


restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L :: SrcSpan -> e -> Located eL p :: SrcSpanp d :: TyClDecl Named | L p (Just d) <- map :: (a -> b) -> [a] -> [b]map (fmap :: Functor f => forall a b. (a -> b) -> f a -> f bfmap keep :: ConDecl Name -> Maybe (ConDecl Name)keep) decls :: [LConDecl Name]decls ]
  where
    keep d | unLoc :: Located e -> eunLoc (con_name :: ConDecl name -> Located namecon_name d :: TyClDecl Named) elem :: Eq a => a -> [a] -> Bool`elem` names :: [Name]names =
      case con_details :: ConDecl name -> HsConDeclDetails namecon_details d :: TyClDecl Named of
        PrefixCon _ -> Just :: a -> Maybe aJust d :: TyClDecl Named
        RecCon fields
          | all :: (a -> Bool) -> [a] -> Boolall field_avail :: ConDeclField Name -> Boolfield_avail fields :: [ConDeclField Name]fields -> Just :: a -> Maybe aJust d :: TyClDecl Named
          | otherwise :: Boolotherwise -> Just :: a -> Maybe aJust (d :: TyClDecl Named { con_details = PrefixCon :: [arg] -> HsConDetails arg recPrefixCon (field_types :: [ConDeclField t] -> [LBangType t]field_types fields :: [ConDeclField Name]fields) })
          -- if we have *all* the field names available, then
          -- keep the record declaration.  Otherwise degrade to
          -- a constructor declaration.  This isn't quite right, but
          -- it's the best we can do.
        InfixCon _ _ -> Just :: a -> Maybe aJust d :: TyClDecl Named
      where
        field_avail (ConDeclField n _ _) = unLoc :: Located e -> eunLoc n :: Located Namen elem :: Eq a => a -> [a] -> Bool`elem` names :: [Name]names
        field_types flds = [ t :: LBangType tt | ConDeclField _ t _ <- flds :: [ConDeclField t]flds ]

    keep _ | otherwise :: Boolotherwise = Nothing :: Maybe aNothing


restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
restrictDecls names decls = filter :: (a -> Bool) -> [a] -> [a]filter keep :: ConDecl Name -> Maybe (ConDecl Name)keep decls :: [LConDecl Name]decls
  where keep d = fromJust :: Maybe a -> afromJust (sigName :: LSig name -> Maybe namesigName d :: TyClDecl Named) elem :: Eq a => a -> [a] -> Bool`elem` names :: [Name]names
        -- has to have a name, since it's a class method type signature


restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
restrictATs names ats = [ at :: LTyClDecl Nameat | at <- ats :: [LTyClDecl Name]ats , tcdName :: TyClDecl name -> nametcdName (unL :: Located a -> aunL at :: LTyClDecl Nameat) elem :: Eq a => a -> [a] -> Bool`elem` names :: [Name]names ]


--------------------------------------------------------------------------------
-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
--------------------------------------------------------------------------------


moduleHtmlFile :: Module -> FilePath
moduleHtmlFile mdl =
  case lookup :: Ord k => k -> Map k a -> Maybe aMap.lookup mdl :: Modulemdl html_xrefs :: Map Module FilePathhtml_xrefs of
    Nothing  -> mdl' :: [Char]mdl' (++) :: [a] -> [a] -> [a]++ ".html"
    Just fp0 -> joinPath :: [FilePath] -> FilePathHtmlPath.joinPath [fp0 :: FilePathfp0, mdl' :: [Char]mdl' (++) :: [a] -> [a] -> [a]++ ".html"]
  where
   mdl' = map :: (a -> b) -> [a] -> [b]map (\c -> if c :: Charc (==) :: Eq a => a -> a -> Bool== '.' then '-' else c :: Charc)
              (moduleNameString :: ModuleName -> StringmoduleNameString (moduleName :: Module -> ModuleNamemoduleName mdl :: Modulemdl))



contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"


-- | The name of the module index file to be displayed inside a frame.
-- Modules are display in full, but without indentation.  Clicking opens in
-- the main window.
frameIndexHtmlFile :: String
frameIndexHtmlFile = "index-frames.html"


moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
moduleIndexFrameName = "modules"
mainFrameName = "main"
synopsisFrameName = "synopsis"


subIndexHtmlFile :: String -> String
subIndexHtmlFile ls = "doc-index-" (++) :: [a] -> [a] -> [a]++ b :: Stringb (++) :: [a] -> [a] -> [a]++ ".html"
   where b | all :: (a -> Bool) -> [a] -> Boolall isAlpha :: Char -> BoolisAlpha ls :: Stringls = ls :: Stringls
           | otherwise :: Boolotherwise = concatMap :: (a -> [b]) -> [a] -> [b]concatMap (show :: Show a => a -> Stringshow (.) :: (b -> c) -> (a -> b) -> a -> c. ord :: Char -> Intord) ls :: Stringls


-------------------------------------------------------------------------------
-- * Anchor and URL utilities
--
-- NB: Anchor IDs, used as the destination of a link within a document must
-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's
-- various needs and compatibility constraints, means these IDs have to match:
--      [A-Za-z][A-Za-z0-9:_.-]*
-- Such IDs do not need to be escaped in any way when used as the fragment part
-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it
-- isn't clear if such fragment identifiers should, or should not be unescaped
-- before being matched with IDs in the target document.
-------------------------------------------------------------------------------
 

moduleUrl :: Module -> String
moduleUrl = moduleHtmlFile :: Module -> FilePathmoduleHtmlFile


moduleNameUrl :: Module -> OccName -> String
moduleNameUrl mdl n = moduleUrl :: Module -> StringmoduleUrl mdl :: Modulemdl (++) :: [a] -> [a] -> [a]++ '#' (:) :: a -> [a] -> [a]: nameAnchorId :: OccName -> StringnameAnchorId n :: Located Namen


nameAnchorId :: OccName -> String
nameAnchorId name = makeAnchorId :: String -> StringmakeAnchorId (prefix :: Charprefix (:) :: a -> [a] -> [a]: ':' (:) :: a -> [a] -> [a]: occNameString :: OccName -> StringoccNameString name :: OccNamename)
 where prefix | isValOcc :: OccName -> BoolisValOcc name :: OccNamename = 'v'
              | otherwise :: Boolotherwise     = 't'


-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
-- identity preserving.
makeAnchorId :: String -> String
makeAnchorId [] = [] :: [a][]
makeAnchorId (f:r) = escape :: (Char -> Bool) -> Char -> [Char]escape isAlpha :: Char -> BoolisAlpha f :: Charf (++) :: [a] -> [a] -> [a]++ concatMap :: (a -> [b]) -> [a] -> [b]concatMap (escape :: (Char -> Bool) -> Char -> [Char]escape isLegal :: Char -> BoolisLegal) r :: [Char]r
  where
    escape p c | p :: SrcSpanp c :: Charc = [c :: Charc]
               | otherwise :: Boolotherwise = '-' (:) :: a -> [a] -> [a]: show :: Show a => a -> Stringshow (ord :: Char -> Intord c :: Charc) (++) :: [a] -> [a] -> [a]++ "-"
    isLegal ':' = True :: BoolTrue
    isLegal '_' = True :: BoolTrue
    isLegal '.' = True :: BoolTrue
    isLegal c = isAscii :: Char -> BoolisAscii c :: Charc (&&) :: Bool -> Bool -> Bool&& isAlphaNum :: Char -> BoolisAlphaNum c :: Charc
       -- NB: '-' is legal in IDs, but we use it as the escape char


-------------------------------------------------------------------------------
-- * Files we need to copy from our $libdir
-------------------------------------------------------------------------------


jsFile, framesFile :: String
jsFile    = "haddock-util.js"
framesFile = "frames.html"


-------------------------------------------------------------------------------
-- * Misc. 
-------------------------------------------------------------------------------


getProgramName :: IO String
getProgramName = liftM :: Monad m => (a1 -> r) -> m a1 -> m rliftM (withoutSuffix :: [a] -> [a] -> [a]`withoutSuffix` ".bin") getProgName :: IO StringgetProgName
   where str `withoutSuffix` suff
            | suff :: [a]suff isSuffixOf :: Eq a => [a] -> [a] -> Bool`isSuffixOf` str :: [a]str = take :: Int -> [a] -> [a]take (length :: [a] -> Intlength str :: [a]str (-) :: Num a => a -> a -> a- length :: [a] -> Intlength suff :: [a]suff) str :: [a]str
            | otherwise :: Boolotherwise             = str :: [a]str


bye :: String -> IO a
bye s = putStr :: String -> IO ()putStr s :: Strings (>>) :: Monad m => forall a b. m a -> m b -> m b>> exitWith :: ExitCode -> IO aexitWith ExitSuccess :: ExitCodeExitSuccess


die :: String -> IO a
die s = hPutStr :: Handle -> String -> IO ()hPutStr stderr :: Handlestderr s :: Strings (>>) :: Monad m => forall a b. m a -> m b -> m b>> exitWith :: ExitCode -> IO aexitWith (ExitFailure :: Int -> ExitCodeExitFailure 1)


dieMsg :: String -> IO a
dieMsg s = getProgramName :: IO StringgetProgramName (>>=) :: Monad m => forall a b. m a -> (a -> m b) -> m b>>= \prog -> die :: String -> IO adie (prog :: Stringprog (++) :: [a] -> [a] -> [a]++ ": " (++) :: [a] -> [a] -> [a]++ s :: Strings)


noDieMsg :: String -> IO ()
noDieMsg s = getProgramName :: IO StringgetProgramName (>>=) :: Monad m => forall a b. m a -> (a -> m b) -> m b>>= \prog -> hPutStr :: Handle -> String -> IO ()hPutStr stderr :: Handlestderr (prog :: Stringprog (++) :: [a] -> [a] -> [a]++ ": " (++) :: [a] -> [a] -> [a]++ s :: Strings)


mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
mapSnd _ [] = [] :: [a][]
mapSnd f ((x,y):xs) = (x :: ax,f :: Charf y :: by) (:) :: a -> [a] -> [a]: mapSnd :: (b -> c) -> [(a, b)] -> [(a, c)]mapSnd f :: Charf xs :: [(a, b)]xs


mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
mapMaybeM _ Nothing = return :: Monad m => forall a. a -> m areturn Nothing :: Maybe aNothing
mapMaybeM f (Just a) = liftM :: Monad m => (a1 -> r) -> m a1 -> m rliftM Just :: a -> Maybe aJust (f :: Charf a :: aa)


escapeStr :: String -> String
escapeStr = escapeURIString :: (Char -> Bool) -> String -> StringescapeURIString isUnreserved :: Char -> BoolisUnreserved


-- Following few functions are copy'n'pasted from Network.URI module
-- to avoid depending on the network lib, since doing so gives a
-- circular build dependency between haddock and network
-- (at least if you want to build network with haddock docs)
-- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs
escapeURIChar :: (Char -> Bool) -> Char -> String
escapeURIChar p c
    | p :: SrcSpanp c :: Charc       = [c :: Charc]
    | otherwise :: Boolotherwise = '%' (:) :: a -> [a] -> [a]: myShowHex :: Int -> ShowSmyShowHex (ord :: Char -> Intord c :: Charc) ""
    where
        myShowHex :: Int -> ShowS
        myShowHex n r =  case showIntAtBase :: Integral a => a -> (Int -> Char) -> a -> ShowSshowIntAtBase 16 toChrHex :: Integral a => a -> ChartoChrHex n :: Located Namen r :: [Char]r of
            []  -> "00"
            [a] -> ['0',a :: aa]
            cs  -> cs :: Stringcs
        toChrHex d
            | d :: TyClDecl Named (<) :: Ord a => a -> a -> Bool< 10    = chr :: Int -> Charchr (ord :: Char -> Intord '0' (+) :: Num a => a -> a -> a+ fromIntegral :: (Integral a, Num b) => a -> bfromIntegral d :: TyClDecl Named)
            | otherwise :: Boolotherwise = chr :: Int -> Charchr (ord :: Char -> Intord 'A' (+) :: Num a => a -> a -> a+ fromIntegral :: (Integral a, Num b) => a -> bfromIntegral (d :: TyClDecl Named (-) :: Num a => a -> a -> a- 10))


escapeURIString :: (Char -> Bool) -> String -> String
escapeURIString = concatMap :: (a -> [b]) -> [a] -> [b]concatMap (.) :: (b -> c) -> (a -> b) -> a -> c. escapeURIChar :: (Char -> Bool) -> Char -> StringescapeURIChar


isUnreserved :: Char -> Bool
isUnreserved c = isAlphaNumChar :: Char -> BoolisAlphaNumChar c :: Charc (||) :: Bool -> Bool -> Bool|| (c :: Charc elem :: Eq a => a -> [a] -> Bool`elem` "-_.~")


isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool
isAlphaChar c    = (c :: Charc (>=) :: Ord a => a -> a -> Bool>= 'A' (&&) :: Bool -> Bool -> Bool&& c :: Charc (<=) :: Ord a => a -> a -> Bool<= 'Z') (||) :: Bool -> Bool -> Bool|| (c :: Charc (>=) :: Ord a => a -> a -> Bool>= 'a' (&&) :: Bool -> Bool -> Bool&& c :: Charc (<=) :: Ord a => a -> a -> Bool<= 'z')
isDigitChar c    = c :: Charc (>=) :: Ord a => a -> a -> Bool>= '0' (&&) :: Bool -> Bool -> Bool&& c :: Charc (<=) :: Ord a => a -> a -> Bool<= '9'
isAlphaNumChar c = isAlphaChar :: Char -> BoolisAlphaChar c :: Charc (||) :: Bool -> Bool -> Bool|| isDigitChar :: Char -> BoolisDigitChar c :: Charc


-----------------------------------------------------------------------------
-- * HTML cross references
--
-- For each module, we need to know where its HTML documentation lives
-- so that we can point hyperlinks to it.  It is extremely
-- inconvenient to plumb this information to all the places that need
-- it (basically every function in HaddockHtml), and furthermore the
-- mapping is constant for any single run of Haddock.  So for the time
-- being I'm going to use a write-once global variable.
-----------------------------------------------------------------------------


{-# NOINLINE html_xrefs_ref #-}
html_xrefs_ref :: IORef (Map Module FilePath)
html_xrefs_ref = unsafePerformIO :: IO a -> aunsafePerformIO (newIORef :: a -> IO (IORef a)newIORef (error :: [Char] -> aerror "module_map"))


{-# NOINLINE html_xrefs #-}
html_xrefs :: Map Module FilePath
html_xrefs = unsafePerformIO :: IO a -> aunsafePerformIO (readIORef :: IORef a -> IO areadIORef html_xrefs_ref :: IORef (Map Module FilePath)html_xrefs_ref)


-----------------------------------------------------------------------------
-- * List utils
-----------------------------------------------------------------------------


replace :: Eq a => a -> a -> [a] -> [a]
replace a b = map :: (a -> b) -> [a] -> [b]map (\x -> if x :: ax (==) :: Eq a => a -> a -> Bool== a :: aa then b :: Stringb else x :: ax)


spanWith :: (a -> Maybe b) -> [a] -> ([b],[a])
spanWith _ [] = ([] :: [a][],[] :: [a][])
spanWith p xs@(a:as)
  | Just b <- p :: SrcSpanp a :: aa = let (bs,cs) = spanWith :: (a -> Maybe b) -> [a] -> ([b], [a])spanWith p :: SrcSpanp as :: [a]as in (b :: Stringb(:) :: a -> [a] -> [a]:bs :: [b]bs,cs :: Stringcs)
  | otherwise :: Boolotherwise     = ([] :: [a][],xs :: [(a, b)]xs)


-----------------------------------------------------------------------------
-- * Put here temporarily
-----------------------------------------------------------------------------


markup :: DocMarkup id a -> Doc id -> a
markup m DocEmpty              = markupEmpty :: DocMarkup id a -> amarkupEmpty m :: DocMarkup id am
markup m (DocAppend d1 d2)     = markupAppend :: DocMarkup id a -> a -> a -> amarkupAppend m :: DocMarkup id am (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am d1 :: Doc idd1) (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am d2 :: Doc idd2)
markup m (DocString s)         = markupString :: DocMarkup id a -> String -> amarkupString m :: DocMarkup id am s :: Strings
markup m (DocParagraph d)      = markupParagraph :: DocMarkup id a -> a -> amarkupParagraph m :: DocMarkup id am (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am d :: TyClDecl Named)
markup m (DocIdentifier ids)   = markupIdentifier :: DocMarkup id a -> [id] -> amarkupIdentifier m :: DocMarkup id am ids :: [id]ids
markup m (DocModule mod0)      = markupModule :: DocMarkup id a -> String -> amarkupModule m :: DocMarkup id am mod0 :: Stringmod0
markup m (DocEmphasis d)       = markupEmphasis :: DocMarkup id a -> a -> amarkupEmphasis m :: DocMarkup id am (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am d :: TyClDecl Named)
markup m (DocMonospaced d)     = markupMonospaced :: DocMarkup id a -> a -> amarkupMonospaced m :: DocMarkup id am (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am d :: TyClDecl Named)
markup m (DocUnorderedList ds) = markupUnorderedList :: DocMarkup id a -> [a] -> amarkupUnorderedList m :: DocMarkup id am (map :: (a -> b) -> [a] -> [b]map (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am) ds :: [(Doc id, Doc id)]ds)
markup m (DocOrderedList ds)   = markupOrderedList :: DocMarkup id a -> [a] -> amarkupOrderedList m :: DocMarkup id am (map :: (a -> b) -> [a] -> [b]map (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am) ds :: [(Doc id, Doc id)]ds)
markup m (DocDefList ds)       = markupDefList :: DocMarkup id a -> [(a, a)] -> amarkupDefList m :: DocMarkup id am (map :: (a -> b) -> [a] -> [b]map (markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)markupPair m :: DocMarkup id am) ds :: [(Doc id, Doc id)]ds)
markup m (DocCodeBlock d)      = markupCodeBlock :: DocMarkup id a -> a -> amarkupCodeBlock m :: DocMarkup id am (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am d :: TyClDecl Named)
markup m (DocURL url)          = markupURL :: DocMarkup id a -> String -> amarkupURL m :: DocMarkup id am url :: Stringurl
markup m (DocAName ref)        = markupAName :: DocMarkup id a -> String -> amarkupAName m :: DocMarkup id am ref :: Stringref
markup m (DocPic img)          = markupPic :: DocMarkup id a -> String -> amarkupPic m :: DocMarkup id am img :: Stringimg
markup m (DocExamples e)       = markupExample :: DocMarkup id a -> [Example] -> amarkupExample m :: DocMarkup id am e :: [Example]e


markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
markupPair m (a,b) = (markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am a :: aa, markup :: DocMarkup id a -> Doc id -> amarkup m :: DocMarkup id am b :: Stringb)


-- | The identity markup
idMarkup :: DocMarkup a (Doc a)
idMarkup = Markup {
  markupEmpty         = DocEmpty :: Doc idDocEmpty,
  markupString        = DocString :: String -> Doc idDocString,
  markupParagraph     = DocParagraph :: Doc id -> Doc idDocParagraph,
  markupAppend        = DocAppend :: Doc id -> Doc id -> Doc idDocAppend,
  markupIdentifier    = DocIdentifier :: [id] -> Doc idDocIdentifier,
  markupModule        = DocModule :: String -> Doc idDocModule,
  markupEmphasis      = DocEmphasis :: Doc id -> Doc idDocEmphasis,
  markupMonospaced    = DocMonospaced :: Doc id -> Doc idDocMonospaced,
  markupUnorderedList = DocUnorderedList :: [Doc id] -> Doc idDocUnorderedList,
  markupOrderedList   = DocOrderedList :: [Doc id] -> Doc idDocOrderedList,
  markupDefList       = DocDefList :: [(Doc id, Doc id)] -> Doc idDocDefList,
  markupCodeBlock     = DocCodeBlock :: Doc id -> Doc idDocCodeBlock,
  markupURL           = DocURL :: String -> Doc idDocURL,
  markupAName         = DocAName :: String -> Doc idDocAName,
  markupPic           = DocPic :: String -> Doc idDocPic,
  markupExample       = DocExamples :: [Example] -> Doc idDocExamples
  }


-----------------------------------------------------------------------------
-- * System tools
-----------------------------------------------------------------------------


#ifdef mingw32_HOST_OS
foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
#else
getProcessID :: IO Int
getProcessID = fmap :: Functor f => forall a b. (a -> b) -> f a -> f bfmap fromIntegral :: (Integral a, Num b) => a -> bfromIntegral c_getpid :: IO CPidSystem.Posix.Internals.c_getpid
#endif