module Haddock.Types (
module Haddock.Types
, HsDocString, LHsDocString
) where
import Control.Exception
import Control.Arrow
import Data.Typeable
import Data.Map (Map)
import Data.Maybe
import qualified Data.Map as Map
import Data.Monoid
import GHC hiding (NoLink)
import OccName
type IfaceMap = Map Module Interface
type InstIfaceMap = Map Module InstalledInterface
type DocMap a = Map Name (Doc a)
type ArgMap a = Map Name (Map Int (Doc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type SrcMap = Map PackageId FilePath
type DocPaths = (FilePath, Maybe FilePath)
data Interface = Interface
{
ifaceMod :: !Module
, ifaceOrigFilename :: !FilePath
, ifaceInfo :: !(HaddockModInfo Name)
, ifaceDoc :: !(Documentation Name)
, ifaceRnDoc :: !(Documentation DocName)
, ifaceOptions :: ![DocOption]
, ifaceDeclMap :: !(Map Name [LHsDecl Name])
, ifaceDocMap :: !(DocMap Name)
, ifaceArgMap :: !(ArgMap Name)
, ifaceRnDocMap :: !(DocMap DocName)
, ifaceRnArgMap :: !(ArgMap DocName)
, ifaceSubMap :: !(Map Name [Name])
, ifaceExportItems :: ![ExportItem Name]
, ifaceRnExportItems :: ![ExportItem DocName]
, ifaceExports :: ![Name]
, ifaceVisibleExports :: ![Name]
, ifaceModuleAliases :: !AliasMap
, ifaceInstances :: ![ClsInst]
, ifaceHaddockCoverage :: !(Int, Int)
}
data InstalledInterface = InstalledInterface
{
instMod :: Module
, instInfo :: HaddockModInfo Name
, instDocMap :: DocMap Name
, instArgMap :: ArgMap Name
, instExports :: [Name]
, instVisibleExports :: [Name]
, instOptions :: [DocOption]
, instSubMap :: Map Name [Name]
}
toInstalledIface :: Interface -> InstalledInterface
toInstalledIface interface = InstalledInterface
{ instMod = ifaceMod interface
, instInfo = ifaceInfo interface
, instDocMap = ifaceDocMap interface
, instArgMap = ifaceArgMap interface
, instExports = ifaceExports interface
, instVisibleExports = ifaceVisibleExports interface
, instOptions = ifaceOptions interface
, instSubMap = ifaceSubMap interface
}
data ExportItem name
= ExportDecl
{
expItemDecl :: !(LHsDecl name)
, expItemMbDoc :: !(DocForDecl name)
, expItemSubDocs :: ![(name, DocForDecl name)]
, expItemInstances :: ![DocInstance name]
}
| ExportNoDecl
{ expItemName :: !name
, expItemSubs :: ![name]
}
| ExportGroup
{
expItemSectionLevel :: !Int
, expItemSectionId :: !String
, expItemSectionText :: !(Doc name)
}
| ExportDoc !(Doc name)
| ExportModule !Module
data Documentation name = Documentation
{ documentationDoc :: Maybe (Doc name)
, documentationWarning :: !(Maybe (Doc name))
} deriving Functor
combineDocumentation :: Documentation name -> Maybe (Doc name)
combineDocumentation (Documentation Nothing Nothing) = Nothing
combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc)
type FnArgsDoc name = Map Int (Doc name)
type DocForDecl name = (Documentation name, FnArgsDoc name)
noDocForDecl :: DocForDecl name
noDocForDecl = (Documentation Nothing Nothing, Map.empty)
unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
unrenameDocForDecl (doc, fnArgsDoc) =
(fmap getName doc, (fmap . fmap) getName fnArgsDoc)
type LinkEnv = Map Name Module
data DocName
= Documented Name Module
| Undocumented Name
deriving Eq
instance NamedThing DocName where
getName (Documented name _) = name
getName (Undocumented name) = name
type DocInstance name = (InstHead name, Maybe (Doc name))
type InstHead name = ([HsType name], name, [HsType name])
type LDoc id = Located (Doc id)
data Doc id
= DocEmpty
| DocAppend (Doc id) (Doc id)
| DocString String
| DocParagraph (Doc id)
| DocIdentifier id
| DocIdentifierUnchecked (ModuleName, OccName)
| DocModule String
| DocWarning (Doc id)
| DocEmphasis (Doc id)
| DocMonospaced (Doc id)
| DocUnorderedList [Doc id]
| DocOrderedList [Doc id]
| DocDefList [(Doc id, Doc id)]
| DocCodeBlock (Doc id)
| DocHyperlink Hyperlink
| DocPic String
| DocAName String
| DocProperty String
| DocExamples [Example]
deriving (Functor)
instance Monoid (Doc id) where
mempty = DocEmpty
mappend = DocAppend
data Hyperlink = Hyperlink
{ hyperlinkUrl :: String
, hyperlinkLabel :: Maybe String
} deriving (Eq, Show)
data Example = Example
{ exampleExpression :: String
, exampleResult :: [String]
} deriving (Eq, Show)
exampleToString :: Example -> String
exampleToString (Example expression result) =
">>> " ++ expression ++ "\n" ++ unlines result
data DocMarkup id a = Markup
{ markupEmpty :: a
, markupString :: String -> a
, markupParagraph :: a -> a
, markupAppend :: a -> a -> a
, markupIdentifier :: id -> a
, markupIdentifierUnchecked :: (ModuleName, OccName) -> a
, markupModule :: String -> a
, markupWarning :: a -> a
, markupEmphasis :: a -> a
, markupMonospaced :: a -> a
, markupUnorderedList :: [a] -> a
, markupOrderedList :: [a] -> a
, markupDefList :: [(a,a)] -> a
, markupCodeBlock :: a -> a
, markupHyperlink :: Hyperlink -> a
, markupAName :: String -> a
, markupPic :: String -> a
, markupProperty :: String -> a
, markupExample :: [Example] -> a
}
data HaddockModInfo name = HaddockModInfo
{ hmi_description :: (Maybe (Doc name))
, hmi_portability :: (Maybe String)
, hmi_stability :: (Maybe String)
, hmi_maintainer :: (Maybe String)
, hmi_safety :: (Maybe String)
}
emptyHaddockModInfo :: HaddockModInfo a
emptyHaddockModInfo = HaddockModInfo
{ hmi_description = Nothing
, hmi_portability = Nothing
, hmi_stability = Nothing
, hmi_maintainer = Nothing
, hmi_safety = Nothing
}
data DocOption
= OptHide
| OptPrune
| OptIgnoreExports
| OptNotHome
deriving (Eq, Show)
data QualOption
= OptNoQual
| OptFullQual
| OptLocalQual
| OptRelativeQual
| OptAliasedQual
type AliasMap = Map Module ModuleName
data Qualification
= NoQual
| FullQual
| LocalQual Module
| RelativeQual Module
| AliasedQual AliasMap Module
makeContentsQual :: QualOption -> Qualification
makeContentsQual qual =
case qual of
OptNoQual -> NoQual
_ -> FullQual
makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
makeModuleQual qual aliases mdl =
case qual of
OptLocalQual -> LocalQual mdl
OptRelativeQual -> RelativeQual mdl
OptAliasedQual -> AliasedQual aliases mdl
OptFullQual -> FullQual
OptNoQual -> NoQual
type ErrMsg = String
newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
instance Functor ErrMsgM where
fmap f (Writer (a, msgs)) = Writer (f a, msgs)
instance Monad ErrMsgM where
return a = Writer (a, [])
m >>= k = Writer $ let
(a, w) = runWriter m
(b, w') = runWriter (k a)
in (b, w ++ w')
tell :: [ErrMsg] -> ErrMsgM ()
tell w = Writer ((), w)
data HaddockException = HaddockException String deriving Typeable
instance Show HaddockException where
show (HaddockException str) = str
throwE :: String -> a
instance Exception HaddockException
throwE str = throw (HaddockException str)
newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
liftErrMsg = WriterGhc . return . runWriter
instance Functor ErrMsgGhc where
fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
instance Monad ErrMsgGhc where
return a = WriterGhc (return (a, []))
m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
fmap (second (msgs1 ++)) (runWriterGhc (k a))