aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface/Create.hs
diff options
context:
space:
mode:
authorKazu Yamamoto <kazu@iij.ad.jp>2013-02-01 11:59:24 +0900
committerKazu Yamamoto <kazu@iij.ad.jp>2013-02-01 11:59:24 +0900
commit8d4c94ca5a969a5ebbb791939fb0195dc672429e (patch)
tree560a944a7105cd715f9acba46790bd7e1a77f82f /src/Haddock/Interface/Create.hs
parent266a20afd2d27f28bbb62839ebc3f70bd83bfcce (diff)
parent3d25ea2929a9a9bd0768339b8ac5fd1b7c4670ad (diff)
Merge branch 'ghc-7.6' into ghc-7.6-merge-2
Conflicts: haddock.cabal src/Haddock/Interface/AttachInstances.hs src/Haddock/Interface/Create.hs src/Haddock/Interface/LexParseRn.hs src/Haddock/InterfaceFile.hs src/Haddock/Types.hs Only GHC HEAD can compile this. GHC 7.6.x cannot compile this. Some test fail.
Diffstat (limited to 'src/Haddock/Interface/Create.hs')
-rw-r--r--src/Haddock/Interface/Create.hs100
1 files changed, 56 insertions, 44 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 8f429d9c..40016a0b 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Create
@@ -40,7 +41,7 @@ import Name
import Bag
import RdrName
import TcRnTypes
-import FastString (unpackFS)
+import FastString (unpackFS, concatFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -89,8 +90,11 @@ createInterface tm flags modMap instIfaceMap = do
liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
- let warningMap = mkWarningMap warnings gre exportedNames
- exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
+ warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
+
+ let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
+
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports
instances instIfaceMap dflags
let !visibleNames = mkVisibleNames exportItems opts
@@ -111,26 +115,29 @@ createInterface tm flags modMap instIfaceMap = do
let !aliases =
mkAliasMap dflags $ tm_renamed_source tm
+ modWarn <- liftErrMsg $ moduleWarning dflags gre warnings
+
return $! Interface {
- ifaceMod = mdl,
- ifaceOrigFilename = msHsFilePath ms,
- ifaceInfo = info,
- ifaceDoc = Documentation mbDoc (moduleWarning warnings),
- ifaceRnDoc = Documentation Nothing Nothing,
- ifaceOptions = opts,
- ifaceDocMap = docMap,
- ifaceArgMap = argMap,
- ifaceRnDocMap = M.empty,
- ifaceRnArgMap = M.empty,
- ifaceExportItems = prunedExportItems,
- ifaceRnExportItems = [],
- ifaceExports = exportedNames,
- ifaceVisibleExports = visibleNames,
- ifaceDeclMap = declMap,
- ifaceSubMap = subMap,
- ifaceModuleAliases = aliases,
- ifaceInstances = instances,
- ifaceHaddockCoverage = coverage
+ ifaceMod = mdl
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceSubMap = subMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
}
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -166,31 +173,35 @@ lookupModuleDyn dflags Nothing mdlName =
-- Warnings
-------------------------------------------------------------------------------
-type WarningMap = DocMap Name
-
-mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
-mkWarningMap NoWarnings _ _ = M.empty
-mkWarningMap (WarnAll _) _ _ = M.empty
-mkWarningMap (WarnSome ws) gre exps = M.fromList
- [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
- , let n = gre_name elt, n `elem` exps ]
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap dflags warnings gre exps = case warnings of
+ NoWarnings -> return M.empty
+ WarnAll _ -> return M.empty
+ WarnSome ws -> do
+ let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+ M.fromList <$> mapM parse ws'
+ where
+ parse (n, w) = (,) n <$> parseWarning dflags gre w
-moduleWarning :: Warnings -> Maybe (Doc id)
-moduleWarning ws =
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning dflags gre ws =
case ws of
- NoWarnings -> Nothing
- WarnSome _ -> Nothing
- WarnAll w -> Just $! warnToDoc w
-
-
-warnToDoc :: WarningTxt -> Doc id
-warnToDoc w = case w of
- (DeprecatedTxt msg) -> format "Deprecated: " msg
- (WarningTxt msg) -> format "Warning: " msg
+ NoWarnings -> return Nothing
+ WarnSome _ -> return Nothing
+ WarnAll w -> Just <$> parseWarning dflags gre w
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning dflags gre w = do
+ r <- case w of
+ (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)
+ (WarningTxt msg) -> format "Warning: " (concatFS msg)
+ r `deepseq` return r
where
- format x xs = let !str = force $ concat (x : map unpackFS xs)
- in DocWarning $ DocParagraph $ DocString str
+ format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
+ . fromMaybe (DocString . unpackFS $ xs)
+ <$> processDocString dflags gre (HsDocString xs)
-------------------------------------------------------------------------------
@@ -703,6 +714,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
f x xs = x : xs
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
@@ -777,7 +789,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
--- | Keep exprt items with docs.
+-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
where