From 003f11795e4413abae5275e8a855765c571ccab9 Mon Sep 17 00:00:00 2001 From: Niklas Haas Date: Sun, 9 Mar 2014 06:07:09 +0100 Subject: Differentiate between TH splices (line-links) and regular names This adds a new type of source code link, to a specific line rather than a specific declaration/name - this is used to link to the location of a TH splice that defines a certain name. Rather hefty changes throughout and still one unresolved issue (the line URLs aren't parsed from the third form of --read-interface which means they're currently restricted to same-interface links). Not sure if this issue is really worth all the hassle, especially since we could just use line links in general. This commit also contains some cleanup/clarification of the types in Haddock.Backends.Xhtml.Decl and shortens some overlong lines in the process. Notably, the Bool parameter was replaced by a Unicode type synonym to help clarify its presence in type signatures. --- src/Haddock/Interface/Create.hs | 49 +++++++++++++++++++++++------------------ src/Haddock/Interface/Rename.hs | 4 ++-- 2 files changed, 29 insertions(+), 24 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 37d0fe7d..e23e9922 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -55,6 +55,7 @@ createInterface tm flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm + L _ hsm = parsedSource tm !safety = modInfoSafe mi mdl = ms_mod ms dflags = ms_hspp_opts ms @@ -85,6 +86,8 @@ createInterface tm flags modMap instIfaceMap = do (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances ++ map getName fam_instances + -- Locations of all TH splices + splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] maps@(!docMap, !argMap, !subMap, !declMap, _) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs @@ -98,8 +101,8 @@ createInterface tm flags modMap instIfaceMap = do let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps fixMap exports - instIfaceMap dflags + exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls + maps fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -477,15 +480,16 @@ mkExportItems -> [LHsDecl Name] -> Maps -> FixMap + -> [SrcSpan] -- splice locations -> Maybe [IE Name] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems modMap thisMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) fixMap optExports instIfaceMap dflags = + maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = case optExports of - Nothing -> fullModuleContents dflags warnings gre maps fixMap decls + Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEVar x) = declWith x @@ -493,7 +497,7 @@ mkExportItems lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap + moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (processDocString dflags gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) @@ -516,9 +520,9 @@ mkExportItems declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of - ([L _ (ValD _)], (doc, _)) -> do + ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem dflags t doc $ M.lookup t fixMap + export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -577,7 +581,7 @@ mkExportItems mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name mkExportDecl name decl (doc, subs) = decl' where - decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities + decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False mdl = nameModule name subs' = filter (isExported . fst) subs sub_names = map fst subs' @@ -608,12 +612,12 @@ hiDecl dflags t = do Just x -> return (Just (tyThingToLHsDecl x)) -hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -hiValExportItem dflags name doc fixity = do +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl decl doc [] [] fixities) + Just decl -> return (ExportDecl decl doc [] [] fixities splice) where fixities = case fixity of Just f -> [(name, f)] @@ -656,9 +660,10 @@ moduleExports :: Module -- ^ Module A -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> FixMap + -> [SrcSpan] -- ^ Locations of all TH splices -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap - | m == thisMod = fullModuleContents dflags warnings gre maps fixMap decls +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices + | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls | otherwise = case M.lookup m ifaceMap of Just iface @@ -696,9 +701,9 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap +fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap decls = +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- A type signature can have multiple names, like: @@ -721,20 +726,20 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr return $ fmap ExportDoc mbDoc - mkExportItem (L _ (ValD d)) + mkExportItem (L l (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name doc $ M.lookup name fixMap) + fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) | otherwise = return Nothing - mkExportItem decl@(L _ (InstD d)) + mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs)) - mkExportItem decl - | name:_ <- getMainDeclBinder (unLoc decl) = + return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + mkExportItem decl@(L l d) + | name:_ <- getMainDeclBinder d = let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs)) + return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) | otherwise = return Nothing fixities name subs = [ (n,f) | n <- name : map fst subs diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 4bf39dfb..a5cde195 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -477,7 +477,7 @@ renameExportItem item = case item of ExportGroup lev id_ doc -> do doc' <- renameDoc doc return (ExportGroup lev id_ doc') - ExportDecl decl doc subs instances fixities -> do + ExportDecl decl doc subs instances fixities splice -> do decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs @@ -488,7 +488,7 @@ renameExportItem item = case item of fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) - return (ExportDecl decl' doc' subs' instances' fixities') + return (ExportDecl decl' doc' subs' instances' fixities' splice) ExportNoDecl x subs -> do x' <- lookupRn x subs' <- mapM lookupRn subs -- cgit v1.2.3