aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Types.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Types.hs')
-rw-r--r--haddock-api/src/Haddock/Types.hs56
1 files changed, 49 insertions, 7 deletions
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 74a17fbb..7fd11d69 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -34,13 +34,15 @@ module Haddock.Types (
, tell
) where
-import Control.Exception
import Control.DeepSeq
+import Control.Exception (throw)
+import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT)
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
+import Data.Void (Void)
import Documentation.Haddock.Types
import GHC.Types.Basic (PromotionFlag(..))
import GHC.Types.Fixity (Fixity(..))
@@ -291,6 +293,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty)
-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
+-- | An 'RdrName' tagged with some type/value namespace information.
+data NsRdrName = NsRdrName
+ { namespace :: !Namespace
+ , rdrName :: !RdrName
+ }
+
-- | Extends 'Name' with cross-reference information.
data DocName
= Documented Name Module
@@ -339,7 +347,30 @@ instance SetName DocName where
setName name' (Documented _ mdl) = Documented name' mdl
setName name' (Undocumented _) = Undocumented name'
+-- | Adds extra "wrapper" information to a name.
+--
+-- This is to work around the fact that most name types in GHC ('Name', 'RdrName',
+-- 'OccName', ...) don't include backticks or parens.
+data Wrap n
+ = Unadorned { unwrap :: n } -- ^ don't do anything to the name
+ | Parenthesized { unwrap :: n } -- ^ add parentheses around the name
+ | Backticked { unwrap :: n } -- ^ add backticks around the name
+ deriving (Show, Functor, Foldable, Traversable)
+
+-- | Useful for debugging
+instance Outputable n => Outputable (Wrap n) where
+ ppr (Unadorned n) = ppr n
+ ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ]
+ ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ]
+
+showWrapped :: (a -> String) -> Wrap a -> String
+showWrapped f (Unadorned n) = f n
+showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"
+showWrapped f (Backticked n) = "`" ++ f n ++ "`"
+instance HasOccName DocName where
+
+ occName = occName . getName
-----------------------------------------------------------------------------
-- * Instances
@@ -433,10 +464,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where
type LDoc id = Located (Doc id)
-type Doc id = DocH (ModuleName, OccName) id
-type MDoc id = MetaDoc (ModuleName, OccName) id
+type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id)
+type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id)
-type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
@@ -610,17 +641,28 @@ type ErrMsgM = Writer [ErrMsg]
-- | Haddock's own exception type.
-data HaddockException = HaddockException String deriving Typeable
+data HaddockException
+ = HaddockException String
+ | WithContext [String] SomeException
+ deriving Typeable
instance Show HaddockException where
show (HaddockException str) = str
-
+ show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se]
throwE :: String -> a
instance Exception HaddockException
throwE str = throw (HaddockException str)
+withExceptionContext :: MonadCatch m => String -> m a -> m a
+withExceptionContext ctxt =
+ handle (\ex ->
+ case ex of
+ HaddockException _ -> throwM $ WithContext [ctxt] (toException ex)
+ WithContext ctxts se -> throwM $ WithContext (ctxt:ctxts) se
+ ) .
+ handle (throwM . WithContext [ctxt])
-- In "Haddock.Interface.Create", we need to gather
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
@@ -671,7 +713,7 @@ type instance XOpTy DocNameI = NoExtField
type instance XParTy DocNameI = NoExtField
type instance XIParamTy DocNameI = NoExtField
type instance XKindSig DocNameI = NoExtField
-type instance XSpliceTy DocNameI = NoExtField
+type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy`
type instance XDocTy DocNameI = NoExtField
type instance XBangTy DocNameI = NoExtField
type instance XRecTy DocNameI = NoExtField