diff options
-rw-r--r-- | haddock-api/src/Haddock.hs | 8 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 56 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 34 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/InterfaceFile.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/ModuleTree.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Options.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Parser.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Types.hs | 4 | ||||
-rw-r--r-- | haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 4 |
15 files changed, 65 insertions, 69 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 68392ab3..3c8f05c9 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -67,13 +67,13 @@ import System.FilePath ((</>)) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import Config -import DynFlags hiding (projectVersion, verbosity) +import GHC.Driver.Session hiding (projectVersion, verbosity) import ErrUtils -import Packages +import GHC.Driver.Packages import Panic (handleGhcException) import Module import FastString -import qualified DynamicLoading +import qualified GHC.Runtime.Loader -------------------------------------------------------------------------------- -- * Exception handling @@ -473,7 +473,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' hscenv <- GHC.getSession - dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'') + dynflags''' <- liftIO (GHC.Runtime.Loader.initializePlugins hscenv dynflags'') _ <- setSessionDynFlags dynflags''' ghcActs dynflags''' where 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 diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 6e065dfb..3b4cbb96 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -4,8 +4,8 @@ module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where import Test.Hspec import Test.QuickCheck -import GHC ( runGhc, getSessionDynFlags ) -import DynFlags ( DynFlags ) +import GHC ( runGhc, getSessionDynFlags ) +import GHC.Driver.Session ( DynFlags ) import Control.Monad.IO.Class import Data.String ( fromString ) |