aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs56
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs2
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs4
-rw-r--r--haddock-api/src/Haddock/Interface.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs34
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs2
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs4
-rw-r--r--haddock-api/src/Haddock/ModuleTree.hs4
-rw-r--r--haddock-api/src/Haddock/Options.hs2
-rw-r--r--haddock-api/src/Haddock/Parser.hs2
-rw-r--r--haddock-api/src/Haddock/Types.hs4
13 files changed, 59 insertions, 63 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 139a4c44..b2e2dadd 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -3,12 +3,14 @@
module Haddock.Backends.Hyperlinker.Parser (parse) where
import Control.Applicative ( Alternative(..) )
+import Control.Monad.Trans.Maybe ( MaybeT(..) )
+import Control.Monad.Trans.Class ( MonadTrans(lift) )
import Data.List ( isPrefixOf, isSuffixOf )
import qualified Data.ByteString as BS
import BasicTypes ( IntegralLit(..) )
-import DynFlags
+import GHC.Driver.Session
import ErrUtils ( emptyMessages, pprLocErrMsg )
import FastString ( mkFastString )
import Lexer ( P(..), ParseResult(..), PState(..), Token(..)
@@ -56,7 +58,10 @@ parse dflags fpath bs = case unP (go False []) initState of
(b, _) <- getInput
if not (atEnd b)
then do
- (newToks, inPrag') <- parseCppLine <|> parsePlainTok inPrag <|> unknownLine
+ mtok <- runMaybeT (parseCppLine <|> parsePlainTok inPrag)
+ (newToks, inPrag') <- case mtok of
+ Nothing -> unknownLine
+ Just a -> pure a
go inPrag' (newToks ++ toks)
else
pure toks
@@ -72,23 +77,23 @@ parse dflags fpath bs = case unP (go False []) initState of
andThen _ = wrappedLexer
-- | Try to parse a CPP line (can fail)
- parseCppLine :: P ([T.Token], Bool)
- parseCppLine = do
+ parseCppLine :: MaybeT P ([T.Token], Bool)
+ parseCppLine = MaybeT $ do
(b, l) <- getInput
case tryCppLine l b of
Just (cppBStr, l', b')
-> let cppTok = T.Token { tkType = TkCpp
, tkValue = cppBStr
, tkSpan = mkRealSrcSpan l l' }
- in setInput (b', l') *> pure ([cppTok], False)
- _ -> empty
+ in setInput (b', l') *> pure (Just ([cppTok], False))
+ _ -> return Nothing
-- | Try to parse a regular old token (can fail)
- parsePlainTok :: Bool -> P ([T.Token], Bool) -- return list is only ever 0-2 elements
+ parsePlainTok :: Bool -> MaybeT P ([T.Token], Bool) -- return list is only ever 0-2 elements
parsePlainTok inPrag = do
- (bInit, lInit) <- getInput
- L sp tok <- Lexer.lexer False return
- (bEnd, _) <- getInput
+ (bInit, lInit) <- lift getInput
+ L sp tok <- tryP (Lexer.lexer False return)
+ (bEnd, _) <- lift getInput
case sp of
UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed
RealSrcSpan rsp -> do
@@ -101,24 +106,24 @@ parse dflags fpath bs = case unP (go False []) initState of
-- Update internal line + file position if this is a LINE pragma
ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do
- L _ (ITinteger (IL { il_value = line })) <- wrappedLexer
- L _ (ITstring _ file) <- wrappedLexer
- L spF ITclose_prag <- wrappedLexer
+ L _ (ITinteger (IL { il_value = line })) <- tryP wrappedLexer
+ L _ (ITstring _ file) <- tryP wrappedLexer
+ L spF ITclose_prag <- tryP wrappedLexer
let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF)
- (bEnd'', _) <- getInput
- setInput (bEnd'', newLoc)
+ (bEnd'', _) <- lift getInput
+ lift $ setInput (bEnd'', newLoc)
pure (bEnd'', False)
-- Update internal column position if this is a COLUMN pragma
ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do
- L _ (ITinteger (IL { il_value = col })) <- wrappedLexer
- L spF ITclose_prag <- wrappedLexer
+ L _ (ITinteger (IL { il_value = col })) <- tryP wrappedLexer
+ L spF ITclose_prag <- tryP wrappedLexer
let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col)
- (bEnd'', _) <- getInput
- setInput (bEnd'', newLoc)
+ (bEnd'', _) <- lift getInput
+ lift $ setInput (bEnd'', newLoc)
pure (bEnd'', False)
@@ -154,15 +159,12 @@ getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)
setInput :: (StringBuffer, RealSrcLoc) -> P ()
setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) ()
+tryP :: P a -> MaybeT P a
+tryP (P f) = MaybeT $ P $ \s -> case f s of
+ POk s' a -> POk s' (Just a)
+ PFailed _ -> POk s Nothing
--- | Orphan instance that adds backtracking to 'P'
-instance Alternative P where
- empty = addFatalError noSrcSpan (text "Alterative.empty")
- P x <|> P y = P $ \s -> case x s of { p@POk{} -> p
- ; _ -> y s }
-
--- | Try a parser. If it fails, backtrack and return the pure value.
-tryOrElse :: a -> P a -> P a
+tryOrElse :: Alternative f => a -> f a -> f a
tryOrElse x p = p <|> pure x
-- | Classify given tokens as appropriate Haskell token type.
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 9e267150..0ab35210 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -49,7 +49,7 @@ import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set hiding ( Set )
import Data.Ord ( comparing )
-import DynFlags (Language(..))
+import GHC.Driver.Session (Language(..))
import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import Name
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index b423d55f..588f1548 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -29,10 +29,10 @@ import Outputable ( Outputable, panic, showPpr )
import Name
import NameSet
import Module
-import HscTypes
+import GHC.Driver.Types
import GHC
import Class
-import DynFlags
+import GHC.Driver.Session
import SrcLoc ( advanceSrcLoc )
import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
isInvisibleArgFlag )
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 998116f4..008beb14 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -52,9 +52,9 @@ import Text.Printf
import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
import Digraph
-import DynFlags hiding (verbosity)
+import GHC.Driver.Session hiding (verbosity)
import GHC hiding (verbosity)
-import HscTypes
+import GHC.Driver.Types
import FastString (unpackFS)
import TcRnTypes (tcg_rdr_env)
import Name (nameIsFromExternalPackage, nameOccName)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 35f24ee5..0e24ccb0 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -28,7 +28,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Class
-import DynFlags
+import GHC.Driver.Session
import CoreSyn (isOrphan)
import ErrUtils
import FamInstEnv
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 73857a90..94443856 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -45,11 +45,11 @@ import qualified Module
import qualified SrcLoc
import ConLike (ConLike(..))
import GHC
-import HscTypes
+import GHC.Driver.Types
import Name
import NameSet
import NameEnv
-import Packages ( lookupModuleInAllPackages, PackageName(..) )
+import GHC.Driver.Packages ( lookupModuleInAllPackages, PackageName(..) )
import Bag
import RdrName
import TcRnTypes
@@ -377,9 +377,8 @@ mkMaps dflags pkgName gre instances decls = do
, [(Name, Map Int (MDoc Name))]
, [(Name, [LHsDecl GhcRn])]
)
- mappings (ldecl, docStrs) = do
- let L l decl = ldecl
- declDoc :: [HsDocString] -> Map Int HsDocString
+ mappings (ldecl@(L (RealSrcSpan l) decl), docStrs) = do
+ let declDoc :: [HsDocString] -> Map Int HsDocString
-> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
declDoc strs m = do
doc' <- processDocStrings dflags pkgName gre strs
@@ -407,12 +406,13 @@ mkMaps dflags pkgName gre instances decls = do
seqList subDocs `seq`
seqList subArgs `seq`
pure (dm, am, cm)
+ mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])
- instanceMap :: Map SrcSpan Name
- instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
+ instanceMap :: Map RealSrcSpan Name
+ instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l <- [getSrcSpan n] ]
- names :: SrcSpan -> HsDecl GhcRn -> [Name]
- names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
+ names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2].
where loc = case d of
-- The CoAx's loc is the whole line, but only for TFs. The
-- workaround is to dig into the family instance declaration and
@@ -446,7 +446,7 @@ subordinates instMap decl = case decl of
DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
- [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+ [ (n, [], M.empty) | Just n <- [SrcLoc.lookupSrcSpan l instMap] ] ++ dataSubs defn
InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-> dataSubs (feqn_rhs d)
@@ -471,7 +471,7 @@ subordinates instMap decl = case decl of
| (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
concatMap (unLoc . deriv_clause_tys . unLoc) $
unLoc $ dd_derivs dd
- , Just instName <- [M.lookup l instMap] ]
+ , Just instName <- [SrcLoc.lookupSrcSpan l instMap] ]
extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
extract_deriv_ty (L l ty) =
@@ -523,7 +523,7 @@ typeDocs = go 0
-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+classDecls class_ = filterDecls . collectDocs . SrcLoc.sortLocated $ decls
where
decls = docs ++ defs ++ sigs ++ ats
docs = mkDecls tcdDocs (DocD noExtField) class_
@@ -536,7 +536,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
-- ordered by source location, with documentation attached if it exists.
topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
topDecls =
- filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+ filterClasses . filterDecls . collectDocs . SrcLoc.sortLocated . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup GhcRn -> FixMap
@@ -570,12 +570,6 @@ ungroup group_ =
mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
-
--- | Sort by source location
-sortByLoc :: [Located a] -> [Located a]
-sortByLoc = sortBy (comparing getLoc)
-
-
--------------------------------------------------------------------------------
-- Filtering of declarations
--
@@ -1196,7 +1190,7 @@ mkVisibleNames (_, _, _, instMap) exports opts
where subs = map fst (expItemSubDocs e)
patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
- InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index a996f006..7323e68e 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -25,7 +25,7 @@ import Control.Monad
import Data.List
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
-import DynFlags (languageExtensions)
+import GHC.Driver.Session (languageExtensions)
import qualified GHC.LanguageExtensions as LangExt
import GHC
import Haddock.Interface.ParseModuleHeader
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 050901b6..4e91e321 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -13,7 +13,7 @@ module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
import Control.Monad (mplus)
import Data.Char
-import DynFlags
+import GHC.Driver.Session
import Haddock.Parser
import Haddock.Types
import RdrName
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index e96ff665..be9f4293 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -36,8 +36,8 @@ import Binary
import FastMutInt
import FastString
import GHC hiding (NoLink)
-import GhcMonad (withSession)
-import HscTypes
+import GHC.Driver.Monad (withSession)
+import GHC.Driver.Types
import NameCache
import GHC.Iface.Env
import Name
diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs
index cff4e8f0..6a3f0606 100644
--- a/haddock-api/src/Haddock/ModuleTree.hs
+++ b/haddock-api/src/Haddock/ModuleTree.hs
@@ -16,8 +16,8 @@ import Haddock.Types ( MDoc )
import GHC ( Name )
import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString )
-import DynFlags ( DynFlags )
-import Packages ( lookupUnit, sourcePackageIdString )
+import GHC.Driver.Session ( DynFlags )
+import GHC.Driver.Packages ( lookupUnit, sourcePackageIdString )
import qualified Control.Applicative as A
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index fe2bb048..69cf61f5 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -48,7 +48,7 @@ import FastString
import GHC ( DynFlags, Module, moduleUnitId )
import Haddock.Types
import Haddock.Utils
-import Packages
+import GHC.Driver.Packages
import System.Console.GetOpt
import qualified Text.ParserCombinators.ReadP as RP
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index e31ea6a8..3fb7eedd 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -16,7 +16,7 @@ module Haddock.Parser ( parseParas
import qualified Documentation.Haddock.Parser as P
import Documentation.Haddock.Types
-import DynFlags ( DynFlags )
+import GHC.Driver.Session ( DynFlags )
import FastString ( fsLit )
import Lexer ( mkPState, unP, ParseResult(POk) )
import Parser ( parseIdentifier )
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 04b2d4fc..2c46e14a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -39,7 +39,7 @@ import Documentation.Haddock.Types
import BasicTypes (Fixity(..), PromotionFlag(..))
import GHC
-import DynFlags (Language)
+import GHC.Driver.Session (Language)
import qualified GHC.LanguageExtensions as LangExt
import OccName
import Outputable
@@ -55,7 +55,7 @@ type DocMap a = Map Name (MDoc a)
type ArgMap a = Map Name (Map Int (MDoc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl GhcRn]
-type InstMap = Map SrcSpan Name
+type InstMap = Map RealSrcSpan Name
type FixMap = Map Name Fixity
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-28 01:14:19 +0000