From ac8e218ba6407fc826fc54e0f1b7ac23c0c6b338 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 15:52:51 +0100 Subject: Clean up some code from last SoC project. --- src/Haddock/Interface/Create.hs | 75 +++++++++++++++++++---------------- src/Haddock/Interface/LexParseRn.hs | 78 ++++++++++++++++++------------------- src/Haddock/Types.hs | 1 - 3 files changed, 78 insertions(+), 76 deletions(-) (limited to 'src') 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 -- cgit v1.2.3