Complete support for inferring types for top-level bindings.

7 files changed, 117 insertions, 37 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f89bcbc0..408e37d1 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -390,10 +390,10 @@ mkExportItems
 mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declMap
               optExports _ instIfaceMap dflags =
   case optExports of
-    Nothing      -> liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls
+    Nothing      -> fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls
     Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
   where
-    decls = filter (\(L _ d) -> not (isInstD d || isValD d)) decls0
+    decls = filter (not . isInstD . unLoc) decls0
 
     -- A type signature can have multiple names, like:
     --   foo, bar :: Types..
@@ -409,7 +409,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
     lookupExport (IEThingAll t)        = declWith t
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  =
-      moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap
+      moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap declMap
     lookupExport (IEGroup lev docStr)  = liftErrMsg $
       ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
             (\doc -> return [ ExportGroup lev "" doc ])
@@ -431,15 +431,12 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
 
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
     declWith t =
-      let doc = (M.lookup t docMap, maybe M.empty id (M.lookup t argMap)) in
+      let (doc, subs) = exportDecl t docMap argMap subMap in
       case findDecl t of
         [L _ (ValD _)] -> do
           -- Top-level binding without type signature
-          mayDecl <- ifaceDecl t
-          case mayDecl of
-            Nothing -> return [ ExportNoDecl t [] ]
-            Just decl -> return [ ExportDecl decl doc [] [] ]
-
+          export <- hiValExportItem t doc
+          return [export]
         ds | decl : _ <- filter (not . isValD . unLoc) ds ->
           let declNames = getMainDeclBinder (unL decl)
           in case () of
@@ -462,7 +459,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
                    return []
 
               -- normal case
-              | otherwise -> return [ mkExportDecl t newDecl (exportDecl t newDecl docMap argMap subMap) ]
+              | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ]
                   where
                     -- Since a single signature might refer to many names, we
                     -- need to filter the ones that are actually exported. This
@@ -477,7 +474,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
 
         -- Declaration from another package
         [] -> do
-          mayDecl <- ifaceDecl t
+          mayDecl <- hiDecl t
           case mayDecl of
             Nothing -> return [ ExportNoDecl t [] ]
             Just decl -> do
@@ -487,10 +484,10 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
                 Nothing -> do
                    liftErrMsg $ tell
                       ["Warning: Couldn't find .haddock for export " ++ pretty t]
-                   let subs = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
-                   return [ mkExportDecl t decl (noDocForDecl, subs) ]
+                   let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
+                   return [ mkExportDecl t decl (noDocForDecl, subs_) ]
                 Just iface -> do
