From 3f8dc6644815d3219bcb970ce6fa5cbee144c7c4 Mon Sep 17 00:00:00 2001 From: Isaac Dupree Date: Wed, 12 Aug 2009 03:47:14 +0000 Subject: Cross-Package Documentation version 4 --- haddock.cabal | 1 + src/Haddock/Convert.hs | 275 ++++++++++++++++++++++++++++++++++++++++ src/Haddock/Interface.hs | 4 +- src/Haddock/Interface/Create.hs | 49 +++++-- src/Haddock/Types.hs | 43 +++++++ 5 files changed, 361 insertions(+), 11 deletions(-) create mode 100644 src/Haddock/Convert.hs diff --git a/haddock.cabal b/haddock.cabal index 12a97e9f..5e6ff274 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -108,6 +108,7 @@ executable haddock Haddock.InterfaceFile Haddock.Options Haddock.GhcUtils + Haddock.Convert -- Cabal doesn't define __GHC_PATCHLEVEL__ if impl(ghc == 6.10.1) 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) + -- cgit v1.2.3