{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Haddock.Types (
module Haddock.Types
, HsDocString, LHsDocString
, Fixity(..)
, module Documentation.Haddock.Types
) where
import Control.Exception
import Control.Arrow hiding ((<+>))
import Control.DeepSeq
import Data.Typeable
import Data.Map (Map)
import Data.Data (Data)
import qualified Data.Map as Map
import Documentation.Haddock.Types
import BasicTypes (Fixity(..))
import GHC hiding (NoLink)
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
import Coercion
import NameSet
import OccName
import Outputable
import Control.Applicative (Applicative(..))
import Control.Monad (ap)
import Haddock.Backends.Hyperlinker.Types
type IfaceMap = Map Module Interface
type InstIfaceMap = Map Module InstalledInterface
type DocMap a = Map Name (MDoc a)
type ArgMap a = Map Name (Map Int (MDoc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type InstMap = Map SrcSpan Name
type FixMap = Map Name Fixity
type DocPaths = (FilePath, Maybe FilePath)
data Interface = Interface
{
ifaceMod :: !Module
, ifaceIsSig :: !Bool
, ifaceOrigFilename :: !FilePath
, ifaceInfo :: !(HaddockModInfo Name)
, ifaceDoc :: !(Documentation Name)
, ifaceRnDoc :: !(Documentation DocName)
, ifaceOptions :: ![DocOption]
, ifaceDeclMap :: !(Map Name [LHsDecl Name])
, ifaceBundledPatSynMap :: !(Map Name [Name])
, ifaceDocMap :: !(DocMap Name)
, ifaceArgMap :: !(ArgMap Name)
, ifaceRnDocMap :: !(DocMap DocName)
, ifaceRnArgMap :: !(ArgMap DocName)
, ifaceSubMap :: !(Map Name [Name])
, ifaceFixMap :: !(Map Name Fixity)
, ifaceExportItems :: ![ExportItem Name]
, ifaceRnExportItems :: ![ExportItem DocName]
, ifaceExports :: ![Name]
, ifaceVisibleExports :: ![Name]
, ifaceModuleAliases :: !AliasMap
, ifaceInstances :: ![ClsInst]
, ifaceFamInstances :: ![FamInst]
, ifaceOrphanInstances :: ![DocInstance Name]
, ifaceRnOrphanInstances :: ![DocInstance DocName]
, ifaceHaddockCoverage :: !(Int, Int)
, ifaceWarningMap :: !WarningMap
, ifaceTokenizedSrc :: !(Maybe [RichToken])
}
type WarningMap = Map Name (Doc Name)
data InstalledInterface = InstalledInterface
{
instMod :: Module
, instIsSig :: Bool
, instInfo :: HaddockModInfo Name
, instDocMap :: DocMap Name
, instArgMap :: ArgMap Name
, instExports :: [Name]
, instVisibleExports :: [Name]
, instOptions :: [DocOption]
, instSubMap :: Map Name [Name]
, instBundledPatSynMap :: Map Name [Name]
, instFixMap :: Map Name Fixity
}
toInstalledIface :: Interface -> InstalledInterface
toInstalledIface interface = InstalledInterface
{ instMod = ifaceMod interface
, instIsSig = ifaceIsSig interface
, instInfo = ifaceInfo interface
, instDocMap = ifaceDocMap interface
, instArgMap = ifaceArgMap interface
, instExports = ifaceExports interface
, instVisibleExports = ifaceVisibleExports interface
, instOptions = ifaceOptions interface
, instSubMap = ifaceSubMap interface
, instBundledPatSynMap = ifaceBundledPatSynMap interface
, instFixMap = ifaceFixMap interface
}
data ExportItem name
= ExportDecl
{
expItemDecl :: !(LHsDecl name)
, expItemPats :: ![(HsDecl name, DocForDecl name)]
, expItemMbDoc :: !(DocForDecl name)
, expItemSubDocs :: ![(name, DocForDecl name)]
, expItemInstances :: ![DocInstance name]
, expItemFixities :: ![(name, Fixity)]
, expItemSpliced :: !Bool
}
| ExportNoDecl
{ expItemName :: !name
, expItemSubs :: ![name]
}
| ExportGroup
{
expItemSectionLevel :: !Int
, expItemSectionId :: !String
, expItemSectionText :: !(Doc name)
}
| ExportDoc !(MDoc name)
| ExportModule !Module
data Documentation name = Documentation
{ documentationDoc :: Maybe (MDoc name)
, documentationWarning :: !(Maybe (Doc name))
} deriving Functor
type FnArgsDoc name = Map Int (MDoc name)
type DocForDecl name = (Documentation name, FnArgsDoc name)
noDocForDecl :: DocForDecl name
noDocForDecl = (Documentation Nothing Nothing, Map.empty)
type LinkEnv = Map Name Module
data DocName
= Documented Name Module
| Undocumented Name
deriving (Eq, Data)
type instance PostRn DocName NameSet = PlaceHolder
type instance PostRn DocName Fixity = PlaceHolder
type instance PostRn DocName Bool = PlaceHolder
type instance PostRn DocName [Name] = PlaceHolder
type instance PostTc DocName Kind = PlaceHolder
type instance PostTc DocName Type = PlaceHolder
type instance PostTc DocName Coercion = PlaceHolder
instance NamedThing DocName where
getName (Documented name _) = name
getName (Undocumented name) = name
instance Outputable DocName where
ppr = ppr . getName
instance OutputableBndr DocName where
pprBndr _ = ppr . getName
pprPrefixOcc = pprPrefixOcc . getName
pprInfixOcc = pprInfixOcc . getName
class NamedThing name => SetName name where
setName :: Name -> name -> name
instance SetName Name where
setName name' _ = name'
instance SetName DocName where
setName name' (Documented _ mdl) = Documented name' mdl
setName name' (Undocumented _) = Undocumented name'
data InstType name
= ClassInst
{ clsiCtx :: [HsType name]
, clsiTyVars :: LHsQTyVars name
, clsiSigs :: [Sig name]
, clsiAssocTys :: [PseudoFamilyDecl name]
}
| TypeInst (Maybe (HsType name))
| DataInst (TyClDecl name)
instance (OutputableBndrId a)
=> Outputable (InstType a) where
ppr (ClassInst { .. }) = text "ClassInst"
<+> ppr clsiCtx
<+> ppr clsiTyVars
<+> ppr clsiSigs
ppr (TypeInst a) = text "TypeInst" <+> ppr a
ppr (DataInst a) = text "DataInst" <+> ppr a
data PseudoFamilyDecl name = PseudoFamilyDecl
{ pfdInfo :: FamilyInfo name
, pfdLName :: Located name
, pfdTyVars :: [LHsType name]
, pfdKindSig :: LFamilyResultSig name
}
mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
{ pfdInfo = fdInfo
, pfdLName = fdLName
, pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]
, pfdKindSig = fdResultSig
}
where
mkType (KindedTyVar (L loc name) lkind) =
HsKindSig tvar lkind
where
tvar = L loc (HsTyVar NotPromoted (L loc name))
mkType (UserTyVar name) = HsTyVar NotPromoted name
type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
data InstHead name = InstHead
{ ihdClsName :: name
, ihdKinds :: [HsType name]
, ihdTypes :: [HsType name]
, ihdInstType :: InstType name
}
data InstOrigin name
= OriginClass name
| OriginData name
| OriginFamily name
instance NamedThing name => NamedThing (InstOrigin name) where
getName (OriginClass name) = getName name
getName (OriginData name) = getName name
getName (OriginFamily name) = getName name
type LDoc id = Located (Doc id)
type Doc id = DocH (ModuleName, OccName) id
type MDoc id = MetaDoc (ModuleName, OccName) id
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
rnf doc = case doc of
DocEmpty -> ()
DocAppend a b -> a `deepseq` b `deepseq` ()
DocString a -> a `deepseq` ()
DocParagraph a -> a `deepseq` ()
DocIdentifier a -> a `deepseq` ()
DocIdentifierUnchecked a -> a `deepseq` ()
DocModule a -> a `deepseq` ()
DocWarning a -> a `deepseq` ()
DocEmphasis a -> a `deepseq` ()
DocBold a -> a `deepseq` ()
DocMonospaced a -> a `deepseq` ()
DocUnorderedList a -> a `deepseq` ()
DocOrderedList a -> a `deepseq` ()
DocDefList a -> a `deepseq` ()
DocCodeBlock a -> a `deepseq` ()
DocHyperlink a -> a `deepseq` ()
DocPic a -> a `deepseq` ()
DocMathInline a -> a `deepseq` ()
DocMathDisplay a -> a `deepseq` ()
DocAName a -> a `deepseq` ()
DocProperty a -> a `deepseq` ()
DocExamples a -> a `deepseq` ()
DocHeader a -> a `deepseq` ()
#if !MIN_VERSION_ghc(8,0,2)
instance NFData Name where rnf x = seq x ()
instance NFData OccName where rnf x = seq x ()
instance NFData ModuleName where rnf x = seq x ()
#endif
instance NFData id => NFData (Header id) where
rnf (Header a b) = a `deepseq` b `deepseq` ()
instance NFData Hyperlink where
rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
instance NFData Picture where
rnf (Picture a b) = a `deepseq` b `deepseq` ()
instance NFData Example where
rnf (Example a b) = a `deepseq` b `deepseq` ()
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
, markupBold :: 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 :: Picture -> a
, markupMathInline :: String -> a
, markupMathDisplay :: String -> a
, markupProperty :: String -> a
, markupExample :: [Example] -> a
, markupHeader :: Header a -> a
}
data HaddockModInfo name = HaddockModInfo
{ hmi_description :: Maybe (Doc name)
, hmi_copyright :: Maybe String
, hmi_license :: Maybe String
, hmi_maintainer :: Maybe String
, hmi_stability :: Maybe String
, hmi_portability :: Maybe String
, hmi_safety :: Maybe String
, hmi_language :: Maybe Language
, hmi_extensions :: [LangExt.Extension]
}
emptyHaddockModInfo :: HaddockModInfo a
emptyHaddockModInfo = HaddockModInfo
{ hmi_description = Nothing
, hmi_copyright = Nothing
, hmi_license = Nothing
, hmi_maintainer = Nothing
, hmi_stability = Nothing
, hmi_portability = Nothing
, hmi_safety = Nothing
, hmi_language = Nothing
, hmi_extensions = []
}
data DocOption
= OptHide
| OptPrune
| OptIgnoreExports
| OptNotHome
| OptShowExtensions
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 Applicative ErrMsgM where
pure a = Writer (a, [])
(<*>) = ap
instance Monad ErrMsgM where
return = pure
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 Applicative ErrMsgGhc where
pure a = WriterGhc (return (a, []))
(<*>) = ap
instance Monad ErrMsgGhc where
return = pure
m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
fmap (second (msgs1 ++)) (runWriterGhc (k a))
type instance PostRn DocName NameSet = PlaceHolder
type instance PostRn DocName Fixity = PlaceHolder
type instance PostRn DocName Bool = PlaceHolder
type instance PostRn DocName Name = DocName
type instance PostRn DocName (Located Name) = Located DocName
type instance PostRn DocName [Name] = PlaceHolder
type instance PostRn DocName DocName = DocName
type instance PostTc DocName Kind = PlaceHolder
type instance PostTc DocName Type = PlaceHolder
type instance PostTc DocName Coercion = PlaceHolder