-                   return [ mkExportDecl t decl (exportDecl t decl (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+                   return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
 
         _ -> return []
 
@@ -508,17 +505,16 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
 
 
     findDecl :: Name -> [Decl]
-    findDecl n
-      | m == thisMod = maybe [] id (M.lookup n declMap)
-      | otherwise = case M.lookup m modMap of
-                      Just iface -> maybe [] id (M.lookup n (ifaceDeclMap iface))
-                      Nothing -> []
+    findDecl name
+      | mdl == thisMod = maybe [] id (M.lookup name declMap)
+      | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface))
+      | otherwise = []
       where
-        m = nameModule n
+        mdl = nameModule name
 
 
-ifaceDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
-ifaceDecl t = do
+hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl t = do
   mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
   case mayTyThing of
     Nothing -> do
@@ -527,8 +523,16 @@ ifaceDecl t = do
     Just x -> return (Just (tyThingToLHsDecl x))
 
 
-exportDecl :: Name -> Decl -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-exportDecl name _ docMap argMap subMap =
+hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
+hiValExportItem name doc = do
+  mayDecl <- hiDecl name
+  case mayDecl of
+    Nothing -> return (ExportNoDecl name [])
+    Just decl -> return (ExportDecl decl doc [] [])
+
+
+exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+exportDecl name docMap argMap subMap =
   let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in
   let doc = (M.lookup name docMap, lookupArgMap name) in
   let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in
@@ -559,9 +563,10 @@ moduleExports :: Module           -- ^ Module A
               -> DocMap Name
               -> ArgMap Name
               -> SubMap
+              -> DeclMap
               -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap
-  | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls
+moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap declMap
+  | m == thisMod = fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls
   | otherwise =
     case M.lookup m ifaceMap of
       Just iface
@@ -599,21 +604,28 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap doc
 -- (For more information, see Trac #69)
 
 
-fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> [Decl] -> ErrMsgM [ExportItem Name]
-fullContentsOfThisModule dflags gre docMap argMap subMap decls = liftM catMaybes $ mapM mkExportItem decls
+fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> DeclMap -> [Decl] -> ErrMsgGhc [ExportItem Name]
+fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls = liftM catMaybes $ mapM mkExportItem decls
   where
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-      mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr
+      mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
       return $ fmap (ExportGroup lev "") mbDoc
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
-      mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+      mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
       return $ fmap ExportDoc mbDoc
+    mkExportItem (L _ (ValD d))
+      | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
+          -- Top-level binding without type signature
+          let (doc, _) = exportDecl name docMap argMap subMap in
+          fmap Just (hiValExportItem name doc)
+      | otherwise = return Nothing
     mkExportItem decl
-      | name : _ <- getMainDeclBinder (unLoc decl) =
-        let (doc, subs) = exportDecl name decl docMap argMap subMap in
+      | name:_ <- getMainDeclBinder (unLoc decl) =
+        let (doc, subs) = exportDecl name docMap argMap subMap in
         return $ Just (ExportDecl decl doc subs [])
       | otherwise = return Nothing
 
+
 -- | Sometimes the declaration we want to export is not the "main" declaration:
 -- it might be an individual record selector or a class method.  In these
 -- cases we have to extract the required declaration (and somehow cobble
diff --git a/tests/html-tests/tests/Bug8.hs b/tests/html-tests/tests/Bug8.hs
index 0f279c29..18df63c8 100644
--- a/tests/html-tests/tests/Bug8.hs
+++ b/tests/html-tests/tests/Bug8.hs
@@ -1,6 +1,3 @@
-{- Note that declarations without type signatures are not included in the
-   documentation. They could be, but that's a missing feature. -}
-
 module Bug8 where
 
 infix -->
diff --git a/tests/html-tests/tests/Bug8.html.ref b/tests/html-tests/tests/Bug8.html.ref
index ee0637b9..05d3ebeb 100644
--- a/tests/html-tests/tests/Bug8.html.ref
+++ b/tests/html-tests/tests/Bug8.html.ref
@@ -82,6 +82,42 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug8.html");};
 	      ></table
 	    ></div
 	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:-45--45--62-" class="def"
+	    >(--&gt;)</a
+	    > ::  t -&gt; t1 -&gt; <a href=""
+	    >Typ</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:-45--45--45--62-" class="def"
+	    >(---&gt;)</a
+	    > ::  [a] -&gt; <a href=""
+	    >Typ</a
+	    > -&gt; <a href=""
+	    >Typ</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:s" class="def"
+	    >s</a
+	    > ::  a</p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:t" class="def"
+	    >t</a
+	    > ::  a</p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:main" class="def"
+	    >main</a
+	    > ::  a</p
+	  ></div
 	></div
       ></div
     ><div id="footer"
diff --git a/tests/html-tests/tests/QuasiExpr.html.ref b/tests/html-tests/tests/QuasiExpr.html.ref
index 0d59ecc8..8241c3f7 100644
--- a/tests/html-tests/tests/QuasiExpr.html.ref
+++ b/tests/html-tests/tests/QuasiExpr.html.ref
@@ -196,6 +196,12 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiExpr.html");};
 	  ></div
 	><div class="top"
 	><p class="src"
+	  ><a name="v:expr" class="def"
+	    >expr</a
+	    > :: QuasiQuoter</p
+	  ></div
+	><div class="top"
+	><p class="src"
 	  ><a name="v:parseExprExp" class="def"
 	    >parseExprExp</a
 	    > :: <a href=""
diff --git a/tests/html-tests/tests/TH2.hs b/tests/html-tests/tests/TH2.hs
index f8f27710..ea85e547 100644
--- a/tests/html-tests/tests/TH2.hs
+++ b/tests/html-tests/tests/TH2.hs
@@ -4,5 +4,4 @@ module TH2 where
 
 import TH
 
--- we can't add a type sig here, so we get no doc
 $( decl )
diff --git a/tests/html-tests/tests/TH2.html.ref b/tests/html-tests/tests/TH2.html.ref
index 9fc9a056..3d284850 100644
--- a/tests/html-tests/tests/TH2.html.ref
+++ b/tests/html-tests/tests/TH2.html.ref
@@ -42,7 +42,15 @@ window.onload = function () {pageLoad();setSynopsis("mini_TH2.html");};
 	>TH2</p
 	></div
       ><div id="interface"
-      ></div
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a name="v:f" class="def"
+	    >f</a
+	    > ::  t -&gt; t</p
+	  ></div
+	></div
       ></div
     ><div id="footer"
     ><p
diff --git a/tests/html-tests/tests/TypeFamilies.html.ref b/tests/html-tests/tests/TypeFamilies.html.ref
index 40c949b8..a3d94bb0 100644
--- a/tests/html-tests/tests/TypeFamilies.html.ref
+++ b/tests/html-tests/tests/TypeFamilies.html.ref
@@ -81,6 +81,16 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 	    > <a href=""
 	    >F</a
 	    > a </li
+	  ><li class="src short"
+	  ><a href=""
+	    >g</a
+	    > :: <a href=""
+	    >B</a
+	    > <a href=""
+	    >Int</a
+	    > <a href=""
+	    >Integer</a
+	    ></li
 	  ></ul
 	></div
       ><div id="interface"
@@ -177,6 +187,18 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 </p
 	    ></div
 	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:g" class="def"
+	    >g</a
+	    > :: <a href=""
+	    >B</a
+	    > <a href=""
+	    >Int</a
+	    > <a href=""
+	    >Integer</a
+	    ></p
+	  ></div
 	></div
       ></div
     ><div id="footer"