aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Convert.hs275
-rw-r--r--src/Haddock/Interface.hs4
-rw-r--r--src/Haddock/Interface/Create.hs49
-rw-r--r--src/Haddock/Types.hs43
4 files changed, 360 insertions, 11 deletions
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
new file mode 100644
index 00000000..f5a200a9
--- /dev/null
+++ b/src/Haddock/Convert.hs
@@ -0,0 +1,275 @@
+
+-- This functionality may be moved into GHC at some point, and then
+-- we can use the GHC version (#if GHC version is new enough).
+module Haddock.Convert ( tyThingToHsSynSig {- :: TyThing -> LHsDecl Name -} )
+ where
+
+import HsSyn
+import TcType ( tcSplitSigmaTy )
+import TypeRep
+import Type ( splitKindFunTys )
+import Name
+import HscTypes
+import Var
+import Class
+import TyCon
+import DataCon
+import Id
+import BasicTypes
+import TysPrim ( alphaTyVars )
+import Bag ( emptyBag )
+import SrcLoc ( Located, noLoc )
+import Maybe
+
+-- the main function here! yay!
+tyThingToHsSynSig :: TyThing -> LHsDecl Name
+-- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
+-- Including built-in functions like seq.
+-- foreign-imported functions could be represented with ForD
+-- instead of SigD if we wanted...
+tyThingToHsSynSig (AnId i) = noLoc $
+ -- in a future code version we could turn idVarDetails = foreign-call
+ -- into a ForD instead of a SigD if we wanted. Haddock doesn't
+ -- need to care.
+ SigD (synifyIdSig ImplicitizeForAll i)
+-- type-constructors (e.g. Maybe) are complicated, put the definition
+-- later in the file (also it's used for class associated-types too.)
+tyThingToHsSynSig (ATyCon tc) = noLoc $
+ TyClD (synifyTyCon tc)
+-- a data-constructor alone just gets rendered as a function:
+tyThingToHsSynSig (ADataCon dc) = noLoc $
+ SigD (TypeSig (synifyName dc)
+ (synifyType ImplicitizeForAll (dataConUserType dc)))
+-- classes are just a little tedious
+tyThingToHsSynSig (AClass cl) = noLoc $
+ TyClD $ ClassDecl
+ (synifyCtx (classSCTheta cl))
+ (synifyName cl)
+ (synifyTyVars (classTyVars cl))
+ (map (\ (l,r) -> noLoc
+ (map getName l, map getName r) ) $
+ snd $ classTvsFds cl)
+ (map (\i -> noLoc $ synifyIdSig DeleteTopLevelQuantification i)
+ (classMethods cl))
+ emptyBag --ignore default method definitions, they don't affect signature
+ (map synifyClassAT (classATs cl))
+ [] --we don't have any docs at this point
+
+-- class associated-types are a subset of TyCon
+-- (mainly only type/data-families)
+synifyClassAT :: TyCon -> LTyClDecl Name
+synifyClassAT tc = noLoc $ synifyTyCon tc
+
+synifyTyCon :: TyCon -> TyClDecl Name
+synifyTyCon tc
+ | isFunTyCon tc || isPrimTyCon tc =
+ TyData
+ -- arbitrary lie, they are neither algebraic data nor newtype:
+ DataType
+ -- no built-in type has any stupidTheta:
+ (noLoc [])
+ (synifyName tc)
+ -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+ (zipWith
+ (\fakeTyVar realKind -> noLoc $
+ KindedTyVar (getName fakeTyVar) realKind)
+ alphaTyVars --a, b, c... which are unfortunately all kind *
+ (fst . splitKindFunTys $ tyConKind tc)
+ )
+ -- assume primitive types aren't members of data/newtype families:
+ Nothing
+ -- we have their kind accurately:
+ (Just (tyConKind tc))
+ -- no algebraic constructors:
+ []
+ -- "deriving" needn't be specified:
+ Nothing
+ | isOpenSynTyCon tc =
+ case synTyConRhs tc of
+ OpenSynTyCon rhs_kind _ ->
+ TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ (Just rhs_kind)
+ _ -> error "synifyTyCon: impossible open type synonym?"
+ | isOpenTyCon tc = --(why no "isOpenAlgTyCon"?)
+ case algTyConRhs tc of
+ OpenTyCon _ ->
+ TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ Nothing --always kind '*'
+ _ -> error "synifyTyCon: impossible open data type?"
+ | otherwise =
+ -- (closed) type, newtype, and data
+ let
+ -- alg_ only applies to newtype/data
+ -- syn_ only applies to type
+ -- others apply to both
+ alg_nd = if isNewTyCon tc then NewType else DataType
+ alg_ctx = synifyCtx (tyConStupidTheta tc)
+ name = synifyName tc
+ tyvars = synifyTyVars (tyConTyVars tc)
+ typats = case tyConFamInst_maybe tc of
+ Nothing -> Nothing
+ Just (_, indexes) -> Just (map (synifyType WithinType) indexes)
+ alg_kindSig = Just (tyConKind tc)
+ -- The data constructors.
+ --
+ -- Any data-constructors not exported from the module that *defines* the
+ -- type will not (cannot) be included.
+ --
+ -- Very simple constructors, Haskell98 with no existentials or anything,
+ -- probably look nicer in non-GADT syntax. In source code, all constructors
+ -- must be declared with the same (GADT vs. not) syntax, and it probably
+ -- is less confusing to follow that principle for the documentation as well.
+ --
+ -- There is no sensible infix-representation for GADT-syntax constructor
+ -- declarations. They cannot be made in source code, but we could end up
+ -- with some here in the case where some constructors use existentials.
+ -- That seems like an acceptable compromise (they'll just be documented
+ -- in prefix position), since, otherwise, the logic (at best) gets much more
+ -- complicated. (would use dataConIsInfix.)
+ alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
+ alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
+ -- "deriving" doesn't affect the signature, no need to specify any.
+ alg_deriv = Nothing
+ syn_type = synifyType WithinType (synTyConType tc)
+ in if isSynTyCon tc
+ then TySynonym name tyvars typats syn_type
+ else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
+
+-- User beware: it is your responsibility to pass True (use_gadt_syntax)
+-- for any constructor that would be misrepresented by omitting its
+-- result-type.
+-- But you might want pass False in simple enough cases,
+-- if you think it looks better.
+synifyDataCon :: Bool -> DataCon -> LConDecl Name
+synifyDataCon use_gadt_syntax dc = noLoc $
+ let
+ -- dataConIsInfix allegedly tells us whether it was declared with
+ -- infix *syntax*.
+ use_infix_syntax = dataConIsInfix dc
+ use_named_field_syntax = not (null field_tys)
+ name = synifyName dc
+ -- con_qvars means a different thing depending on gadt-syntax
+ qvars = if use_gadt_syntax
+ then synifyTyVars (dataConAllTyVars dc)
+ else synifyTyVars (dataConExTyVars dc)
+ -- skip any EqTheta, use 'orig'inal syntax
+ ctx = synifyCtx (dataConDictTheta dc)
+ linear_tys = zipWith (\ty strict ->
+ let tySyn = synifyType WithinType ty
+ in case strict of
+ MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
+ MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
+ NotMarkedStrict ->
+ -- HsNoBang never appears, it's implied instead.
+ tySyn
+ )
+ (dataConOrigArgTys dc) (dataConStrictMarks dc)
+ field_tys = zipWith (\field synTy -> ConDeclField
+ (synifyName field) synTy Nothing)
+ (dataConFieldLabels dc) linear_tys
+ tys = case (use_named_field_syntax, use_infix_syntax) of
+ (True,True) -> error "synifyDataCon: contradiction!"
+ (True,False) -> RecCon field_tys
+ (False,False) -> PrefixCon linear_tys
+ (False,True) -> case linear_tys of
+ [a,b] -> InfixCon a b
+ _ -> error "synifyDataCon: infix with non-2 args?"
+ res_ty = if use_gadt_syntax
+ then ResTyGADT (synifyType WithinType (dataConOrigResTy dc))
+ else ResTyH98
+ -- finally we get synifyDataCon's result!
+ in ConDecl name Implicit{-we don't know nor care-}
+ qvars ctx tys res_ty Nothing
+
+synifyName :: NamedThing n => n -> Located Name
+synifyName n = noLoc (getName n)
+
+synifyIdSig :: SynifyTypeState -> Id -> Sig Name
+synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i))
+
+
+synifyCtx :: [PredType] -> LHsContext Name
+synifyCtx ps = (\ps' -> noLoc ps') $
+ map synifyPred ps
+ where
+ synifyPred (ClassP cls tys) =
+ let sTys = map (synifyType WithinType) tys
+ in noLoc $
+ HsClassP (getName cls) sTys
+ synifyPred (IParam ip ty) =
+ let sTy = synifyType WithinType ty
+ -- IPName should be in class NamedThing...
+ in noLoc $
+ HsIParam ip sTy
+ synifyPred (EqPred ty1 ty2) =
+ let
+ s1 = synifyType WithinType ty1
+ s2 = synifyType WithinType ty2
+ in noLoc $
+ HsEqualP s1 s2
+
+synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
+synifyTyVars = map synifyTyVar
+ where
+ synifyTyVar tv = noLoc $ let
+ kind = tyVarKind tv
+ name = getName tv
+ in if isLiftedTypeKind kind
+ then UserTyVar name
+ else KindedTyVar name kind
+
+--states of what to do with foralls:
+data SynifyTypeState
+ = WithinType
+ -- ^ normal situation. This is the safe one to use if you don't
+ -- quite understand what's going on.
+ | ImplicitizeForAll
+ -- ^ beginning of a function definition, in which, to make it look
+ -- less ugly, those rank-1 foralls are made implicit.
+ | DeleteTopLevelQuantification
+ -- ^ because in class methods the context is added to the type
+ -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
+ -- which is rather sensible,
+ -- but we want to restore things to the source-syntax situation where
+ -- the defining class gets to quantify all its functions for free!
+
+synifyType :: SynifyTypeState -> Type -> LHsType Name
+synifyType _ (PredTy{}) = --should never happen.
+ error "synifyType: PredTys are not, in themselves, source-level types."
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
+synifyType _ (TyConApp tc tys)
+ -- Use non-prefix tuple syntax where possible, because it looks nicer.
+ | isTupleTyCon tc && tyConArity tc == length tys =
+ let sTys = map (synifyType WithinType) tys
+ in noLoc $
+ HsTupleTy (tupleTyConBoxity tc) sTys
+ -- We could do the same for list types if we knew how to determine
+ -- whether the constructor was the list-constructor....
+ -- Most TyCons:
+ | otherwise =
+ foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
+ (noLoc $ HsTyVar (getName tc))
+ (map (synifyType WithinType) tys)
+synifyType _ (AppTy t1 t2) = let
+ s1 = synifyType WithinType t1
+ s2 = synifyType WithinType t2
+ in noLoc $ HsAppTy s1 s2
+synifyType _ (FunTy t1 t2) = let
+ s1 = synifyType WithinType t1
+ s2 = synifyType WithinType t2
+ in noLoc $ HsFunTy s1 s2
+synifyType s forallty@(ForAllTy _tv _ty) =
+ let (tvs, ctx, tau) = tcSplitSigmaTy forallty
+ in case s of
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
+ _ -> let
+ forallPlicitness = case s of
+ WithinType -> Explicit
+ ImplicitizeForAll -> Implicit
+ _ -> error "synifyType: impossible case!!!"
+ sTvs = synifyTyVars tvs
+ sCtx = synifyCtx ctx
+ sTau = synifyType WithinType tau
+ in noLoc $
+ HsForAllTy forallPlicitness sTvs sCtx sTau
+
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 3092afc6..d81a5c9f 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -183,7 +183,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
moduleInfo tc_mod))
dynflags
out verbosity verbose "Creating interface..."
- let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
+ (interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
interface' <- liftIO $ evaluate interface
return (Just interface')
@@ -201,7 +201,7 @@ processModule verbosity session modsum flags modMap instIfaceMap = do
Just (CheckedModule a (Just b) (Just c) (Just d) _)
-> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
_ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
- let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
+ (interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap
mapM_ putStrLn msg
return (Just interface)
else
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 92476382..62960360 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -17,6 +17,7 @@ import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
+import Haddock.Convert
import qualified Data.Map as Map
import Data.Map (Map)
@@ -34,12 +35,12 @@ import Bag
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the module map.
createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap
- -> ErrMsgM Interface
+ -> ErrMsgGhc Interface
createInterface ghcMod flags modMap instIfaceMap = do
let mdl = ghcModule ghcMod
- opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
+ opts0 <- liftErrMsg $ mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
@@ -54,7 +55,7 @@ createInterface ghcMod flags modMap instIfaceMap = do
exportedNames = ghcExportedNames ghcMod
instances = ghcInstances ghcMod
- warnAboutFilteredDecls mdl decls0
+ liftErrMsg $ warnAboutFilteredDecls mdl decls0
exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap
opts exports ignoreExps instances instIfaceMap
@@ -343,7 +344,7 @@ mkExportItems
-> Bool -- --ignore-all-exports flag
-> [Instance]
-> InstIfaceMap
- -> ErrMsgM [ExportItem Name]
+ -> ErrMsgGhc [ExportItem Name]
mkExportItems modMap this_mod exported_names decls declMap
opts maybe_exps ignore_all_exports _ instIfaceMap
@@ -373,12 +374,12 @@ mkExportItems modMap this_mod exported_names decls declMap
lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ]
lookupExport (IEDoc doc) = return [ ExportDoc doc ]
lookupExport (IEDocNamed str) = do
- r <- findNamedDoc str [ unL d | (d,_,_) <- decls ]
+ r <- liftErrMsg $ findNamedDoc str [ unL d | (d,_,_) <- decls ]
case r of
Nothing -> return []
Just found -> return [ ExportDoc found ]
- declWith :: Name -> ErrMsgM [ ExportItem Name ]
+ declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
Just x@(decl,_,_) ->
@@ -397,7 +398,7 @@ mkExportItems modMap this_mod exported_names decls declMap
-- parents is also exported. See note [1].
| t /= declName_,
Just p <- find isExported (parents t $ unL decl) ->
- do tell [
+ do liftErrMsg $ tell [
"Warning: " ++ moduleString this_mod ++ ": " ++
pretty (nameOccName t) ++ " is exported separately but " ++
"will be documented under " ++ pretty (nameOccName p) ++
@@ -412,12 +413,41 @@ mkExportItems modMap this_mod exported_names decls declMap
-- We return just the name of the declaration and try to get the subs
-- from the installed interface of that package.
case Map.lookup (nameModule t) instIfaceMap of
+ -- It's Nothing in the cases where Haddock has already warned
+ -- the user: "Warning: The documentation for the following
+ -- packages are not installed. No links will be generated to
+ -- these packages: ..."
Nothing -> return [ ExportNoDecl t [] ]
Just iface ->
let subs = case Map.lookup t (instSubMap iface) of
Nothing -> []
Just x -> x
- in return [ ExportNoDecl t subs ]
+ in
+ -- If we couldn't find out the decl, we would have to
+ -- return [ ExportNoDecl t subs ]
+ -- . But we can find out the decl, because we have the
+ -- Name and the imported module's .hi files for
+ -- reference!
+ do
+ mbTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ case mbTyThing of
+ Nothing -> do
+ liftErrMsg (tell ["Why was no tything found for " ++ pretty (nameOccName t) ++ "? We found its module's docs. Is this a Haddock bug?"])
+ return [ ExportNoDecl t subs ]
+ Just tyThing -> do
+ let hsdecl = tyThingToHsSynSig tyThing
+ return [ mkExportDecl t
+ ( hsdecl
+ , fmap (fmapHsDoc getName) $
+ Map.lookup t (instDocMap iface)
+ , map (\subt ->
+ ( subt
+ , fmap (fmapHsDoc getName) $
+ Map.lookup subt (instDocMap iface)
+ )
+ )
+ subs
+ )]
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
mkExportDecl n (decl, doc, subs) = decl'
@@ -443,7 +473,8 @@ mkExportItems modMap this_mod exported_names decls declMap
case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of
Just iface -> return [ ExportModule (instMod iface) ]
Nothing -> do
- tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++
+ liftErrMsg $
+ tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++
"documentation for exported module: " ++ pretty modname]
return []
where
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index d82c4778..c860976f 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -292,3 +292,46 @@ throwE str = throw (HaddockException str)
#else
throwE str = throwDyn (HaddockException str)
#endif
+
+-- In "Haddock.Interface.Create", we need to gather
+-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
+-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
+-- transformed monad to be MonadIO.
+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) }
+--instance MonadIO ErrMsgGhc where
+-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
+--er, implementing GhcMonad involves annoying ExceptionMonad and
+--WarnLogMonad classes, so don't bother.
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = WriterGhc . return . runWriter
+-- for now, use (liftErrMsg . tell) for this
+--tell :: [ErrMsg] -> ErrMsgGhc ()
+--tell msgs = WriterGhc $ return ( (), msgs )
+instance Functor ErrMsgGhc where
+ fmap f (WriterGhc x) = WriterGhc (fmap (\(a,msgs)->(f a,msgs)) x)
+instance Monad ErrMsgGhc where
+ return a = WriterGhc (return (a, []))
+ m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
+ fmap (\ (b, msgs2) -> (b, msgs1 ++ msgs2)) (runWriterGhc (k a))
+
+-- When HsDoc syntax is part of the Haddock codebase, we'll just
+-- declare a Functor instance.
+fmapHsDoc :: (a->b) -> HsDoc a -> HsDoc b
+fmapHsDoc _ DocEmpty = DocEmpty
+fmapHsDoc f (DocAppend a b) = DocAppend (fmapHsDoc f a) (fmapHsDoc f b)
+fmapHsDoc _ (DocString s) = DocString s
+fmapHsDoc _ (DocModule s) = DocModule s
+fmapHsDoc _ (DocURL s) = DocURL s
+fmapHsDoc _ (DocPic s) = DocPic s
+fmapHsDoc _ (DocAName s) = DocAName s
+fmapHsDoc f (DocParagraph a) = DocParagraph (fmapHsDoc f a)
+fmapHsDoc f (DocEmphasis a) = DocEmphasis (fmapHsDoc f a)
+fmapHsDoc f (DocMonospaced a) = DocMonospaced (fmapHsDoc f a)
+fmapHsDoc f (DocCodeBlock a) = DocMonospaced (fmapHsDoc f a)
+fmapHsDoc f (DocIdentifier a) = DocIdentifier (map f a)
+fmapHsDoc f (DocOrderedList a) = DocOrderedList (map (fmapHsDoc f) a)
+fmapHsDoc f (DocUnorderedList a) = DocUnorderedList (map (fmapHsDoc f) a)
+fmapHsDoc f (DocDefList a) = DocDefList (map (\(b,c)->(fmapHsDoc f b, fmapHsDoc f c)) a)
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 08:28:29 +0000