aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2012-02-04 15:52:51 +0100
committerDavid Waern <david.waern@gmail.com>2012-02-04 15:52:51 +0100
commitac8e218ba6407fc826fc54e0f1b7ac23c0c6b338 (patch)
tree3efbec7abb669f7d543c98a141c2bf62f3c3b531 /src
parentb31252e0699a65a8e7d0168f012b58fde50c4b3d (diff)
Clean up some code from last SoC project.
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Interface/Create.hs75
-rw-r--r--src/Haddock/Interface/LexParseRn.hs78
-rw-r--r--src/Haddock/Types.hs1
3 files changed, 78 insertions, 76 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index cac3eac2..737547fd 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -28,7 +28,7 @@ import Data.Monoid
import Data.Ord
import Control.Applicative
import Control.Monad
-import qualified Data.Traversable as Traversable
+import qualified Data.Traversable as T
import GHC hiding (flags)
import HscTypes
@@ -72,7 +72,7 @@ createInterface tm flags modMap instIfaceMap = do
| otherwise = opts0
(info, mbDoc) <- do
- (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+ (i, d) <- liftErrMsg $ processModuleHeader dflags gre mayDocHeader
return (i, addModuleWarning warnings d)
let declsWithDocs = topDecls group_
@@ -193,13 +193,16 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
--------------------------------------------------------------------------------
--- Declarations
+-- Maps
--------------------------------------------------------------------------------
type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
mkMaps :: DynFlags
-> GlobalRdrEnv
-> [Instance]
@@ -207,38 +210,36 @@ mkMaps :: DynFlags
-> [(LHsDecl Name, [HsDocString])]
-> ErrMsgM Maps
mkMaps dflags gre instances exports decls = do
- (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls
- let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
- f = M.fromListWith (<>) . concat
- return (f dm, f am, f sm, f cm)
+ (a, b, c, d) <- unzip4 <$> mapM mappings decls
+ return (f a, f b, f c, f d)
where
- mappings (ldecl@(L _ decl), docs) = do
- doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs
- argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $
- lexParseRnHaddockComment dflags NormalHaddockComment gre
-
+ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f = M.fromListWith (<>) . concat
+
+ mappings (ldecl, docStrs) = do
+ let decl = unLoc ldecl
+ let declDoc strs m = do
+ doc <- processDocStrings dflags gre strs
+ m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
+ return (doc, m')
+ (doc, args) <- declDoc docStrs (typeDocs decl)
let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ]
-
- (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do
- mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr
- subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $
- lexParseRnHaddockComment dflags NormalHaddockComment gre
- return ((n, mbSubDoc), (n, subFnArgsDoc)))
-
- let names = case decl of
- -- See note [2].
- InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap)
- _ -> filter (`elem` exports) (getMainDeclBinder decl)
-
- let subNames = map fst subDocs
- dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ]
- am = [ (n, argDocs) | n <- names ] ++ subArgMap
- sm = [ (n, subNames) | n <- names ]
- cm = [ (n, [ldecl]) | n <- names ++ subNames ]
+ (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
+ let ns = names decl
+ subNs = [ n | (n, _, _) <- subs ]
+ dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+ sm = [ (n, subNs) | n <- ns ]
+ cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
return (dm, am, sm, cm)
+ instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
+ names :: HsDecl Name -> [Name]
+ names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2].
+ names decl = filter (`elem` exports) (getMainDeclBinder decl)
+
-- Note [2]:
------------
@@ -249,6 +250,12 @@ mkMaps dflags gre instances exports decls = do
-- with InstDecls).
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates (TyClD decl)
| isClassDecl decl = classSubs
@@ -446,15 +453,15 @@ mkExportItems
lookupExport (IEModuleContents m) =
moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
lookupExport (IEGroup lev docStr) = liftErrMsg $
- ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
+ ifDoc (processDocString dflags gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
lookupExport (IEDoc docStr) = liftErrMsg $
- ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+ ifDoc (processDocStringParas dflags gre docStr)
(\doc -> return [ ExportDoc doc ])
lookupExport (IEDocNamed str) = liftErrMsg $
ifDoc (findNamedDoc str [ unL d | d <- decls ])
(\docStr ->
- ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+ ifDoc (processDocStringParas dflags gre docStr)
(\doc -> return [ ExportDoc doc ]))
@@ -656,10 +663,10 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
f x xs = x : xs
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
+ mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+ mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
return $ fmap ExportDoc mbDoc
mkExportItem (L _ (ValD d))
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index ebd2b8fc..61f5d6ac 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+ -----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
-- Copyright : (c) Isaac Dupree 2009,
@@ -9,11 +9,10 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
- ( HaddockCommentType(..)
- , lexParseRnHaddockComment
- , lexParseRnHaddockCommentList
- , lexParseRnMbHaddockComment
- , lexParseRnHaddockModHeader
+ ( processDocString
+ , processDocStringParas
+ , processDocStrings
+ , processModuleHeader
) where
@@ -24,6 +23,7 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Doc
import Control.Applicative
+import Data.List
import Data.Maybe
import FastString
import GHC
@@ -33,62 +33,58 @@ import RdrName
import RnEnv
-data HaddockCommentType = NormalHaddockComment | DocSectionComment
-
-
-lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockCommentList dflags hty gre docStrs = do
- docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs
- let docs = catMaybes docMbs
- let doc = foldl docAppend DocEmpty docs
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+processDocStrings dflags gre strs = do
+ docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
+ let doc = foldl' docAppend DocEmpty docs
case doc of
DocEmpty -> return Nothing
_ -> return (Just doc)
-lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
- GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocString = process parseString
+
+process :: ([LToken] -> Maybe (Doc RdrName))
+ -> DynFlags
+ -> GlobalRdrEnv
+ -> HsDocString
+ -> ErrMsgM (Maybe (Doc Name))
+process parse dflags gre (HsDocString fs) = do
let str = unpackFS fs
- let toks = tokenise dflags str (0,0) -- TODO: real position
- let parse = case hty of
- NormalHaddockComment -> parseParas
- DocSectionComment -> parseString
+ let toks = tokenise dflags str (0,0) -- TODO: real position
case parse toks of
Nothing -> do
- tell ["doc comment parse failed: "++str]
+ tell [ "doc comment parse failed: " ++ str ]
return Nothing
Just doc -> return (Just (rename gre doc))
-lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing
-lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d
-
-
--- yes, you always get a HaddockModInfo though it might be empty
-lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
-lexParseRnHaddockModHeader dflags gre mbStr = do
- (hmi, docn) <-
- case mbStr of
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre mayStr = do
+ (hmi, doc) <-
+ case mayStr of
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
case parseModuleHeader dflags str of
- Left mess -> do
- tell ["haddock module header parse failed: " ++ mess]
+ Left msg -> do
+ tell ["haddock module header parse failed: " ++ msg]
return failure
- Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))
- return (hmi { hmi_safety = safety }, docn)
+ Right (hmi, doc) -> do
+ let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi }
+ doc' = rename gre doc
+ return (hmi', Just doc')
+ let safety = Just $ showPpr $ safeHaskell dflags
+ return (hmi { hmi_safety = safety }, doc)
where
- safety = Just $ showPpr $ safeHaskell dflags
failure = (emptyHaddockModInfo, Nothing)
-renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
-renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi }
-
-
rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name
rename gre = rn
where
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index fe4039a7..927fcffb 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -42,7 +42,6 @@ type ArgMap a = Map Name (Map Int (Doc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type SrcMap = Map PackageId FilePath
-type GhcDocHdr = Maybe LHsDocString
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources