Cross-Package Documentation version 4

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)
+