{-# 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 Control.Monad.IO.Class (MonadIO(..))
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 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 GhcRn]
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 GhcRn])
, ifaceDocMap :: !(DocMap Name)
, ifaceArgMap :: !(ArgMap Name)
, ifaceRnDocMap :: !(DocMap DocName)
, ifaceRnArgMap :: !(ArgMap DocName)
, ifaceFixMap :: !(Map Name Fixity)
, ifaceExportItems :: ![ExportItem GhcRn]
, ifaceRnExportItems :: ![ExportItem DocNameI]
, ifaceExports :: ![Name]
, ifaceVisibleExports :: ![Name]
, ifaceModuleAliases :: !AliasMap
, ifaceInstances :: ![ClsInst]
, ifaceFamInstances :: ![FamInst]
, ifaceOrphanInstances :: ![DocInstance GhcRn]
, ifaceRnOrphanInstances :: ![DocInstance DocNameI]
, 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]
, 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
, instFixMap = ifaceFixMap interface
}
data ExportItem name
= ExportDecl
{
expItemDecl :: !(LHsDecl name)
, expItemPats :: ![(HsDecl name, DocForDecl (IdP name))]
, expItemMbDoc :: !(DocForDecl (IdP name))
, expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))]
, expItemInstances :: ![DocInstance name]
, expItemFixities :: ![(IdP name, Fixity)]
, expItemSpliced :: !Bool
}
| ExportNoDecl
{ expItemName :: !(IdP name)
, expItemSubs :: ![IdP name]
}
| ExportGroup
{
expItemSectionLevel :: !Int
, expItemSectionId :: !String
, expItemSectionText :: !(Doc (IdP name))
}
| ExportDoc !(MDoc (IdP 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)
data DocNameI
type instance IdP DocNameI = DocName
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 (a ~ GhcPass p,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 (IdP name)
, pfdTyVars :: [LHsType name]
, pfdKindSig :: LFamilyResultSig name
}
mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)
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 NoExt tvar lkind
where
tvar = L loc (HsTyVar NoExt NotPromoted (L loc name))
mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name
mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl"
mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl"
type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module)
data InstHead name = InstHead
{ ihdClsName :: IdP 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
type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
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` ()
DocTable 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` ()
instance NFData id => NFData (Table id) where
rnf (Table h b) = h `deepseq` b `deepseq` ()
instance NFData id => NFData (TableRow id) where
rnf (TableRow cs) = cs `deepseq` ()
instance NFData id => NFData (TableCell id) where
rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` ()
exampleToString :: Example -> String
exampleToString (Example expression result) =
">>> " ++ expression ++ "\n" ++ unlines result
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
data HideEmptyContexts
= HideEmptyContexts
| ShowEmptyToplevelContexts
data SinceQual
= Always
| External
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))
instance MonadIO ErrMsgGhc where
liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
type instance XForAllTy DocNameI = NoExt
type instance XQualTy DocNameI = NoExt
type instance XTyVar DocNameI = NoExt
type instance XStarTy DocNameI = NoExt
type instance XAppTy DocNameI = NoExt
type instance XFunTy DocNameI = NoExt
type instance XListTy DocNameI = NoExt
type instance XTupleTy DocNameI = NoExt
type instance XSumTy DocNameI = NoExt
type instance XOpTy DocNameI = NoExt
type instance XParTy DocNameI = NoExt
type instance XIParamTy DocNameI = NoExt
type instance XKindSig DocNameI = NoExt
type instance XSpliceTy DocNameI = NoExt
type instance XDocTy DocNameI = NoExt
type instance XBangTy DocNameI = NoExt
type instance XRecTy DocNameI = NoExt
type instance XExplicitListTy DocNameI = NoExt
type instance XExplicitTupleTy DocNameI = NoExt
type instance XTyLit DocNameI = NoExt
type instance XWildCardTy DocNameI = HsWildCardInfo
type instance XXType DocNameI = NewHsTypeX
type instance XUserTyVar DocNameI = NoExt
type instance XKindedTyVar DocNameI = NoExt
type instance XXTyVarBndr DocNameI = NoExt
type instance XCFieldOcc DocNameI = DocName
type instance XXFieldOcc DocNameI = NoExt
type instance XFixitySig DocNameI = NoExt
type instance XFixSig DocNameI = NoExt
type instance XPatSynSig DocNameI = NoExt
type instance XClassOpSig DocNameI = NoExt
type instance XTypeSig DocNameI = NoExt
type instance XMinimalSig DocNameI = NoExt
type instance XForeignExport DocNameI = NoExt
type instance XForeignImport DocNameI = NoExt
type instance XConDeclGADT DocNameI = NoExt
type instance XConDeclH98 DocNameI = NoExt
type instance XDerivD DocNameI = NoExt
type instance XInstD DocNameI = NoExt
type instance XForD DocNameI = NoExt
type instance XSigD DocNameI = NoExt
type instance XTyClD DocNameI = NoExt
type instance XNoSig DocNameI = NoExt
type instance XCKindSig DocNameI = NoExt
type instance XTyVarSig DocNameI = NoExt
type instance XCFamEqn DocNameI _ _ = NoExt
type instance XCClsInstDecl DocNameI = NoExt
type instance XCDerivDecl DocNameI = NoExt
type instance XViaStrategy DocNameI = LHsSigType DocNameI
type instance XDataFamInstD DocNameI = NoExt
type instance XTyFamInstD DocNameI = NoExt
type instance XClsInstD DocNameI = NoExt
type instance XCHsDataDefn DocNameI = NoExt
type instance XCFamilyDecl DocNameI = NoExt
type instance XClassDecl DocNameI = NoExt
type instance XDataDecl DocNameI = NoExt
type instance XSynDecl DocNameI = NoExt
type instance XFamDecl DocNameI = NoExt
type instance XHsIB DocNameI _ = NoExt
type instance XHsWC DocNameI _ = NoExt
type instance XHsQTvs DocNameI = NoExt
type instance XConDeclField DocNameI = NoExt