aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2011-12-03 19:45:56 +0100
committerDavid Waern <david.waern@gmail.com>2011-12-03 20:13:08 +0100
commit1bf42a0c5b92fc142eeb7e540e5f5e12373edc99 (patch)
treea9d1e8041a3f4b6117c295d309df160945c53bf1
parent20c4bfe760b3b50c875e91e455c47f544ba5129e (diff)
More cleanup.
-rw-r--r--haddock.cabal2
-rw-r--r--src/Haddock/Interface/Create.hs41
-rw-r--r--src/Haddock/Interface/ExtractFnArgDocs.hs49
3 files changed, 25 insertions, 67 deletions
diff --git a/haddock.cabal b/haddock.cabal
index 81d64756..16b37bcc 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -109,7 +109,6 @@ executable haddock
Haddock.Interface
Haddock.Interface.Rename
Haddock.Interface.Create
- Haddock.Interface.ExtractFnArgDocs
Haddock.Interface.AttachInstances
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
@@ -172,7 +171,6 @@ library
Haddock.Interface
Haddock.Interface.Rename
Haddock.Interface.Create
- Haddock.Interface.ExtractFnArgDocs
Haddock.Interface.AttachInstances
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index de87ca94..74c98dd9 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -18,7 +18,6 @@ import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
-import Haddock.Interface.ExtractFnArgDocs
import qualified Data.Map as Map
import Data.Map (Map)
@@ -197,7 +196,7 @@ declInfos dflags gre decls =
mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment
gre mbDocString
fnArgsDoc <- fmap (Map.mapMaybe id) $
- Traversable.forM (getDeclFnArgDocs d) $
+ Traversable.forM (typeDocs d) $
\doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
let subs_ = subordinates d
@@ -213,23 +212,16 @@ declInfos dflags gre decls =
subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)]
-subordinates (TyClD d) = classDataSubs d
-subordinates _ = []
-
-
-classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)]
-classDataSubs decl
+subordinates (TyClD decl)
| isClassDecl decl = classSubs
| isDataDecl decl = dataSubs
- | otherwise = []
where
- classSubs = [ (name, doc, fnArgsDoc)
- | (L _ d, doc) <- classDecls decl
+ classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl
, name <- getMainDeclBinder d
- , let fnArgsDoc = getDeclFnArgDocs d ]
- dataSubs = constrs ++ fields
+ ]
+ dataSubs = constrs ++ fields
where
- cons = map unL $ tcdCons decl
+ cons = map unL $ tcdCons decl
-- should we use the type-signature of the constructor
-- and the docs of the fields to produce fnArgsDoc for the constr,
-- just in case someone exports it without exporting the type
@@ -239,6 +231,24 @@ classDataSubs decl
fields = [ (unL n, maybeToList $ fmap unL doc, Map.empty)
| RecCon flds <- map con_details cons
, ConDeclField n _ doc <- flds ]
+subordinates _ = []
+
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsDecl Name -> Map Int HsDocString
+typeDocs d =
+ let docs = go 0 in
+ case d of
+ SigD (TypeSig _ ty) -> docs (unLoc ty)
+ ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
+ TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty)
+ _ -> Map.empty
+ where
+ go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
+ go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = Map.insert n x $ go (n+1) ty
+ go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
+ go n (HsDocTy _ (L _ doc)) = Map.singleton n doc
+ go _ _ = Map.empty
-- | All the sub declarations of a class (that we handle), ordered by
@@ -259,8 +269,7 @@ topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
--- | Take all declarations except pragmas, infix decls, rules and value
--- bindings from an 'HsGroup'.
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup Name -> [Decl]
ungroup group_ =
mkDecls (concat . hs_tyclds) TyClD group_ ++
diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs
deleted file mode 100644
index a9f8a807..00000000
--- a/src/Haddock/Interface/ExtractFnArgDocs.hs
+++ /dev/null
@@ -1,49 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface.ExtractFnArgDocs
--- Copyright : (c) Isaac Dupree 2009,
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Interface.ExtractFnArgDocs (
- getDeclFnArgDocs, getSigFnArgDocs, getTypeFnArgDocs
-) where
-
-import Haddock.Types
-
-import qualified Data.Map as Map
-import Data.Map (Map)
-
-import GHC
-
--- the type of Name doesn't matter, except in 6.10 where
--- HsDocString = HsDoc Name, so we can't just say "HsDecl name" yet.
-
-getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString
-getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty
-getDeclFnArgDocs (ForD (ForeignImport _ ty _ _)) = getTypeFnArgDocs ty
-getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty
-getDeclFnArgDocs _ = Map.empty
-
-getSigFnArgDocs :: Sig Name -> Map Int HsDocString
-getSigFnArgDocs (TypeSig _ ty) = getTypeFnArgDocs ty
-getSigFnArgDocs _ = Map.empty
-
-getTypeFnArgDocs :: LHsType Name -> Map Int HsDocString
-getTypeFnArgDocs ty = getLTypeDocs 0 ty
-
-
-getLTypeDocs :: Int -> LHsType Name -> Map Int HsDocString
-getLTypeDocs n (L _ ty) = getTypeDocs n ty
-
-getTypeDocs :: Int -> HsType Name -> Map Int HsDocString
-getTypeDocs n (HsForAllTy _ _ _ ty) = getLTypeDocs n ty
-getTypeDocs n (HsFunTy (L _ (HsDocTy _arg_type (L _ doc))) res_type) =
- Map.insert n doc $ getLTypeDocs (n+1) res_type
-getTypeDocs n (HsFunTy _ res_type) = getLTypeDocs (n+1) res_type
-getTypeDocs n (HsDocTy _res_type (L _ doc)) = Map.singleton n doc
-getTypeDocs _ _res_type = Map.empty
-