diff --git a/Break.hs b/Break.hs new file mode 100644 --- /dev/null +++ b/Break.hs @@ -0,0 +1,164 @@ +-- | This is a modified copy of compiler/ghci/Debugger.hs +{-# LANGUAGE MagicHash, CPP #-} +module Break ( + evaluateIds + , resolveNames + , parseNames + ) where + +import Prelude hiding (id) + +import Linker +import RtClosureInspect + +import GhcMonad +import HscTypes +import Id +import Name +import Var hiding ( varName ) +import VarSet +import UniqSupply +import TcType ( + emptyTvSubst + , TvSubst + , substTy + , isUnliftedTypeKind + , unionTvSubst + ) +import GHC +import MonadUtils + +import Control.Monad +import Data.List +import Data.Maybe +import Data.IORef + +import GhcShim + +------------------------------------- +-- | The :print & friends commands +------------------------------------- + +-- | This is basically 'pprintClosureCommand' from Debugger.hs except that +-- we don't take a string as argument but a set of names (and defined a +-- separate 'parseNames' and 'resolveNames' if we do want to start with a +-- String), and that we return a set of terms rather than pretty-printing +-- them directly to stdout. +evaluateIds :: GhcMonad m => Bool -> Bool -> [Id] -> m [(Id, Term)] +evaluateIds bindThings force ids = do + -- Obtain the terms and the recovered type information + (subst, terms) <- mapAccumLM go emptyTvSubst ids + + -- Apply the substitutions obtained after recovering the types + modifySession $ \hsc_env -> + hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} + + return (zip ids terms) + where + -- Do the obtainTerm--bindSuspensions-computeSubstitution dance + go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term) + go subst id = do + let id' = id `setIdType` substTy subst (idType id) + term_ <- GHC.obtainTermFromId maxBound force id' + term <- tidyTermTyVars term_ + term' <- if bindThings && + False == isUnliftedTypeKind (termType term) + then bindSuspensions term + else return term + -- Before leaving, we compare the type obtained to see if it's more specific + -- Then, we extract a substitution, + -- mapping the old tyvars to the reconstructed types. + let reconstructed_type = termType term + hsc_env <- getSession + case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of + Nothing -> return (subst, term') + Just subst' -> return (subst `unionTvSubst` subst', term') + + tidyTermTyVars :: GhcMonad m => Term -> m Term + tidyTermTyVars t = + withSession $ \hsc_env -> do + let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env + my_tvs = termTyVars t + tvs = env_tvs `minusVarSet` my_tvs + tyvarOccName = nameOccName . tyVarName + tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs)) + , env_tvs `intersectVarSet` my_tvs) + return$ mapTermType (snd . tidyOpenType tidyEnv) t + +-- | Give names, and bind in the interactive environment, to all the suspensions +-- included (inductively) in a term +bindSuspensions :: GhcMonad m => Term -> m Term +#if __GLASGOW_HASKELL__ >= 710 +-- TODO: Not implemented for 7.10 and up +bindSuspensions _ = undefined +#else +bindSuspensions t = do + hsc_env <- getSession + inScope <- GHC.getBindings + let ictxt = hsc_IC hsc_env + prefix = "_t" + alreadyUsedNames = map (occNameString . nameOccName . getName) inScope + availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames + availNames_var <- liftIO $ newIORef availNames + (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t + let (names, tys, hvals) = unzip3 stuff + let ids = [ mkVanillaGlobal name ty + | (name,ty) <- zip names tys] + new_ic = extendInteractiveContext ictxt (map AnId ids) + liftIO $ extendLinkEnv (zip names hvals) + modifySession $ \_ -> hsc_env {hsc_IC = new_ic } + return t' + where + +-- Processing suspensions. Give names and recopilate info + nameSuspensionsAndGetInfos :: IORef [String] -> + TermFold (IO (Term, [(Name,Type,HValue)])) + nameSuspensionsAndGetInfos freeNames = TermFold + { + fSuspension = doSuspension freeNames + , fTerm = \ty dc v acts -> do + tt' <- sequence acts + let (terms,names) = unzip tt' + return (Term ty dc v terms, concat names) + , fPrim = \ty n ->return (Prim ty n,[]) + , fNewtypeWrap = + \ty dc act -> do + (term, names) <- act + return (NewtypeWrap ty dc term, names) + , fRefWrap = \ty act -> do + (term, names) <- act + return (RefWrap ty term, names) + } + doSuspension freeNames ct ty hval _name = do + name <- atomicModifyIORef freeNames (\x->(tail x, head x)) + n <- newGrimName name + return (Suspension ct ty hval (Just n), [(n,ty,hval)]) +#endif + +-- Create new uniques and give them sequentially numbered names +newGrimName :: MonadIO m => String -> m Name +newGrimName userName = do + us <- liftIO $ mkSplitUniqSupply 'b' + let unique = uniqFromSupply us + occname = mkOccName varName userName + name = mkInternalName unique occname noSrcSpan + return name + +{------------------------------------------------------------------------------ + Resolving names +------------------------------------------------------------------------------} + +resolveNames :: GhcMonad m => [Name] -> m [Id] +resolveNames names = do + tyThings <- catMaybes `liftM` mapM lookupName names + return $ idsFromTyThings tyThings + where + idsFromTyThings :: [TyThing] -> [Id] + idsFromTyThings = catMaybes . map aux + where + aux (AnId id) = Just id + aux _ = Nothing + +parseNames :: GhcMonad m => String -> m [Name] +parseNames str = concatMapM parseName (words str) + diff --git a/Conv.hs b/Conv.hs new file mode 100644 --- /dev/null +++ b/Conv.hs @@ -0,0 +1,72 @@ +-- | Conversions between GHC's types and our types +module Conv ( + -- * Conversions from ghc's types to our types + importPackageId + , importMainPackage + , importModuleId + , importModuleId' + , findExposedModule + -- * Conversions from our types to ghc's types + , exportPackageId + , exportModuleId + ) where + +import Prelude hiding (mod) +import qualified Data.Text as Text + +import GHC (DynFlags) +import qualified Module as GHC + +import GhcShim +import qualified IdeSession.Types.Private as Private +import qualified IdeSession.Types.Public as Public +import qualified IdeSession.Strict.Maybe as Maybe + +{------------------------------------------------------------------------------ + Conversions from ghc's types to our types +------------------------------------------------------------------------------} + +-- | PackageId of the main package +importMainPackage :: Private.PackageId +importMainPackage = Private.PackageId { + Private.packageName = Text.pack "main" + , Private.packageVersion = Maybe.nothing -- the only case of no version + , Private.packageKey = Text.pack $ packageKeyString mainPackageKey + } + +-- | Find out the version of a package +importPackageId :: DynFlags -> PackageKey -> Private.PackageId +importPackageId _ p | p == mainPackageKey = importMainPackage +importPackageId dflags p = + let (pkgName, pkgVersion) = packageKeyToSourceId dflags p in + Private.PackageId { + Private.packageName = Text.pack pkgName + , Private.packageVersion = Maybe.just $ Text.pack pkgVersion + , Private.packageKey = Text.pack $ packageKeyString p + } + +importModuleId :: DynFlags -> GHC.Module -> Private.ModuleId +importModuleId dflags mod = Private.ModuleId { + Private.moduleName = Text.pack $ GHC.moduleNameString $ GHC.moduleName mod + , Private.modulePackage = importPackageId dflags $ modulePackageKey mod + } + +importModuleId' :: DynFlags -> PackageQualifier -> GHC.ModuleName -> Private.ModuleId +importModuleId' dflags pkgQual impMod = Private.ModuleId { + Private.moduleName = Text.pack $ GHC.moduleNameString impMod + , Private.modulePackage = case findExposedModule dflags pkgQual impMod of + Just pkg -> importPackageId dflags pkg + Nothing -> importMainPackage + } + +{------------------------------------------------------------------------------ + Conversions from our types to ghc's types +------------------------------------------------------------------------------} + +exportPackageId :: Public.PackageId -> PackageKey +exportPackageId = stringToPackageKey . Text.unpack . Public.packageKey + +exportModuleId :: Public.ModuleId -> GHC.Module +exportModuleId (Public.ModuleId {..}) = + GHC.mkModule (exportPackageId modulePackage) + (GHC.mkModuleName . Text.unpack $ moduleName) diff --git a/Debug.hs b/Debug.hs new file mode 100644 --- /dev/null +++ b/Debug.hs @@ -0,0 +1,24 @@ +module Debug ( + dVerbosity + , debugFile + , debug + ) where + +import Control.Monad (when) +import qualified Data.ByteString.Char8 as BS +import System.IO (stderr, hFlush) + +dVerbosity :: Int +dVerbosity = 3 + +debugFile :: Maybe FilePath +debugFile = Nothing -- Just "debug.log" + +debug :: Int -> String -> IO () +debug verbosity msg = when (verbosity >= 3) $ do + case debugFile of + Nothing -> return () + Just logName -> appendFile logName $ msg ++ "\n" + when (verbosity >= 4) $ do + BS.hPutStrLn stderr $ BS.pack $ "debug: " ++ msg + hFlush stderr diff --git a/FilePathCaching.hs b/FilePathCaching.hs new file mode 100644 --- /dev/null +++ b/FilePathCaching.hs @@ -0,0 +1,60 @@ +module FilePathCaching ( + MonadFilePathCaching(..) + , mkFilePathPtr + , extractSourceSpan + ) where + +import Control.Monad (liftM) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import System.IO.Unsafe (unsafePerformIO) +import Data.Text (Text) +import qualified Data.Text as Text + +import GHC +import FastString +import MonadUtils + +import IdeSession.Types.Private +import IdeSession.Strict.IORef +import IdeSession.Strict.Pair + +class Monad m => MonadFilePathCaching m where + getFilePathCache :: m (StrictPair (HashMap FilePath Int) Int) + putFilePathCache :: StrictPair (HashMap FilePath Int) Int -> m () + +filePathCacheRef :: StrictIORef (StrictPair (HashMap FilePath Int) Int) +{-# NOINLINE filePathCacheRef #-} +filePathCacheRef = unsafePerformIO $ newIORef $ fromLazyPair (HashMap.empty, 0) + +instance MonadFilePathCaching IO where + getFilePathCache = readIORef filePathCacheRef + putFilePathCache = writeIORef filePathCacheRef + +instance MonadFilePathCaching Ghc where + getFilePathCache = liftIO $ getFilePathCache + putFilePathCache = liftIO . putFilePathCache + +mkFilePathPtr :: MonadFilePathCaching m => FilePath -> m FilePathPtr +mkFilePathPtr path = do + (hash, next) <- toLazyPair `liftM` getFilePathCache + case HashMap.lookup path hash of + Nothing -> do + let next' = next + 1 + putFilePathCache $ fromLazyPair (HashMap.insert path next' hash, next') + return $ FilePathPtr next' + Just key -> + return $ FilePathPtr key + +extractSourceSpan :: MonadFilePathCaching m => SrcSpan -> m EitherSpan +extractSourceSpan (RealSrcSpan srcspan) = do + key <- mkFilePathPtr $ unpackFS (srcSpanFile srcspan) + return . ProperSpan $ SourceSpan + key + (srcSpanStartLine srcspan) (srcSpanStartCol srcspan) + (srcSpanEndLine srcspan) (srcSpanEndCol srcspan) +extractSourceSpan (UnhelpfulSpan s) = + return . TextSpan $ fsToText s + +fsToText :: FastString -> Text +fsToText = Text.pack . unpackFS diff --git a/GhcShim.hs b/GhcShim.hs new file mode 100644 --- /dev/null +++ b/GhcShim.hs @@ -0,0 +1,56 @@ +-- | Abstract over differences in ghc versions +-- +-- NOTE on ways to identity packages: +-- +-- * "Source IDs" consist of a package name and a version: foo-1.0 +-- * "Package Keys" are a hash of a package's source ID and the source IDs of +-- all its transitive dependencies. It is used internally by ghc to construct +-- FQN and to construct linker symbols. +-- * "Installed IDs" uniquely identifies a particular build of a package: its +-- version, its build time configuration flags, and the installed IDs for all +-- its transitive dependencies. +-- +-- GHC cannot simultaneously load multiple packages that have different +-- installed IDs but identical package keys (amongst other things, this would +-- result in linker errors about multiply defined symbols). When GHC loads +-- packages from the package DB, it extract package keys, and it indices the +-- package DB by package key; installed IDs do not feature internally in GHC. +-- +-- Prior to version 7.10 ghc used a fourth way to identify a package, which was +-- variously known as a packageId or a packageName. This package ID was +-- basically a flat string version of the Source ID. As of version 7.10 this +-- concept is replaced in favour of the package key. In the shim we paper over +-- this by calling the internal ID used by GHC a "package key" always, and map +-- that to a packageId for older versions. +-- +-- In addition, we have our _own_ datatype which is (somewhat unfortunately) +-- called a PackageId; this corresponds to a source ID. +{-# LANGUAGE CPP #-} +module GhcShim ( + module GhcShim.API +#ifdef GHC_742 + , module GhcShim.GhcShim742 +#endif +#ifdef GHC_78 + , module GhcShim.GhcShim78 +#endif +#ifdef GHC_710 + , module GhcShim.GhcShim710 +#endif + ) where + +import GhcShim.API + +#ifdef GHC_742 +import GhcShim.GhcShim742 +#else +#ifdef GHC_78 +import GhcShim.GhcShim78 +#else +#ifdef GHC_710 +import GhcShim.GhcShim710 +#else +#error "Unsupported GHC version" +#endif +#endif +#endif diff --git a/GhcShim/API.hs b/GhcShim/API.hs new file mode 100644 --- /dev/null +++ b/GhcShim/API.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances #-} +module GhcShim.API ( + -- * Traversing the AST + IsBinder(..) + , AstAlg(..) + , Fold(..) + , FoldPhase(..) + ) where + +import Type (Type) +import SrcLoc (SrcSpan, Located) +import Name (Name) +import Var (Var) + +-- | Is this a binding occurrence of @f@? +data IsBinder = + DefSite -- ^ @f = ..@ + | UseSite -- ^ @g = f ..@ + | SigSite -- ^ @f :: ..@ or fixity declaration + +-- | The "algebra" that we use while traversing the AST. +-- +-- This is not a general purpose fold; we look for identifiers and types. +data AstAlg m id = AstAlg { + -- | Mark a branch point in the AST + astMark :: Maybe SrcSpan -> String -> m (Maybe Type) -> m (Maybe Type) + -- | Throw a runtime error + , astUnsupported :: Maybe SrcSpan -> String -> m (Maybe Type) + -- | Found a subexpression type + , astExpType :: SrcSpan -> Maybe Type -> m (Maybe Type) + -- | Found a 'Name' (i.e., pre type checking) + , astId :: IsBinder -> Located id -> m (Maybe Type) + -- | Are we running pre or post type checking? + , astPhase :: FoldPhase id + } + +class Fold id a where + fold :: Monad m => AstAlg m id -> a -> m (Maybe Type) + +data FoldPhase id where + FoldPreTc :: FoldPhase Name + FoldPostTc :: FoldPhase Var + +instance Fold id a => Fold id [a] where + fold alg xs = do + mapM_ (fold alg) xs + return Nothing + +instance Fold id a => Fold id (Maybe a) where + fold _alg Nothing = return Nothing + fold alg (Just x) = fold alg x diff --git a/GhcShim/GhcShim710.hs b/GhcShim/GhcShim710.hs new file mode 100644 --- /dev/null +++ b/GhcShim/GhcShim710.hs @@ -0,0 +1,1654 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, StandaloneDeriving, MultiParamTypeClasses, GADTs #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-} +module GhcShim.GhcShim710 + ( -- * Pretty-printing + showSDoc + , pretty + , prettyM + , prettyType + , prettyTypeM + -- * Errors + , sourceErrorSpan + -- * Breakpoints + , getBreak + , setBreak + -- * Time + , GhcTime + -- * Setup + , ghcGetVersion + , packageDBFlags + , setGhcOptions + , storeDynFlags + -- * Package keys (see GhcShim.hs). + , PackageKey + , PackageQualifier + , lookupPackage + , mainPackageKey + , modulePackageKey + , packageKeyString + , stringToPackageKey + , packageKeyToSourceId + , findExposedModule + -- * Folding + , AstAlg(..) + , fold + -- * Operations on types + , typeOfTyThing + -- * Re-exports + , tidyOpenType + ) where + +import Prelude hiding (id, span) +import Control.Monad (void, forM_, liftM) +import Data.IORef +import Data.Time (UTCTime) +import Data.Version +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Maybe as Maybe + +import Bag +import BasicTypes hiding (Version) +import ConLike (ConLike(RealDataCon)) +import DataCon (dataConRepType) +import DynFlags +import ErrUtils +import FastString +import GHC hiding (getBreak) +import Linker +import Module +import MonadUtils +import Outputable hiding (showSDoc) +import PackageConfig +import Pair +import PprTyThing +import Pretty +import SrcLoc +import TcEvidence +import TcHsSyn +import TcType +import Type +import TysWiredIn +import qualified BreakArray +import qualified Packages + +import qualified Distribution.Package as Cabal +import qualified Distribution.Text as Cabal +import qualified Distribution.Compat.ReadP as Cabal + +import GhcShim.API +import IdeSession.GHC.API (GhcVersion(..)) + +{------------------------------------------------------------------------------ + Pretty-printing +------------------------------------------------------------------------------} + +showSDoc :: DynFlags -> PprStyle -> SDoc -> String +showSDoc dflags pprStyle doc = + showDoc OneLineMode 100 + $ runSDoc doc + $ initSDocContext dflags pprStyle + +pretty :: Outputable a => DynFlags -> PprStyle -> a -> String +pretty dynFlags pprStyle = showSDoc dynFlags pprStyle . ppr + +prettyType :: DynFlags -> PprStyle -> Bool -> Type -> String +prettyType dynFlags pprStyle showForalls typ = + showSDoc dynFlags' pprStyle (pprTypeForUser typ) + where + dynFlags' :: DynFlags + dynFlags' | showForalls = dynFlags `gopt_set` Opt_PrintExplicitForalls + | otherwise = dynFlags `gopt_unset` Opt_PrintExplicitForalls + +prettyM :: (Outputable a, Monad m, HasDynFlags m) => PprStyle -> a -> m String +prettyM pprStyle x = do + dynFlags <- getDynFlags + return (pretty dynFlags pprStyle x) + +prettyTypeM :: (Monad m, HasDynFlags m) => PprStyle -> Bool -> Type -> m String +prettyTypeM pprStyle showForalls typ = do + dynFlags <- getDynFlags + return $ prettyType dynFlags pprStyle showForalls typ + +{------------------------------------------------------------------------------ + Show instances +------------------------------------------------------------------------------} + +deriving instance Show Severity + +{------------------------------------------------------------------------------ + Source errors +------------------------------------------------------------------------------} + +sourceErrorSpan :: ErrMsg -> Maybe SrcSpan +sourceErrorSpan errMsg = case errMsgSpan errMsg of + real@RealSrcSpan{} -> Just real + _ -> Nothing + +{------------------------------------------------------------------------------ + Breakpoints +------------------------------------------------------------------------------} + +getBreak :: BreakArray -> Int -> Ghc (Maybe Bool) +getBreak array index = do + dflags <- getDynFlags + val <- liftIO $ BreakArray.getBreak dflags array index + return ((== 1) `liftM` val) + +setBreak :: BreakArray -> Int -> Bool -> Ghc () +setBreak array index value = do + dflags <- getDynFlags + void . liftIO $ if value then BreakArray.setBreakOn dflags array index + else BreakArray.setBreakOff dflags array index + +{------------------------------------------------------------------------------ + Time +------------------------------------------------------------------------------} + +type GhcTime = UTCTime + +{------------------------------------------------------------------------------ + Setup +------------------------------------------------------------------------------} + +ghcGetVersion :: GhcVersion +ghcGetVersion = GHC_7_10 + +packageDBFlags :: Bool -> [String] -> [String] +packageDBFlags userDB specificDBs = + ["-no-user-package-db" | not userDB] + ++ concat [["-package-db", db] | db <- specificDBs] + +-- | Set GHC options +-- +-- This is meant to be stateless. It is important to call storeDynFlags at least +-- once before calling setGhcOptions so that we know what state to restore to +-- before setting the options. +-- +-- Returns unrecognized options and warnings +setGhcOptions :: [String] -> Ghc ([String], [String]) +setGhcOptions opts = do + dflags <- restoreDynFlags + (dflags', leftover, warnings) <- parseDynamicFlags dflags (map noLoc opts) + setupLinkerState =<< setSessionDynFlags dflags' + return (map unLoc leftover, map unLoc warnings) + +-- | Setup linker state to deal with changed package flags +-- +-- This follows newDynFlags in ghci, except that in 7.8 there is also the +-- notion of "interactive dynflags", which we are ignoring completely. +-- I'm not sure if that's ok or not. +setupLinkerState :: [PackageKey] -> Ghc () +setupLinkerState newPackages = do + dflags <- getSessionDynFlags + setTargets [] + load LoadAllTargets + liftIO $ linkPackages dflags newPackages + +{------------------------------------------------------------------------------ + Backup DynFlags + + Sadly, this hardcodes quite a bit of version-specific information about ghc's + inner workings. Unfortunately, there is no easy way to know which parts of + DynFlags should and should not be restored to restore flags. The flag + specification is given by (see packageDynamicFlags in compiler/main/GHC.hs) + + > package_flags ++ dynamic_flags + + both of which are defined in DynFlags.hs. They are not exported, but this + would not be particularly useful anyway, as the action associated with a + flag is given by a shallow embedding, so we cannot walk over them and extract + the necessary info about DynFlags. At least, we cannot do that in code -- we + can do it manually, and that is precisely what I've done to obtain the list + below. Of course, this means it's somewhat error prone. + + In order so that this code can be audited and cross-checked against the + actual ghc version, and so that it can be modified for future ghc versions, + we don't just list the end result if this manual traversal, but document the + process. + + Each of the command line options are defined in terms of a auxiliary + functions that specify their effect on DynFlags. These auxiliary functions + are listed below, along with which parts of DynFlags they modify: + + > FUNCTION MODIFIES FIELD(s) OF DYNFLAGS + > ---------------------------------------------------------------------------- + > addCmdlineFramework cmdlineFrameworks + > addCmdlineHCInclude cmdlineHcIncludes + > addDepExcludeMod depExcludeMods + > addDepSuffix depSuffixes + > addFrameworkPath frameworkPaths + > addGhciScript ghciScripts + > addHaddockOpts haddockOptions + > addImportPath importPaths + > addIncludePath includePaths + > addLdInputs ldInputs + > addLibraryPath libraryPaths + > addOptP settings + > addOptc settings + > addOptl settings + > addPkgConfRef extraPkgConfs + > addPluginModuleName pluginModNames + > addPluginModuleNameOption pluginModNameOpts + > addWay ways, packageFlags, extensions, extensionFlags, generalFlags + > alterSettings settings + > clearPkgConf extraPkgConfs + > disableGlasgowExts generalFlags, extensions, extensionFlags + > distrustPackage packageFlags + > enableGlasgowExts generalFlags, extensions, extensionFlags + > exposePackage packageFlags + > exposePackageId packageFlags + > exposePackageKey packageFlags + > forceRecompile generalFlags + > hidePackage packageFlags + > ignorePackage packageFlags + > parseDynLibLoaderMode dynLibLoader + > removeGlobalPkgConf extraPkgConfs + > removeUserPkgConf extraPkgConfs + > removeWayDyn ways + > setDPHOpt optLevel, generalFlags, maxSimplIterations, simplPhases + > setDepIncludePkgDeps depIncludePkgDeps + > setDepMakefile depMakefile + > setDumpDir dumpDir + > setDumpFlag dumpFlags, generalFlags + > setDumpFlag' dumpFlags, generalFlags + > setDumpPrefixForce dumpPrefixForce + > setDylibInstallName dylibInstallName + > setDynHiSuf dynHiSuf + > setDynObjectSuf dynObjectSuf + > setDynOutputFile dynOutputFile + > setExtensionFlag extensions, extensionFlags + > setGeneralFlag generalFlags + > setHcSuf hcSuf + > setHiDir hiDir + > setHiSuf hiSuf + > setInteractivePrint interactivePrint + > setLanguage language, extensionFlags + > setMainIs mainFunIs, mainModIs + > setObjTarget hscTarget + > setObjectDir objectDir + > setObjectSuf objectSuf + > setOptHpcDir hpcDir + > setOptLevel optLevel, generalFlags + > setOutputDir objectDir, hiDir, stubDir, dumpDir + > setOutputFile outputFile + > setOutputHi outputHi + > setPackageKey thisPackage + > setPackageTrust generalFlags, pkgTrustOnLoc + > setPgmP settings + > setRtsOpts rtsOpts + > setRtsOptsEnabled rtsOptsEnabled + > setSafeHaskell safeHaskell, safeInfer, trustworthyOnLoc + > setSigOf sigOf + > setStubDir stubDir, includePaths + > setTarget hscTarget + > setTargetWithPlatform hscTarget + > setTmpDir settings + > setVerboseCore2Core dumpFlags, generalFlags + > setVerbosity verbosity + > setWarningFlag warningFlags + > trustPackage packageFlags + > unSetExtensionFlag extensions, extensionFlags + > unSetGeneralFlag generalFlags + > unSetWarningFlag warningFlags + + Below is a list of the dynamic_flags in alphabetical order along with the + auxiliary function that they use. A handful of these flags define their + effect on DynFlags directly; these are marked (**). + + > FLAG DEFINED IN TERMS OF + > ---------------------------------------------------------------------------- + > "#include" addCmdlineHCInclude + > "D" addOptP + > "F" setGeneralFlag + > "H" ** sets ghcHeapSize + > "I" addIncludePath + > "L" addLibraryPath + > "O" setOptLevel + > "O" setOptLevel + > "Odph" setDPHOpt + > "Onot" setOptLevel + > "Rghc-timing" ** sets enableTimeStats + > "U" addOptP + > "W" setWarningFlag + > "Wall" setWarningFlag + > "Werror" setGeneralFlag + > "Wnot" ** sets warningFlags + > "Wwarn" unSetGeneralFlag + > "auto" ** sets profAuto + > "auto-all" ** sets profAuto + > "caf-all" setGeneralFlag + > "cpp" setExtensionFlag + > "dannot-lint" setGeneralFlag + > "dasm-lint" setGeneralFlag + > "dcmm-lint" setGeneralFlag + > "dcore-lint" setGeneralFlag + > "ddump-asm" setDumpFlag + > "ddump-asm-conflicts" setDumpFlag + > "ddump-asm-expanded" setDumpFlag + > "ddump-asm-liveness" setDumpFlag + > "ddump-asm-native" setDumpFlag + > "ddump-asm-regalloc" setDumpFlag + > "ddump-asm-regalloc-stages" setDumpFlag + > "ddump-asm-stats" setDumpFlag + > "ddump-bcos" setDumpFlag + > "ddump-call-arity" setDumpFlag + > "ddump-cmm" setDumpFlag + > "ddump-cmm-cbe" setDumpFlag + > "ddump-cmm-cfg" setDumpFlag + > "ddump-cmm-cps" setDumpFlag + > "ddump-cmm-info" setDumpFlag + > "ddump-cmm-proc" setDumpFlag + > "ddump-cmm-procmap" setDumpFlag + > "ddump-cmm-raw" setDumpFlag + > "ddump-cmm-sink" setDumpFlag + > "ddump-cmm-sp" setDumpFlag + > "ddump-cmm-split" setDumpFlag + > "ddump-core-stats" setDumpFlag + > "ddump-cs-trace" setDumpFlag + > "ddump-cse" setDumpFlag + > "ddump-debug" setDumpFlag + > "ddump-deriv" setDumpFlag + > "ddump-ds" setDumpFlag + > "ddump-file-prefix" setDumpPrefixForce + > "ddump-foreign" setDumpFlag + > "ddump-hi" setDumpFlag + > "ddump-hi-diffs" setDumpFlag + > "ddump-hpc" setDumpFlag + > "ddump-if-trace" setDumpFlag + > "ddump-inlinings" setDumpFlag + > "ddump-llvm" setObjTarget, setDumpFlag' + > "ddump-minimal-imports" setGeneralFlag + > "ddump-mod-cycles" setDumpFlag + > "ddump-mod-map" setDumpFlag + > "ddump-occur-anal" setDumpFlag + > "ddump-opt-cmm" setDumpFlag + > "ddump-parsed" setDumpFlag + > "ddump-prep" setDumpFlag + > "ddump-rn" setDumpFlag + > "ddump-rn-stats" setDumpFlag + > "ddump-rn-trace" setDumpFlag + > "ddump-rtti" setDumpFlag + > "ddump-rule-firings" setDumpFlag + > "ddump-rule-rewrites" setDumpFlag + > "ddump-rules" setDumpFlag + > "ddump-simpl" setDumpFlag + > "ddump-simpl-iterations" setDumpFlag + > "ddump-simpl-stats" setDumpFlag + > "ddump-simpl-trace" setDumpFlag + > "ddump-spec" setDumpFlag + > "ddump-splices" setDumpFlag + > "ddump-stg" setDumpFlag + > "ddump-stranal" setDumpFlag + > "ddump-strsigs" setDumpFlag + > "ddump-tc" setDumpFlag + > "ddump-tc-trace" setDumpFlag' + > "ddump-ticked" setDumpFlag + > "ddump-to-file" setGeneralFlag + > "ddump-types" setDumpFlag + > "ddump-vect" setDumpFlag + > "ddump-view-pattern-commoning" setDumpFlag + > "ddump-vt-trace" setDumpFlag + > "ddump-worker-wrapper" setDumpFlag + > "debug" addWay + > "dep-makefile" setDepMakefile + > "dep-suffix" addDepSuffix + > "dfaststring-stats" setGeneralFlag + > "dll-split" ** sets dllSplitFile, dllSplit + > "dno-llvm-mangler" setGeneralFlag + > "dppr-cols" ** sets pprCols + > "dppr-user-length" ** sets pprUserLength + > "dshow-passes" forceRecompile, setVerbosity + > "dsource-stats" setDumpFlag + > "dstg-lint" setGeneralFlag + > "dstg-stats" setGeneralFlag + > "dsuppress-all" setGeneralFlag + > "dth-dec-file" setDumpFlag + > "dtrace-level" ** sets traceLevel + > "dumpdir" setDumpDir + > "dverbose-core2core" setVerbosity, setVerboseCore2Core + > "dverbose-stg2stg" setDumpFlag + > "dylib-install-name" setDylibInstallName + > "dynamic" addWay + > "dynamic-too" setGeneralFlag + > "dynhisuf" setDynHiSuf + > "dynload" parseDynLibLoaderMode + > "dyno" setDynOutputFile + > "dynosuf" setDynObjectSuf + > "eventlog" addWay + > "exclude-module" addDepExcludeMod + > "fPIC" setGeneralFlag + > "fasm" setObjTarget + > "fbyte-code" setTarget + > "fcontext-stack" ** sets ctxtStkDepth + > "ffloat-all-lams" ** sets floatLamArgs + > "ffloat-lam-args" ** sets floatLamArgs + > "fghci-hist-size" ** sets ghciHistSize + > "fglasgow-exts" enableGlasgowExts + > "fhistory-size" ** sets historySize + > "fliberate-case-threshold" ** sets liberateCaseThreshold + > "fllvm" setObjTarget + > "fmax-inline-alloc-size" ** sets maxInlineAllocSize + > "fmax-inline-memcpy-insns" ** sets maxInlineMemcpyInsns + > "fmax-inline-memset-insns" ** sets maxInlineMemsetInsns + > "fmax-relevant-binds" ** sets maxRelevantBinds + > "fmax-simplifier-iterations" ** sets maxSimplIterations + > "fmax-worker-args" ** sets maxWorkerArgs + > "fno-PIC" unSetGeneralFlag + > "fno-code" setTarget, ** sets ghcLink + > "fno-glasgow-exts" disableGlasgowExts + > "fno-liberate-case-threshold" ** sets liberateCaseThreshold + > "fno-max-relevant-binds" ** sets maxRelevantBinds + > "fno-prof-auto" ** sets profAuto + > "fno-safe-infer" ** sets safeInfer + > "fno-spec-constr-count" ** sets specConstrCount + > "fno-spec-constr-threshold" ** sets specConstrThreshold + > "fobject-code" setTargetWithPlatform + > "fpackage-trust" setPackageTrust + > "fplugin" addPluginModuleName + > "fplugin-opt" addPluginModuleNameOption + > "fprof-auto" ** sets profAuto + > "fprof-auto-calls" ** sets profAuto + > "fprof-auto-exported" ** sets profAuto + > "fprof-auto-top" ** sets profAuto + > "framework" addCmdlineFramework + > "framework-path" addFrameworkPath + > "frule-check" ** sets ruleCheck + > "fsimpl-tick-factor" ** sets simplTickFactor + > "fsimplifier-phases" ** sets simplPhases + > "fspec-constr-count" ** sets specConstrCount + > "fspec-constr-recursive" ** sets specConstrRecursive + > "fspec-constr-threshold" ** sets specConstrThreshold + > "fstrictness-before" ** sets strictnessBefore + > "ftype-function-depth" ** sets tyFunStkDepth + > "funfolding-creation-threshold" ** sets ufCreationThreshold + > "funfolding-dict-discount" ** sets ufDictDiscount + > "funfolding-fun-discount" ** sets ufFunAppDiscount + > "funfolding-keeness-factor" ** sets ufKeenessFactor + > "funfolding-use-threshold" ** sets ufUseThreshold + > "fvia-C" <> + > "fvia-c" <> + > "g" setGeneralFlag + > "ghci-script" addGhciScript + > "gransim" addWay + > "haddock" setGeneralFlag + > "haddock-opts" addHaddockOpts + > "hcsuf" setHcSuf + > "hidir" setHiDir + > "hisuf" setHiSuf + > "hpcdir" setOptHpcDir + > "i" addImportPath + > "include-pkg-deps" setDepIncludePkgDeps + > "interactive-print" setInteractivePrint + > "j" ** sets parMakeCount + > "keep-hc-file" setGeneralFlag + > "keep-hc-files" setGeneralFlag + > "keep-llvm-file" setObjTarget, setGeneralFlag + > "keep-llvm-files" setObjTarget, setGeneralFlag + > "keep-s-file" setGeneralFlag + > "keep-s-files" setGeneralFlag + > "keep-tmp-files" setGeneralFlag + > "l" addLdInputs + > "main-is" setMainIs + > "mavx" ** sets avx + > "mavx2" ** sets avx2 + > "mavx512cd" ** sets avx512cd + > "mavx512er" ** sets avx512er + > "mavx512f" ** sets avx512f + > "mavx512pf" ** sets avx512pf + > "msse" ** sets sseVersion + > "msse2" ** sets sseVersion + > "msse3" ** sets sseVersion + > "msse4" ** sets sseVersion + > "msse4.2" ** sets sseVersion + > "n" <> + > "ndp" addWay + > "no-auto" ** sets profAuto + > "no-auto-all" ** sets profAuto + > "no-auto-link-packages" unSetGeneralFlag + > "no-caf-all" unSetGeneralFlag + > "no-hs-main" setGeneralFlag + > "no-link" ** sets ghcLink + > "no-recomp" setGeneralFlag + > "no-rtsopts" setRtsOptsEnabled + > "o" setOutputFile + > "odir" setObjectDir + > "ohi" setOutputHi + > "optF" alterSettings + > "optL" alterSettings + > "optP" addOptP + > "opta" alterSettings + > "optc" addOptc + > "optl" addOptl + > "optlc" alterSettings + > "optlo" alterSettings + > "optwindres" alterSettings + > "osuf" setObjectSuf + > "outputdir" setOutputDir + > "parallel" addWay + > "pgmF" alterSettings + > "pgmL" alterSettings + > "pgmP" setPgmP + > "pgma" alterSettings + > "pgmc" alterSettings + > "pgmdll" alterSettings + > "pgml" alterSettings + > "pgmlc" alterSettings + > "pgmlibtool" alterSettings + > "pgmlo" alterSettings + > "pgms" alterSettings + > "pgmwindres" alterSettings + > "prof" addWay + > "rdynamic" addOptl + > "recomp" unSetGeneralFlag + > "relative-dynlib-paths" setGeneralFlag + > "rtsopts" setRtsOptsEnabled + > "rtsopts=all" setRtsOptsEnabled + > "rtsopts=none" setRtsOptsEnabled + > "rtsopts=some" setRtsOptsEnabled + > "shared" ** sets ghcLink + > "sig-of" setSigOf + > "smp" addWay + > "split-objs" setGeneralFlag + > "static" removeWayDyn + > "staticlib" ** sets ghcLink + > "stubdir" setStubDir + > "threaded" addWay + > "ticky" setGeneralFlag, addWay + > "ticky-LNE" setGeneralFlag + > "ticky-allocd" setGeneralFlag + > "ticky-dyn-thunk" setGeneralFlag + > "tmpdir" setTmpDir + > "v" setVerbosity + > "w" ** sets warningFlags + > "with-rtsopts" setRtsOpts + + Finally, there is a bunch of flags defined in terms of setGeneralFlag, + unSetGeneralFlag, setWarningFlag, unSetWarningFlag, setExtensionFlag, + unSetExtensionFlag, setLanguage, and setSafeHaskell. + + The same list for package_flags: + + > FLAG DEFINED IN TERMS OF + > -------------------------------------------- + > "clear-package-db" clearPkgConf + > "distrust" distrustPackage + > "distrust-all-packages" setGeneralFlag + > "global-package-db" addPkgConfRef + > "hide-all-packages" setGeneralFlag + > "hide-package" hidePackage + > "ignore-package" ignorePackage + > "no-global-package-db" removeGlobalPkgConf + > "no-user-package-conf" removeUserPkgConf + > "no-user-package-db" removeUserPkgConf + > "package" exposePackage + > "package-conf" addPkgConfRef + > "package-db" addPkgConfRef + > "package-env" ** sets packageEnv + > "package-id" exposePackageId + > "package-key" exposePackageKey + > "package-name" setPackageKey + > "syslib" exposePackage + > "this-package-key" setPackageKey + > "trust" trustPackage + > "user-package-db" addPkgConfRef + + In addition to the above, we also reset one more field: pkgDatabase. The + pkgDatabase is initialized on the first call to initPackages (and hence the + first call to setSessionDynFlags), which happens at server startup. After + that, subsequent calls to setSessionDynFlags take the _existing_ pkgDatabase, + but applies the "batch package flags" to it (hide-all-packages, + distrust-all-packages). However, it doesn't "unapply" these batch flags. By + restoring the pkgDatabase to the value it gets at server startup, we + effectively restore these batch flags whenever we apply user settings. +------------------------------------------------------------------------------} + +dynFlagsRef :: IORef DynFlags +{-# NOINLINE dynFlagsRef #-} +dynFlagsRef = unsafePerformIO $ newIORef (error "No DynFlags stored yet") + +storeDynFlags :: Ghc () +storeDynFlags = do + dynFlags <- getSessionDynFlags + liftIO $ writeIORef dynFlagsRef dynFlags + +restoreDynFlags :: Ghc DynFlags +restoreDynFlags = do + storedDynFlags <- liftIO $ readIORef dynFlagsRef + currentDynFlags <- getSessionDynFlags + return (currentDynFlags `restoreDynFlagsFrom` storedDynFlags) + +-- | Copy over all fields of DynFlags that are affected by dynamic_flags +-- and package_flags (and only those) +-- +-- See detailed description above. +restoreDynFlagsFrom :: DynFlags -> DynFlags -> DynFlags +restoreDynFlagsFrom new old = new { + avx = avx old + , avx2 = avx2 old + , avx512cd = avx512cd old + , avx512er = avx512er old + , avx512f = avx512f old + , avx512pf = avx512pf old + , cmdlineFrameworks = cmdlineFrameworks old + , cmdlineHcIncludes = cmdlineHcIncludes old + , ctxtStkDepth = ctxtStkDepth old + , depExcludeMods = depExcludeMods old + , depIncludePkgDeps = depIncludePkgDeps old + , depMakefile = depMakefile old + , depSuffixes = depSuffixes old + , dllSplit = dllSplit old + , dllSplitFile = dllSplitFile old + , dumpDir = dumpDir old + , dumpFlags = dumpFlags old + , dumpPrefixForce = dumpPrefixForce old + , dylibInstallName = dylibInstallName old + , dynHiSuf = dynHiSuf old + , dynLibLoader = dynLibLoader old + , dynObjectSuf = dynObjectSuf old + , dynOutputFile = dynOutputFile old + , enableTimeStats = enableTimeStats old + , extensionFlags = extensionFlags old + , extensions = extensions old + , extraPkgConfs = extraPkgConfs old + , floatLamArgs = floatLamArgs old + , frameworkPaths = frameworkPaths old + , generalFlags = generalFlags old + , ghcHeapSize = ghcHeapSize old + , ghcLink = ghcLink old + , ghciHistSize = ghciHistSize old + , ghciScripts = ghciScripts old + , haddockOptions = haddockOptions old + , hcSuf = hcSuf old + , hiDir = hiDir old + , hiSuf = hiSuf old + , historySize = historySize old + , hpcDir = hpcDir old + , hscTarget = hscTarget old + , importPaths = importPaths old + , includePaths = includePaths old + , interactivePrint = interactivePrint old + , language = language old + , ldInputs = ldInputs old + , liberateCaseThreshold = liberateCaseThreshold old + , libraryPaths = libraryPaths old + , mainFunIs = mainFunIs old + , mainModIs = mainModIs old + , maxInlineAllocSize = maxInlineAllocSize old + , maxInlineMemcpyInsns = maxInlineMemcpyInsns old + , maxInlineMemsetInsns = maxInlineMemsetInsns old + , maxRelevantBinds = maxRelevantBinds old + , maxSimplIterations = maxSimplIterations old + , maxWorkerArgs = maxWorkerArgs old + , objectDir = objectDir old + , objectSuf = objectSuf old + , optLevel = optLevel old + , outputFile = outputFile old + , outputHi = outputHi old + , packageEnv = packageEnv old + , packageFlags = packageFlags old + , parMakeCount = parMakeCount old + , pkgDatabase = pkgDatabase old + , pkgTrustOnLoc = pkgTrustOnLoc old + , pluginModNameOpts = pluginModNameOpts old + , pluginModNames = pluginModNames old + , pprCols = pprCols old + , pprUserLength = pprUserLength old + , profAuto = profAuto old + , rtsOpts = rtsOpts old + , rtsOptsEnabled = rtsOptsEnabled old + , ruleCheck = ruleCheck old + , safeHaskell = safeHaskell old + , safeInfer = safeInfer old + , settings = settings old + , sigOf = sigOf old + , simplPhases = simplPhases old + , simplTickFactor = simplTickFactor old + , specConstrCount = specConstrCount old + , specConstrRecursive = specConstrRecursive old + , specConstrThreshold = specConstrThreshold old + , sseVersion = sseVersion old + , strictnessBefore = strictnessBefore old + , stubDir = stubDir old + , thisPackage = thisPackage old + , traceLevel = traceLevel old + , trustworthyOnLoc = trustworthyOnLoc old + , tyFunStkDepth = tyFunStkDepth old + , ufCreationThreshold = ufCreationThreshold old + , ufDictDiscount = ufDictDiscount old + , ufFunAppDiscount = ufFunAppDiscount old + , ufKeenessFactor = ufKeenessFactor old + , ufUseThreshold = ufUseThreshold old + , verbosity = verbosity old + , warningFlags = warningFlags old + , ways = ways old + } + +{------------------------------------------------------------------------------- + Package keys +-------------------------------------------------------------------------------} + +type PackageQualifier = Maybe FastString + +-- | Lookup a package by package key +-- +-- Throws a runtime error when the package cannot be found (since these +-- package keys from from ghc and/or haddock, we should never ever be +-- presented with an invalid key). +lookupPackage :: DynFlags -> PackageKey -> PackageConfig +lookupPackage dflags pkey = + Maybe.fromMaybe + (error $ "lookupPackage: invalid key " ++ packageKeyString pkey) + (Packages.lookupPackage dflags pkey) + +-- | Translate a package key to a source ID (name and version) +-- +-- See comments for `lookupPackage` about runtime errors. +-- +-- From 7.10 ghc maintains version numbers even for built-in packages, so +-- earlier tricks to recover this information are no longer necessary. +packageKeyToSourceId :: DynFlags -> PackageKey -> (String, String) +packageKeyToSourceId dflags p = + let pkgCfg = lookupPackage dflags p + srcId = sourcePackageIdParsed pkgCfg + name = pkgName srcId + version = Cabal.pkgVersion srcId + in (name, showVersion (stripInPlace version)) + where + stripInPlace :: Version -> Version + stripInPlace (Version bs ts) = Version bs (filter (/= "inplace") ts) + +-- | Find an exposed module in an exposed package +-- +-- Prior to ghc 7.10 we had to manually filter out non-exposed modules or +-- modules in non-exposed packages; however, from 7.10 this is done for us (see +-- `lookupModuleInAllPackages` and `LookupResult`, in particular haddock for +-- `LookupHidden` and the fact that `lookupModuleInAllPackages` returns an +-- empty list for a `LookupHidden` result). +-- +-- TODO: On the other hand, we now need to _parse_ the source ID for every +-- patch, because we only store the source IDs in flat form. Perhaps we need +-- to think about how to make this more efficient. +findExposedModule :: DynFlags -> PackageQualifier -> ModuleName -> Maybe PackageKey +findExposedModule dflags pkgQual impMod = Maybe.listToMaybe pkgIds + where + pkgAll = map snd $ Packages.lookupModuleInAllPackages dflags impMod + pkgMatching = filter (matchesQual pkgQual) pkgAll + pkgIds = map Packages.packageConfigId pkgMatching + + matchesQual :: PackageQualifier -> PackageConfig -> Bool + matchesQual Nothing _ = True + matchesQual (Just fs) p = unpackFS fs == pkgName (sourcePackageIdParsed p) + +{------------------------------------------------------------------------------ + Traversing the AST +------------------------------------------------------------------------------} + +ifPostTc :: AstAlg m id -> a -> Maybe a +ifPostTc alg a = + case astPhase alg of + FoldPreTc -> Nothing + FoldPostTc -> Just a + +ifPostTcType :: AstAlg m id -> PostTc id Type -> Maybe Type +ifPostTcType alg a = + case astPhase alg of + FoldPreTc -> Nothing + FoldPostTc -> Just a + +instance Fold id (HsGroup id) where + fold alg HsGroup { hs_valds + , hs_tyclds + , hs_instds + , hs_derivds + , hs_fixds + , hs_defds + , hs_fords + , hs_warnds + , hs_annds + , hs_ruleds + , hs_vects + , hs_docs } = astMark alg Nothing "HsGroup" $ do + fold alg hs_valds + fold alg hs_tyclds + fold alg hs_instds + fold alg hs_derivds + fold alg hs_fixds + fold alg hs_defds + fold alg hs_fords + fold alg hs_warnds + fold alg hs_annds + fold alg hs_ruleds + fold alg hs_vects + fold alg hs_docs + +instance Fold id (HsValBinds id) where + fold _alg (ValBindsIn {}) = + fail "fold alg: Unexpected ValBindsIn" + fold alg (ValBindsOut binds sigs) = astMark alg Nothing "ValBindsOut" $ do + fold alg (map snd binds) + -- ValBindsOut specifically stores Names, independent of the phase. + -- Traverse only in the right mode (types force this) + case astPhase alg of + FoldPreTc -> fold alg sigs + FoldPostTc -> return Nothing + +instance Fold id (LSig id) where + fold alg (L span (TypeSig names tp _wildcards)) = astMark alg (Just span) "TypeSig" $ do + forM_ names $ astId alg SigSite + fold alg tp + fold alg (L span (PatSynSig name + _{-TODO?: (HsPatSynDetails (LHsType name))-} + tp + _{-TODO?: (LHsContext name)-} + _{-TODO?: (LHsContext name)-}) + ) = astMark alg (Just span) "PatSynSig" $ do + astId alg SigSite name + fold alg tp + fold alg (L span (GenericSig names tp)) = astMark alg (Just span) "GenericSig" $ do + forM_ names $ astId alg SigSite + fold alg tp + + -- Only in generated code + fold alg (L span (IdSig _)) = astMark alg (Just span) "IdSig" $ + return Nothing + + -- Annotations + fold alg (L span (FixSig _)) = astMark alg (Just span) "FixSig" $ + return Nothing + fold alg (L span (InlineSig _ _)) = astMark alg (Just span) "InlineSig" $ + return Nothing + fold alg (L span (SpecSig _ _ _)) = astMark alg (Just span) "SpecSig" $ + return Nothing + fold alg (L span (SpecInstSig _ _)) = astMark alg (Just span) "SpecInstSig" $ + return Nothing + fold alg (L span (MinimalSig _ _)) = astMark alg (Just span) "MinimalSig" $ + return Nothing + +instance Fold id (LHsType id) where + fold alg (L span (HsFunTy arg res)) = astMark alg (Just span) "HsFunTy" $ + fold alg [arg, res] + fold alg (L span (HsTyVar name)) = astMark alg (Just span) "HsTyVar" $ + astId alg UseSite (L span name) + fold alg (L span (HsForAllTy explicitFlag _wildcards tyVars ctxt body)) = astMark alg (Just span) "hsForAllTy" $ do + -- only traverse type variables if the user explicitly listed them + -- (see `hsExplicitTvs`) + case explicitFlag of + Explicit -> fold alg tyVars + Implicit -> return Nothing + Qualified -> return Nothing + fold alg ctxt + fold alg body + fold alg (L span (HsAppTy fun arg)) = astMark alg (Just span) "HsAppTy" $ + fold alg [fun, arg] + fold alg (L span (HsTupleTy _tupleSort typs)) = astMark alg (Just span) "HsTupleTy" $ + -- tupleSort is unboxed/boxed/etc. + fold alg typs + fold alg (L span (HsListTy typ)) = astMark alg (Just span) "HsListTy" $ + fold alg typ + fold alg (L span (HsPArrTy typ)) = astMark alg (Just span) "HsPArrTy" $ + fold alg typ + fold alg (L span (HsParTy typ)) = astMark alg (Just span) "HsParTy" $ + fold alg typ + fold alg (L span (HsEqTy a b)) = astMark alg (Just span) "HsEqTy" $ + fold alg [a, b] + fold alg (L span (HsDocTy typ _doc)) = astMark alg (Just span) "HsDocTy" $ + -- I don't think HsDocTy actually makes it through the renamer + fold alg typ + fold alg (L span (HsWrapTy _wrapper _typ)) = astMark alg (Just span) "HsWrapTy" $ + -- This is returned only by the type checker, and _typ is not located + return Nothing + fold alg (L span (HsRecTy fields)) = astMark alg (Just span) "HsRecTy" $ + fold alg fields + fold alg (L span (HsKindSig typ kind)) = astMark alg (Just span) "HsKindSig" $ + fold alg [typ, kind] + fold alg (L span (HsBangTy _bang typ)) = astMark alg (Just span) "HsBangTy" $ + fold alg typ + fold alg (L span (HsOpTy left (_wrapper, op) right)) = astMark alg (Just span) "HsOpTy" $ do + fold alg [left, right] + astId alg UseSite op + fold alg (L span (HsIParamTy _var typ)) = astMark alg (Just span) "HsIParamTy" $ + -- _var is not located + fold alg typ + fold alg (L span (HsSpliceTy splice _postTcKind)) = astMark alg (Just span) "HsSpliceTy" $ + fold alg splice + fold alg (L span (HsCoreTy _)) = astMark alg (Just span) "HsCoreTy" $ + -- Not important: doesn't arise until later in the compiler pipeline + return Nothing + fold alg (L span (HsQuasiQuoteTy qquote)) = astMark alg (Just span) "HsQuasiQuoteTy" $ + fold alg (L span qquote) -- reuse location info + fold alg (L span (HsExplicitListTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitListTy" $ + fold alg typs + fold alg (L span (HsExplicitTupleTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitTupleTy" $ + fold alg typs + fold alg (L span (HsTyLit _hsTyLit)) = astMark alg (Just span) "HsTyLit" $ + return Nothing + fold alg (L span HsWildcardTy) = astMark alg (Just span) "HsWildcardTy" $ + return Nothing + fold alg (L span (HsNamedWildcardTy nm)) = astMark alg (Just span) "HsNamedWildcardTy" $ + astId alg UseSite (L span nm) + +instance Fold id (HsSplice id) where + fold alg (HsSplice _id expr) = astMark alg Nothing "HsSplice" $ do + fold alg expr + +instance Fold id (Located (HsQuasiQuote id)) where + fold alg (L span (HsQuasiQuote _id _srcSpan _enclosed)) = astMark alg (Just span) "HsQuasiQuote" $ + -- Unfortunately, no location information is stored within HsQuasiQuote at all + return Nothing + +instance Fold id (LHsTyVarBndr id) where + fold alg (L span (UserTyVar name)) = astMark alg (Just span) "UserTyVar" $ do + astId alg DefSite (L span name) + fold alg (L span (KindedTyVar name kind)) = astMark alg (Just span) "KindedTyVar" $ do + astId alg DefSite name + fold alg kind + +instance Fold id (LHsContext id) where + fold alg (L span typs) = astMark alg (Just span) "LHsContext" $ + fold alg typs + +instance Fold id (LHsBinds id) where + fold alg = fold alg . bagToList + +instance Fold id (LHsBind id) where + fold alg (L span bind@(FunBind {})) = astMark alg (Just span) "FunBind" $ do + astId alg DefSite (fun_id bind) + fold alg (fun_matches bind) + fold alg (L span bind@(PatBind {})) = astMark alg (Just span) "PatBind" $ do + fold alg (pat_lhs bind) + fold alg (pat_rhs bind) + fold alg (L span _bind@(VarBind {})) = astMark alg (Just span) "VarBind" $ + -- These are only introduced by the type checker, and don't involve user + -- written code. The ghc comments says "located 'only for consistency'" + return Nothing + fold alg (L span bind@(AbsBinds {})) = astMark alg (Just span) "AbsBinds" $ do + forM_ (abs_exports bind) $ \abs_export -> + astId alg DefSite (L typecheckOnly (abe_poly abs_export)) + fold alg (abs_binds bind) + fold alg (L span (PatSynBind bind)) = astMark alg (Just span) "PatSynBind" $ do + astId alg DefSite (psb_id bind) + fold alg (psb_def bind) + -- TODO?: patsyn_args :: HsPatSynDetails (Located idR) + -- patsyn_dir :: HsPatSynDir idR + +typecheckOnly :: SrcSpan +typecheckOnly = mkGeneralSrcSpan (fsLit "") + +instance Fold id body => Fold id (MatchGroup id body) where + -- We ignore the postTcType, as it doesn't have location information + -- TODO: _mg_origin distinguishes between FromSource and Generated. + -- May be useful to take that into account? (Here and elsewhere) + fold alg (MG mg_alts _mg_arg_tys _mg_res_ty _mg_origin) = astMark alg Nothing "MG" $ + fold alg mg_alts + +instance Fold id body => Fold id (LMatch id body) where + fold alg (L span (Match _fun_id pats _type rhss)) = astMark alg (Just span) "Match" $ do + -- TODO: should we do something with _fun_id? + fold alg pats + fold alg rhss + +instance Fold id body => Fold id (GRHSs id body) where + fold alg (GRHSs rhss binds) = astMark alg Nothing "GRHSs" $ do + fold alg rhss + fold alg binds + +instance Fold id body => Fold id (LGRHS id body) where + fold alg (L span (GRHS _guards rhs)) = astMark alg (Just span) "GRHS" $ + fold alg rhs + +instance Fold id (HsLocalBinds id) where + fold _alg EmptyLocalBinds = + return Nothing + fold _alg (HsValBinds (ValBindsIn _ _)) = + fail "fold alg: Unexpected ValBindsIn (after renamer these should not exist)" + fold alg (HsValBinds binds) = astMark alg Nothing "HsValBinds" $ do + fold alg binds + fold alg (HsIPBinds binds) = + fold alg binds + +instance Fold id (HsIPBinds id) where + fold alg (IPBinds binds _evidence) = + fold alg binds + +instance Fold id (LIPBind id) where + fold alg (L span (IPBind _name expr)) = astMark alg (Just span) "IPBind" $ do + -- Name is not located :( + fold alg expr + +instance Fold id (LHsExpr id) where + fold alg (L span (HsPar expr)) = astMark alg (Just span) "HsPar" $ + fold alg expr + fold alg (L span (ExprWithTySig expr _type _wildcards)) = astMark alg (Just span) "ExprWithTySig" $ + fold alg expr + fold alg (L span (ExprWithTySigOut expr _type)) = astMark alg (Just span) "ExprWithTySigOut" $ + fold alg expr + fold alg (L span (HsOverLit (OverLit{ol_type}))) = astMark alg (Just span) "HsOverLit" $ do + astExpType alg span (ifPostTcType alg ol_type) + fold alg (L span (OpApp left op _fix right)) = astMark alg (Just span) "OpApp" $ do + _leftTy <- fold alg left + opTy <- fold alg op + _rightTy <- fold alg right + astExpType alg span (funRes2 <$> opTy) + fold alg (L span (HsVar id)) = astMark alg (Just span) "HsVar" $ do + astId alg UseSite (L span id) + fold alg (L span (HsWrap wrapper expr)) = astMark alg (Just span) "HsWrap" $ do + ty <- fold alg (L span expr) + astExpType alg span (applyWrapper wrapper <$> ty) + fold alg (L span (HsLet binds expr)) = astMark alg (Just span) "HsLet" $ do + fold alg binds + ty <- fold alg expr + astExpType alg span ty -- Re-astId alg this with the span of the whole let + fold alg (L span (HsApp fun arg)) = astMark alg (Just span) "HsApp" $ do + funTy <- fold alg fun + _argTy <- fold alg arg + astExpType alg span (funRes1 <$> funTy) + fold alg (L span (HsLit lit)) = + -- Intentional omission of the "astMark alg" debugging call here. + -- The syntax "assert" is replaced by GHC by "assertError ", where + -- both "assertError" and the "" are assigned the source span of + -- the original "assert". This means that the (represented as an + -- HsLit) might override "assertError" in the IdMap. + astExpType alg span (ifPostTc alg (hsLitType lit)) + fold alg (L span (HsLam matches@(MG _ mg_arg_tys mg_res_ty _ms_origin))) = astMark alg (Just span) "HsLam" $ do + fold alg matches + let lamTy = do arg_tys <- sequence $ map (ifPostTcType alg) mg_arg_tys + res_ty <- ifPostTcType alg mg_res_ty + return (mkFunTys arg_tys res_ty) + astExpType alg span lamTy + fold alg (L span (HsDo _ctxt stmts postTcType)) = astMark alg (Just span) "HsDo" $ do + -- ctxt indicates what kind of statement it is; AFAICT there is no + -- useful information in it for us + fold alg stmts + astExpType alg span (ifPostTcType alg postTcType) + fold alg (L span (ExplicitList postTcType _mSyntaxExpr exprs)) = astMark alg (Just span) "ExplicitList" $ do + fold alg exprs + astExpType alg span (mkListTy <$> ifPostTcType alg postTcType) + fold alg (L span (RecordCon con postTcExpr recordBinds)) = astMark alg (Just span) "RecordCon" $ do + fold alg recordBinds + -- Only traverse the postTcExpr in the right phase (types force us! yay! :) + case astPhase alg of + FoldPreTc -> do + astId alg UseSite con + return Nothing + FoldPostTc -> do + conTy <- fold alg (L (getLoc con) postTcExpr) + astExpType alg span (funResN <$> conTy) + fold alg (L span (HsCase expr matches@(MG _ _mg_arg_tys mg_res_ty _mg_origin))) = astMark alg (Just span) "HsCase" $ do + fold alg expr + fold alg matches + astExpType alg span (ifPostTcType alg mg_res_ty) + fold alg (L span (ExplicitTuple args boxity)) = astMark alg (Just span) "ExplicitTuple" $ do + argTys <- mapM (fold alg) args + astExpType alg span (mkTupleTy (boxityNormalTupleSort boxity) <$> sequence argTys) + fold alg (L span (HsIf _rebind cond true false)) = astMark alg (Just span) "HsIf" $ do + _condTy <- fold alg cond + _trueTy <- fold alg true + falseTy <- fold alg false + astExpType alg span falseTy + fold alg (L span (SectionL arg op)) = astMark alg (Just span) "SectionL" $ do + _argTy <- fold alg arg + opTy <- fold alg op + astExpType alg span (mkSectionLTy <$> opTy) + where + mkSectionLTy ty = let (_arg1, arg2, res) = splitFunTy2 ty + in mkFunTy arg2 res + fold alg (L span (SectionR op arg)) = astMark alg (Just span) "SectionR" $ do + opTy <- fold alg op + _argTy <- fold alg arg + astExpType alg span (mkSectionRTy <$> opTy) + where + mkSectionRTy ty = let (arg1, _arg2, res) = splitFunTy2 ty + in mkFunTy arg1 res + fold alg (L span (HsIPVar _name)) = astMark alg (Just span) "HsIPVar" $ + -- _name is not located :( + return Nothing + fold alg (L span (NegApp expr _rebind)) = astMark alg (Just span) "NegApp" $ do + ty <- fold alg expr + astExpType alg span ty + fold alg (L span (HsBracket th)) = astMark alg (Just span) "HsBracket" $ + fold alg th + fold alg (L span (HsRnBracketOut th pendingSplices)) = astMark alg (Just span) "HsRnBracketOut" $ do + -- HsRnBracketOut is used pre type checking (contains Names only) + case astPhase alg of + FoldPreTc -> do fold alg pendingSplices + fold alg th + return Nothing + FoldPostTc -> return Nothing + fold alg (L span (HsTcBracketOut _th pendingSplices)) = astMark alg (Just span) "HsTcBracketOut" $ do + -- Given something like + -- + -- > \x xs -> [| x : xs |] + -- + -- @pendingSplices@ contains + -- + -- > [ "x", "Language.Haskell.TH.Syntax.lift x" + -- > , "xs", "Language.Haskell.TH.Syntax.lift xs" + -- > ] + -- + -- Sadly, however, ghc attaches to these splices. + -- Moreover, we don't get any type information about the whole bracket + -- expression either :( + case astPhase alg of + FoldPreTc -> return Nothing -- already traversed in HsRnBracketOut + FoldPostTc -> do fold alg pendingSplices + return Nothing + fold alg (L span (RecordUpd expr binds _dataCons _postTcTypeInp _postTcTypeOutp)) = astMark alg (Just span) "RecordUpd" $ do + recordTy <- fold alg expr + fold alg binds + astExpType alg span recordTy -- The type doesn't change + fold alg (L span (HsProc pat body)) = astMark alg (Just span) "HsProc" $ do + fold alg pat + fold alg body + fold alg (L span (HsArrApp arr inp _postTcType _arrType _orient)) = astMark alg (Just span) "HsArrApp" $ do + fold alg [arr, inp] + fold alg (L span (HsArrForm expr _fixity cmds)) = astMark alg (Just span) "HsArrForm" $ do + fold alg expr + fold alg cmds + fold alg (L span (HsTick _tickish expr)) = astMark alg (Just span) "HsTick" $ do + fold alg expr + fold alg (L span (HsBinTick _trueTick _falseTick expr)) = astMark alg (Just span) "HsBinTick" $ do + fold alg expr + fold alg (L span (HsTickPragma _src _span expr)) = astMark alg (Just span) "HsTickPragma" $ do + fold alg expr + fold alg (L span (HsSCC _src _string expr)) = astMark alg (Just span) "HsSCC" $ do + fold alg expr + fold alg (L span (HsCoreAnn _src _string expr)) = astMark alg (Just span) "HsCoreAnn" $ do + fold alg expr + fold alg (L span (HsSpliceE _isTyped splice)) = astMark alg (Just span) "HsSpliceE" $ do + fold alg splice + fold alg (L span (HsQuasiQuoteE qquote)) = astMark alg (Just span) "HsQuasiQuoteE" $ do + fold alg (L span qquote) -- reuse span + fold alg (L span (ExplicitPArr _postTcType exprs)) = astMark alg (Just span) "ExplicitPArr" $ do + fold alg exprs + fold alg (L span (PArrSeq _postTcType seqInfo)) = astMark alg (Just span) "PArrSeq" $ do + fold alg seqInfo + + -- According to the comments in HsExpr.lhs, + -- "These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing." + fold alg (L span EWildPat) = astMark alg (Just span) "EWildPat" $ + return Nothing + fold alg (L span (EAsPat _ _)) = astMark alg (Just span) "EAsPat" $ + return Nothing + fold alg (L span (EViewPat _ _)) = astMark alg (Just span) "EViewPat" $ + return Nothing + fold alg (L span (ELazyPat _)) = astMark alg (Just span) "ELazyPat" $ + return Nothing + fold alg (L span (HsType _ )) = astMark alg (Just span) "HsType" $ + return Nothing + fold alg (L span (ArithSeq postTcExpr _mSyntaxExpr seqInfo)) = astMark alg (Just span) "ArithSeq" $ do + fold alg seqInfo + case astPhase alg of + FoldPreTc -> return Nothing + FoldPostTc -> fold alg (L span postTcExpr) + + -- New expressions + fold _ (L _ (HsLamCase _ _)) = + return Nothing -- FIXME (7.8 and 7.10) + fold _ (L _ (HsMultiIf _ _)) = + return Nothing -- FIXME (7.8 and 7.10) + fold alg (L span (HsStatic expr)) = astMark alg (Just span) "HsStatic" $ + fold alg expr + + -- Unbound variables are errors? + fold _alg (L _span (HsUnboundVar _rdrName)) = + return Nothing + +instance Fold id (PendingSplice id) where + fold alg (PendSplice _nm splice) = astMark alg Nothing "PendSplice" $ do + fold alg splice + +instance Fold id (ArithSeqInfo id) where + fold alg (From expr) = astMark alg Nothing "From" $ + fold alg expr + fold alg (FromThen frm thn) = astMark alg Nothing "FromThen" $ + fold alg [frm, thn] + fold alg (FromTo frm to) = astMark alg Nothing "FromTo" $ + fold alg [frm, to] + fold alg (FromThenTo frm thn to) = astMark alg Nothing "FromThenTo" $ + fold alg [frm, thn, to] + +instance Fold id (LHsCmdTop id) where + fold alg (L span (HsCmdTop cmd _postTcTypeInp _postTcTypeRet _syntaxTable)) = astMark alg (Just span) "HsCmdTop" $ + fold alg cmd + +instance Fold id (HsBracket id) where + fold alg (ExpBr expr) = astMark alg Nothing "ExpBr" $ + fold alg expr + fold alg (PatBr pat) = astMark alg Nothing "PatBr" $ + fold alg pat + fold alg (DecBrG group) = astMark alg Nothing "DecBrG" $ + fold alg group + fold alg (TypBr typ) = astMark alg Nothing "TypBr" $ + fold alg typ + fold alg (VarBr _namespace _id) = astMark alg Nothing "VarBr" $ + -- No location information, sadly + return Nothing + fold alg (DecBrL decls) = astMark alg Nothing "DecBrL" $ + fold alg decls + fold alg (TExpBr expr) = astMark alg Nothing "TExpBr" $ + fold alg expr + +instance Fold Name PendingRnSplice where + fold alg (PendingRnExpSplice splice) = astMark alg Nothing "PendingRnExpSplice" $ + fold alg splice + fold alg (PendingRnPatSplice splice) = astMark alg Nothing "PendingRnPatSplice" $ + fold alg splice + fold alg (PendingRnTypeSplice splice) = astMark alg Nothing "PendingRnTypeSplice" $ + fold alg splice + fold alg (PendingRnDeclSplice splice) = astMark alg Nothing "PendingRnDeclSplice" $ + fold alg splice + fold alg (PendingRnCrossStageSplice _) = astMark alg Nothing "PendingRnCrossStageSplice" $ + -- No location info + return Nothing + +instance Fold id (LHsTupArg id) where + fold alg (L span (Present arg)) = astMark alg (Just span) "Present" $ + fold alg arg + fold alg (L span (Missing _postTcType)) = astMark alg (Just span) "Missing" $ + return Nothing + +instance Fold id a => Fold id (HsRecFields id a) where + fold alg (HsRecFields rec_flds _rec_dotdot) = astMark alg Nothing "HsRecFields" $ + fold alg rec_flds + +instance Fold id a => Fold id (LHsRecField id a) where + fold alg (L span (HsRecField id arg _pun)) = astMark alg (Just span) "HsRecField" $ do + astId alg UseSite id + fold alg arg + +-- The meaning of the constructors of LStmt isn't so obvious; see various +-- notes in ghc/compiler/hsSyn/HsExpr.lhs +instance Fold id body => Fold id (LStmt id body) where + fold alg (L span (LastStmt body _syntaxExpr)) = astMark alg (Just span) "LastStmt" $ do + fold alg body + fold alg (L span (BindStmt pat expr _bind _fail)) = astMark alg (Just span) "BindStmt" $ do + -- Neither _bind or _fail are located + fold alg pat + fold alg expr + fold alg (L span (BodyStmt body _seq _guard _postTcType)) = astMark alg (Just span) "BodyStmt" $ do + -- TODO: should we do something with _postTcType? + -- (Comment in HsExpr.lhs says it's for arrows) + fold alg body + fold alg (L span (LetStmt binds)) = astMark alg (Just span) "LetStmt" $ + fold alg binds + fold alg (L span stmt@(RecStmt {})) = astMark alg (Just span) "RecStmt" $ do + fold alg (recS_stmts stmt) + + fold alg (L span (TransStmt {})) = astUnsupported alg (Just span) "TransStmt" + fold alg (L span (ParStmt _ _ _)) = astUnsupported alg (Just span) "ParStmt" + +instance Fold id (LPat id) where + fold alg (L span (WildPat postTcType)) = astMark alg (Just span) "WildPat" $ + astExpType alg span (ifPostTcType alg postTcType) + fold alg (L span (VarPat id)) = astMark alg (Just span) "VarPat" $ + astId alg DefSite (L span id) + fold alg (L span (LazyPat pat)) = astMark alg (Just span) "LazyPat" $ + fold alg pat + fold alg (L span (AsPat id pat)) = astMark alg (Just span) "AsPat" $ do + astId alg DefSite id + fold alg pat + fold alg (L span (ParPat pat)) = astMark alg (Just span) "ParPat" $ + fold alg pat + fold alg (L span (BangPat pat)) = astMark alg (Just span) "BangPat" $ + fold alg pat + fold alg (L span (ListPat pats _postTcType _mSyntaxExpr)) = astMark alg (Just span) "ListPat" $ + fold alg pats + fold alg (L span (TuplePat pats _boxity _postTcType)) = astMark alg (Just span) "TuplePat" $ + fold alg pats + fold alg (L span (PArrPat pats _postTcType)) = astMark alg (Just span) "PArrPat" $ + fold alg pats + fold alg (L span (ConPatIn con details)) = astMark alg (Just span) "ConPatIn" $ do + -- Unlike ValBindsIn and HsValBindsIn, we *do* get ConPatIn + astId alg UseSite con -- the constructor name is non-binding + fold alg details + fold alg (L span (ConPatOut {pat_con, pat_args})) = astMark alg (Just span) "ConPatOut" $ do + () <- case astPhase alg of + FoldPreTc -> do astId alg UseSite (L (getLoc pat_con) (getName (unLoc pat_con))) + return () + FoldPostTc -> return () + fold alg pat_args + fold alg (L span (LitPat _)) = astMark alg (Just span) "LitPat" $ + return Nothing + fold alg (L span (NPat _ _ _)) = astMark alg (Just span) "NPat" $ + return Nothing + fold alg (L span (NPlusKPat id _lit _rebind1 _rebind2)) = astMark alg (Just span) "NPlusKPat" $ do + astId alg DefSite id + fold alg (L span (ViewPat expr pat _postTcType)) = astMark alg (Just span) "ViewPat" $ do + fold alg expr + fold alg pat + fold alg (L span (SigPatIn pat typ)) = astMark alg (Just span) "SigPatIn" $ do + fold alg pat + fold alg typ + fold alg (L span (SigPatOut pat _typ)) = astMark alg (Just span) "SigPatOut" $ do + -- _typ is not located + fold alg pat + fold alg (L span (QuasiQuotePat qquote)) = astMark alg (Just span) "QuasiQuotePat" $ + fold alg (L span qquote) -- reuse span + fold alg (L span (SplicePat splice)) = astMark alg (Just span) "SplicePat" $ + fold alg splice + + -- During translation only + fold alg (L span (CoPat _ _ _)) = astMark alg (Just span) "CoPat" $ + return Nothing + +instance (Fold id arg, Fold id rec) => Fold id (HsConDetails arg rec) where + fold alg (PrefixCon args) = astMark alg Nothing "PrefixCon" $ + fold alg args + fold alg (RecCon rec) = astMark alg Nothing "RecCon" $ + fold alg rec + fold alg (InfixCon a b) = astMark alg Nothing "InfixCon" $ + fold alg [a, b] + +instance Fold id (LTyClDecl id) where + fold alg (L span (FamDecl tcdFam)) = astMark alg (Just span) "FamDecl" $ do + fold alg (L span tcdFam) + fold alg (L span (SynDecl tcdLName + tcdTyVars + tcdRhs + _tcdFVs)) = astMark alg (Just span) "SynDecl" $ do + astId alg DefSite tcdLName + fold alg tcdTyVars + fold alg tcdRhs + fold alg (L span (DataDecl tcdLName + tcdTyVars + tcdDataDefn + _tcdFVs)) = astMark alg (Just span) "DataDecl" $ do + astId alg DefSite tcdLName + fold alg tcdTyVars + fold alg tcdDataDefn + fold alg (L span decl@(ClassDecl {})) = astMark alg (Just span) "ClassDecl" $ do + fold alg (tcdCtxt decl) + astId alg DefSite (tcdLName decl) + fold alg (tcdTyVars decl) + -- Sadly, we don't get location info for the functional dependencies + fold alg (tcdSigs decl) + fold alg (tcdMeths decl) + fold alg (tcdATs decl) + fold alg (tcdATDefs decl) + fold alg (tcdDocs decl) + +instance Fold id (LConDecl id) where + fold alg (L span decl@(ConDecl {})) = astMark alg (Just span) "ConDecl" $ do + forM_ (con_names decl) $ astId alg DefSite + fold alg (con_qvars decl) + fold alg (con_cxt decl) + fold alg (unlocRec (con_details decl)) + fold alg (con_res decl) + where + unlocRec :: HsConDetails a (Located b) -> HsConDetails a b + unlocRec (PrefixCon args) = PrefixCon args + unlocRec (RecCon rec) = RecCon (unLoc rec) + unlocRec (InfixCon arg1 arg2) = InfixCon arg1 arg2 + +instance Fold id ty => Fold id (ResType ty) where + fold alg ResTyH98 = astMark alg Nothing "ResTyH98" $ do + return Nothing -- Nothing to do + fold alg (ResTyGADT span ty) = astMark alg (Just span) "ResTyGADT" $ do + fold alg ty + +instance Fold id (LConDeclField id) where + fold alg (L span (ConDeclField names typ _doc)) = astMark alg (Just span) "ConDeclField" $ do + forM_ names $ astId alg DefSite + fold alg typ + +instance Fold id (LInstDecl id) where + fold alg (L span (ClsInstD cid_inst)) = astMark alg (Just span) "ClsInstD" $ + fold alg cid_inst + fold alg (L span (DataFamInstD dfid_inst)) = astMark alg (Just span) "DataFamInstD" $ + fold alg dfid_inst + fold alg (L span (TyFamInstD tfid_inst)) = astMark alg (Just span) "TyFamInstD" $ + fold alg tfid_inst + +instance Fold id (LDerivDecl id) where + fold alg (L span (DerivDecl deriv_type _overlapMode)) = astMark alg (Just span) "LDerivDecl" $ do + fold alg deriv_type + +instance Fold id (LFixitySig id) where + fold alg (L span (FixitySig names _fixity)) = astMark alg (Just span) "LFixitySig" $ do + forM_ names $ astId alg SigSite + return Nothing + +instance Fold id (LDefaultDecl id) where + fold alg (L span (DefaultDecl typs)) = astMark alg (Just span) "LDefaultDecl" $ do + fold alg typs + +instance Fold id (LForeignDecl id) where + fold alg (L span (ForeignImport name sig _coercion _import)) = astMark alg (Just span) "ForeignImport" $ do + astId alg DefSite name + fold alg sig + fold alg (L span (ForeignExport name sig _coercion _export)) = astMark alg (Just span) "ForeignExport" $ do + astId alg UseSite name + fold alg sig + +instance Fold id (LWarnDecl id) where + fold alg (L span (Warning names _txt)) = astMark alg (Just span) "Warning" $ do + forM_ names $ astId alg UseSite + return Nothing + +instance Fold id (LWarnDecls id) where + fold alg (L span (Warnings _src warnings)) = astMark alg (Just span) "Warnings" $ do + fold alg warnings + +instance Fold id (LAnnDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LAnnDecl" + +instance Fold id (LRuleDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LRuleDecl" + +instance Fold id (LRuleDecls id) where + fold alg (L span _) = astUnsupported alg (Just span) "LRuleDecls" + +instance Fold id (LVectDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LVectDecl" + +instance Fold id LDocDecl where + fold alg (L span _) = astMark alg (Just span) "LDocDec" $ + -- Nothing to do + return Nothing + +instance Fold id (Located (SpliceDecl id)) where + fold alg (L span (SpliceDecl splice _explicit)) = astMark alg (Just span) "SpliceDecl" $ do + fold alg (unLoc splice) + +-- LHsDecl is a wrapper around the various kinds of declarations; the wrapped +-- declarations don't have location information of themselves, so we reuse +-- the location info of the wrapper +instance Fold id (LHsDecl id) where + fold alg (L span (TyClD tyClD)) = astMark alg (Just span) "TyClD" $ + fold alg (L span tyClD) + fold alg (L span (InstD instD)) = astMark alg (Just span) "InstD" $ + fold alg (L span instD) + fold alg (L span (DerivD derivD)) = astMark alg (Just span) "DerivD" $ + fold alg (L span derivD) + fold alg (L span (ValD valD)) = astMark alg (Just span) "ValD" $ + fold alg (L span valD) + fold alg (L span (SigD sigD)) = astMark alg (Just span) "SigD" $ + fold alg (L span sigD) + fold alg (L span (DefD defD)) = astMark alg (Just span) "DefD" $ + fold alg (L span defD) + fold alg (L span (ForD forD)) = astMark alg (Just span) "ForD" $ + fold alg (L span forD) + fold alg (L span (WarningD warningD)) = astMark alg (Just span) "WarningD" $ + fold alg (L span warningD) + fold alg (L span (AnnD annD)) = astMark alg (Just span) "AnnD" $ + fold alg (L span annD) + fold alg (L span (RuleD ruleD)) = astMark alg (Just span) "RuleD" $ + fold alg (L span ruleD) + fold alg (L span (VectD vectD)) = astMark alg (Just span) "VectD" $ + fold alg (L span vectD) + fold alg (L span (SpliceD spliceD)) = astMark alg (Just span) "SpliceD" $ + fold alg (L span spliceD) + fold alg (L span (DocD docD)) = astMark alg (Just span) "DocD" $ + fold alg (L span docD) + fold alg (L span (QuasiQuoteD quasiQuoteD)) = astMark alg (Just span) "QuasiQuoteD" $ + fold alg (L span quasiQuoteD) + fold alg (L span (RoleAnnotD _roleAnnotDecl)) = astMark alg (Just span) "RoleAnnotD" $ + -- TODO: Do something with roleAnnotDecl + return Nothing + +instance Fold id (TyClGroup id) where + fold alg (TyClGroup decls _roles) = astMark alg Nothing "TyClGroup" $ + -- TODO: deal with roles + fold alg decls + +instance Fold id (LHsTyVarBndrs id) where + fold alg (HsQTvs _hsq_kvs hsq_tvs) = astMark alg Nothing "HsQTvs" $ do + -- TODO: sadly, we get no location information about the kind variables + fold alg hsq_tvs + +instance Fold id (LHsCmd id) where + -- TODO: support arrows + fold _ _ = return Nothing + +instance Fold id thing => Fold id (HsWithBndrs id thing) where + fold alg (HsWB hswb_cts _hswb_kvs _hswb_tvs _hswb_wcs) = astMark alg Nothing "HsWB" $ do + -- TODO: sadly, we get no location information about the variables + fold alg hswb_cts + +instance Fold id (LFamilyDecl id) where + fold alg (L span (FamilyDecl fdInfo fdLName fdTyVars fdKindSig)) = astMark alg (Just span) "FamilyDecl" $ do + fold alg fdInfo + astId alg DefSite fdLName + fold alg fdTyVars + fold alg fdKindSig + +instance Fold id (FamilyInfo id) where + fold alg DataFamily = astMark alg Nothing "DataFamily" $ + return Nothing + fold alg OpenTypeFamily = astMark alg Nothing "OpenTypeFamily" $ + return Nothing + fold alg (ClosedTypeFamily instDecls) = astMark alg Nothing "ClosedTypeFamily" $ + fold alg instDecls + +instance Fold id (LTyFamInstDecl id) where + fold alg (L span (TyFamInstDecl tfid_eqn _tfid_fvs)) = astMark alg (Just span) "TyFamInstDecl" $ do + -- TODO: sadly, tfid_fvs is unlocated + fold alg tfid_eqn + +instance Fold id (ClsInstDecl id) where + fold alg (ClsInstDecl cid_poly_ty + cid_binds + cid_sigs + cid_tyfam_insts + cid_datafam_insts + _cid_overlap_mode) = astMark alg Nothing "ClsInstDecl" $ do + fold alg cid_poly_ty + fold alg cid_binds + fold alg cid_sigs + fold alg cid_tyfam_insts + fold alg cid_datafam_insts + +instance Fold id (DataFamInstDecl id) where + fold alg (DataFamInstDecl dfid_tycon + dfid_pats + dfid_defn + _dfid_fvs) = astMark alg Nothing "DataFamInstDecl" $ do + -- TODO: _dfid_fvs is unlocated + astId alg UseSite dfid_tycon + fold alg dfid_pats + fold alg dfid_defn + +instance Fold id (TyFamInstDecl id) where + fold alg (TyFamInstDecl tfid_eqn _tfid_fvs) = astMark alg Nothing "TyFamInstDecl" $ do + -- TODO: tfid_fvs is not located + fold alg tfid_eqn + +instance Fold id pats => Fold id (Located (TyFamEqn id pats)) where + fold alg (L span (TyFamEqn tfe_tycon + tfe_pats + tfe_rhs)) = astMark alg (Just span) "TyFamInstEqn" $ do + astId alg UseSite tfe_tycon + fold alg tfe_pats + fold alg tfe_rhs + +instance Fold id (LDataFamInstDecl id) where + fold alg (L span (DataFamInstDecl dfid_tycon + dfid_pats + dfid_defn + _dfid_fvs)) = astMark alg (Just span) "DataFamInstDecl" $ do + -- TODO: dfid_fvs is not located + astId alg UseSite dfid_tycon + fold alg dfid_pats + fold alg dfid_defn + +instance Fold id (HsDataDefn id) where + fold alg (HsDataDefn _dd_ND + dd_ctxt + _dd_cType + dd_kindSig + dd_cons + dd_derivs) = astMark alg Nothing "HsDataDefn" $ do + fold alg dd_ctxt + fold alg dd_kindSig + fold alg dd_cons + fold alg dd_derivs + +{------------------------------------------------------------------------------ + Operations on types +------------------------------------------------------------------------------} + +-- | Apply a wrapper to a type +applyWrapper :: HsWrapper -> Type -> Type +applyWrapper WpHole t = t -- identity +applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t +applyWrapper (WpFun _ _ t1 t2) _ = mkFunTy t1 t2 +applyWrapper (WpCast coercion) _ = let Pair _ t = tcCoercionKind coercion in t +applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t +applyWrapper (WpEvApp _) t = funRes1 t +applyWrapper (WpTyLam v) t = mkForAllTy v t +applyWrapper (WpTyApp t') t = applyTy t t' +applyWrapper (WpLet _) t = t -- we don't care about evidence _terms_ + +-- | Given @a -> b@, return @b@ +funRes1 :: Type -> Type +funRes1 = snd . splitFunTy + +-- | Given @a1 -> a2 -> b@, return @b@ +funRes2 :: Type -> Type +funRes2 = funRes1 . funRes1 + +-- | Given @a1 -> a2 -> ... -> b@, return @b@ +funResN :: Type -> Type +funResN = snd . splitFunTys + +-- | Given @a -> b -> c@, return @(a, b, c)@ +splitFunTy2 :: Type -> (Type, Type, Type) +splitFunTy2 ty0 = let (arg1, ty1) = splitFunTy ty0 + (arg2, ty2) = splitFunTy ty1 + in (arg1, arg2, ty2) + +typeOfTyThing :: TyThing -> Maybe Type +typeOfTyThing (AConLike (RealDataCon dataCon)) = Just $ dataConRepType dataCon +typeOfTyThing _ = Nothing -- we probably don't want psOrigResTy from PatSynCon + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Extract a source ID from a package config +---- From 7.10 and up this is stored as a flat string so we need to parse it. +sourcePackageIdParsed :: PackageConfig -> Cabal.PackageId +sourcePackageIdParsed = parseSourceId . sourcePackageIdString + +-- | Parse a source package ID +-- +-- Returns an empty package ID if the parse failed. +parseSourceId :: String -> Cabal.PackageId +parseSourceId = emptyOnParseFailure + . Maybe.mapMaybe successfulParse + . Cabal.readP_to_S Cabal.parse + where + successfulParse :: (a, String) -> Maybe a + successfulParse (a, unparsed) = if null unparsed then Just a else Nothing + + emptyOnParseFailure :: [Cabal.PackageId] -> Cabal.PackageId + emptyOnParseFailure (i:_) = i + emptyOnParseFailure [] = Cabal.PackageIdentifier { + pkgName = Cabal.PackageName "" + , pkgVersion = Version [] [] + } + +-- | Extract a version from an installed package ID +pkgName :: Cabal.PackageIdentifier -> String +pkgName pkgId = let Cabal.PackageName nm = Cabal.pkgName pkgId in nm diff --git a/GhcShim/GhcShim742.hs b/GhcShim/GhcShim742.hs new file mode 100644 --- /dev/null +++ b/GhcShim/GhcShim742.hs @@ -0,0 +1,1359 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, StandaloneDeriving, MultiParamTypeClasses, GADTs #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-} +module GhcShim.GhcShim742 + ( -- * Pretty-printing + showSDoc + , pretty + , prettyM + , prettyType + , prettyTypeM + -- * Errors + , sourceErrorSpan + -- * Breakpoints + , getBreak + , setBreak + -- * Time + , GhcTime + -- * Setup + , ghcGetVersion + , packageDBFlags + , setGhcOptions + , storeDynFlags + -- * Package keys (see GhcShim.hs). + , PackageKey + , PackageQualifier + , lookupPackage + , mainPackageKey + , modulePackageKey + , packageKeyString + , stringToPackageKey + , packageKeyToSourceId + , findExposedModule + -- * Folding + , AstAlg(..) + , fold + -- * Operations on types + , typeOfTyThing + -- * Re-exports + , tidyOpenType + ) where + +import Prelude hiding (id, span) +import Control.Monad (void, forM_, liftM) +import Data.IORef +import Data.Version +import System.IO.Unsafe (unsafePerformIO) +import System.Time (ClockTime) +import qualified Data.Maybe as Maybe + +import Bag +import BasicTypes hiding (Version) +import DataCon +import DynFlags +import ErrUtils +import FastString +import GHC hiding (getBreak) +import GhcMonad +import Linker +import Module +import MonadUtils +import Outputable hiding (showSDoc) +import PackageConfig (PackageConfig) +import Pair +import PprTyThing +import Pretty +import SrcLoc +import TcEvidence +import TcHsSyn +import TcType +import Type +import TysWiredIn +import qualified BreakArray +import qualified Packages + +import qualified Distribution.Package as Cabal +import qualified Distribution.InstalledPackageInfo as Cabal +import qualified Distribution.Text as Cabal +import qualified Distribution.Compat.ReadP as Cabal + +import GhcShim.API +import IdeSession.GHC.API (GhcVersion(..)) + +{------------------------------------------------------------------------------ + Pretty-printing +------------------------------------------------------------------------------} + +showSDoc :: DynFlags -> PprStyle -> SDoc -> String +showSDoc _dflags pprStyle doc = + showDocWith OneLineMode + $ runSDoc doc + $ initSDocContext pprStyle + +pretty :: Outputable a => DynFlags -> PprStyle -> a -> String +pretty dynFlags pprStyle = showSDoc dynFlags pprStyle . ppr + +prettyType :: DynFlags -> PprStyle -> Bool -> Type -> String +prettyType dynFlags pprStyle showForalls typ = + showSDoc dynFlags pprStyle (pprTypeForUser showForalls typ) + +prettyM :: (Outputable a, Monad m, HasDynFlags m) => PprStyle -> a -> m String +prettyM pprStyle x = do + dynFlags <- getDynFlags + return (pretty dynFlags pprStyle x) + +prettyTypeM :: (Monad m, HasDynFlags m) => PprStyle -> Bool -> Type -> m String +prettyTypeM pprStyle showForalls typ = do + dynFlags <- getDynFlags + return $ prettyType dynFlags pprStyle showForalls typ + +{------------------------------------------------------------------------------ + Show instances +------------------------------------------------------------------------------} + +deriving instance Show Severity + +{------------------------------------------------------------------------------ + Source errors +------------------------------------------------------------------------------} + +sourceErrorSpan :: ErrMsg -> Maybe SrcSpan +sourceErrorSpan errMsg = case errMsgSpans errMsg of + [real@RealSrcSpan{}] -> Just real + _ -> Nothing + +{------------------------------------------------------------------------------ + Breakpoints +------------------------------------------------------------------------------} + +getBreak :: BreakArray -> Int -> Ghc (Maybe Bool) +getBreak array index = do + val <- liftIO $ BreakArray.getBreak array index + return ((== 1) `liftM` val) + +setBreak :: BreakArray -> Int -> Bool -> Ghc () +setBreak array index value = do + void . liftIO $ if value then BreakArray.setBreakOn array index + else BreakArray.setBreakOff array index + +{------------------------------------------------------------------------------ + Time +------------------------------------------------------------------------------} + +type GhcTime = ClockTime + +{------------------------------------------------------------------------------ + Setup +------------------------------------------------------------------------------} + +ghcGetVersion :: GhcVersion +ghcGetVersion = GHC_7_4 + +packageDBFlags :: Bool -> [String] -> [String] +packageDBFlags userDB specificDBs = + ["-no-user-package-conf" | not userDB] + ++ concat [["-package-conf", db] | db <- specificDBs] + +-- | Set GHC options +-- +-- This is meant to be stateless. It is important to call storeDynFlags at least +-- once before calling setGhcOptions so that we know what state to restore to +-- before setting the options. +-- +-- Returns unrecognized options and warnings +setGhcOptions :: [String] -> Ghc ([String], [String]) +setGhcOptions opts = do + dflags <- restoreDynFlags + (dflags', leftover, warnings) <- parseDynamicFlags dflags (map noLoc opts) + setupLinkerState =<< setSessionDynFlags dflags' + return (map unLoc leftover, map unLoc warnings) + +-- | Setup linker state to deal with changed package flags +-- +-- This follows newDynFlags in ghci +setupLinkerState :: [PackageId] -> Ghc () +setupLinkerState newPackages = do + dflags <- getSessionDynFlags + setTargets [] + load LoadAllTargets + liftIO $ linkPackages dflags newPackages + +{------------------------------------------------------------------------------ + Backup DynFlags + + Sadly, this hardcodes quite a bit of version-specific information about ghc's + inner workings. Unfortunately, there is no easy way to know which parts of + DynFlags should and should not be restored to restore flags. The flag + specification is given by (see packageDynamicFlags in compiler/main/GHC.hs) + + > package_flags ++ dynamic_flags + + both of which are defined in DynFlags.hs. They are not exported, but this + would not be particularly useful anyway, as the action associated with a + flag is given by a shallow embedding, so we cannot walk over them and extract + the necessary info about DynFlags. At least, we cannot do that in code -- we + can do it manually, and that is precisely what I've done to obtain the list + below. Of course, this means it's somewhat error prone. + + In order so that this code can be audited and cross-checked against the + actual ghc version, and so that it can be modified for future ghc versions, + we don't just list the end result if this manual traversal, but document the + process. + + Each of the command line options are defined in terms of a auxiliary + functions that specify their effect on DynFlags. These auxiliary functions + are listed below, along with which parts of DynFlags they modify: + + > FUNCTION MODIFIES FIELD(s) OF DYNFLAGS + > ---------------------------------------------------------------------------- + > addCmdlineFramework cmdlineFrameworks + > addCmdlineHCInclude cmdlineHcIncludes + > addDepExcludeMod depExcludeMods + > addDepSuffix depSuffixes + > addFrameworkPath frameworkPaths + > addHaddockOpts haddockOptions + > addImportPath importPaths + > addIncludePath includePaths + > addLibraryPath libraryPaths + > addOptP settings + > addOptl settings + > addPluginModuleName pluginModNames + > addPluginModuleNameOption pluginModNameOpts + > alterSettings settings + > disableGlasgowExts flags, extensions, extensionFlags + > enableGlasgowExts flags, extensions, extensionFlags + > exposePackage packageFlags + > exposePackageId packageFlags + > extraPkgConf_ extraPkgConfs + > forceRecompile flags + > hidePackage packageFlags + > ignorePackage packageFlags + > parseDynLibLoaderMode dynLibLoader + > setDPHOpt optLevel, flags, maxSimplIterations, simplPhases + > setDepIncludePkgDeps depIncludePkgDeps + > setDepMakefile depMakefile + > setDumpDir dumpDir + > setDumpFlag flags + > setDumpFlag' flags + > setDumpPrefixForce dumpPrefixForce + > setDumpSimplPhases flags, shouldDumpSimplPhase + > setDylibInstallName dylibInstallName + > setDynFlag flags + > setExtensionFlag extensions, extensionFlags + > setHcSuf hcSuf + > setHiDir hiDir + > setHiSuf hiSuf + > setLanguage language, extensionFlags + > setMainIs mainFunIs, mainModIs + > setObjTarget hscTarget + > setObjectDir objectDir + > setObjectSuf objectSuf + > setOptHpcDir hpcDir + > setOptLevel optLevel, flags + > setOutputDir objectDir, hiDir, stubDir, includePaths, dumpDir + > setOutputFile outputFile + > setOutputHi outputHi + > setPackageName thisPackage + > setPackageTrust flags, pkgTrustOnLoc + > setPgmP settings + > setRtsOpts rtsOpts + > setRtsOptsEnabled rtsOptsEnabled + > setSafeHaskell safeHaskell + > setStubDir stubDir + > setTarget hscTarget + > setTmpDir settings + > setVerboseCore2Core flags, shouldDumpSimplPhase + > setVerbosity verbosity + > setWarningFlag warningFlags + > trustPackage packageFlags + > unSetDynFlag flags + > unSetExtensionFlag extensions, extensionFlags + > unSetWarningFlag warningFlags + + Below is a list of the dynamic_flags in alphabetical order along with the + auxiliary function that they use. A handful of these flags define their + effect on DynFlags directly; these are marked (**). + + > FLAG DEFINED IN TERMS OF + > ---------------------------------------------------------------------------- + > "#include" addCmdlineHCInclude + > "D" addOptP + > "F" setDynFlag + > "I" addIncludePath + > "L" addLibraryPath + > "O" setOptLevel + > "Odph" setDPHOpt + > "Onot" setOptLevel + > "U" addOptP + > "W" setWarningFlag + > "Wall" setWarningFlag + > "Werror" setDynFlag + > "Wnot" ** sets warningFlags + > "Wwarn" unSetDynFlag + > "auto" ** sets profAuto + > "auto-all" ** sets profAuto + > "caf-all" setDynFlag + > "cpp" setExtensionFlag + > "dasm-lint" setDynFlag + > "dcmm-lint" setDynFlag + > "dcore-lint" setDynFlag + > "ddump-asm" setDumpFlag + > "ddump-asm-coalesce" setDumpFlag + > "ddump-asm-conflicts" setDumpFlag + > "ddump-asm-expanded" setDumpFlag + > "ddump-asm-liveness" setDumpFlag + > "ddump-asm-native" setDumpFlag + > "ddump-asm-regalloc" setDumpFlag + > "ddump-asm-regalloc-stages" setDumpFlag + > "ddump-asm-stats" setDumpFlag + > "ddump-bcos" setDumpFlag + > "ddump-cmm" setDumpFlag + > "ddump-cmmz" setDumpFlag + > "ddump-cmmz-cafs" setDumpFlag + > "ddump-cmmz-cbe" setDumpFlag + > "ddump-cmmz-dead" setDumpFlag + > "ddump-cmmz-info" setDumpFlag + > "ddump-cmmz-lower" setDumpFlag + > "ddump-cmmz-pretty" setDumpFlag + > "ddump-cmmz-proc" setDumpFlag + > "ddump-cmmz-procmap" setDumpFlag + > "ddump-cmmz-rewrite" setDumpFlag + > "ddump-cmmz-sp" setDumpFlag + > "ddump-cmmz-spills" setDumpFlag + > "ddump-cmmz-split" setDumpFlag + > "ddump-cmmz-stub" setDumpFlag + > "ddump-core-pipeline" setDumpFlag + > "ddump-core-stats" setDumpFlag + > "ddump-cpranal" setDumpFlag + > "ddump-cps-cmm" setDumpFlag + > "ddump-cs-trace" setDumpFlag + > "ddump-cse" setDumpFlag + > "ddump-cvt-cmm" setDumpFlag + > "ddump-deriv" setDumpFlag + > "ddump-ds" setDumpFlag + > "ddump-file-prefix" setDumpPrefixForce + > "ddump-flatC" setDumpFlag + > "ddump-foreign" setDumpFlag + > "ddump-hi" setDumpFlag + > "ddump-hi-diffs" setDumpFlag + > "ddump-hpc" setDumpFlag + > "ddump-if-trace" setDumpFlag + > "ddump-inlinings" setDumpFlag + > "ddump-llvm" setObjTarget, setDumpFlag' + > "ddump-minimal-imports" setDumpFlag + > "ddump-mod-cycles" setDumpFlag + > "ddump-occur-anal" setDumpFlag + > "ddump-opt-cmm" setDumpFlag + > "ddump-parsed" setDumpFlag + > "ddump-prep" setDumpFlag + > "ddump-raw-cmm" setDumpFlag + > "ddump-rn" setDumpFlag + > "ddump-rn-stats" setDumpFlag + > "ddump-rn-trace" setDumpFlag + > "ddump-rtti" setDumpFlag + > "ddump-rule-firings" setDumpFlag + > "ddump-rule-rewrites" setDumpFlag + > "ddump-rules" setDumpFlag + > "ddump-simpl" setDumpFlag + > "ddump-simpl-iterations" setDumpFlag + > "ddump-simpl-phases" setDumpSimplPhases + > "ddump-simpl-stats" setDumpFlag + > "ddump-spec" setDumpFlag + > "ddump-splices" setDumpFlag + > "ddump-stg" setDumpFlag + > "ddump-stranal" setDumpFlag + > "ddump-tc" setDumpFlag + > "ddump-tc-trace" setDumpFlag + > "ddump-ticked" setDumpFlag + > "ddump-to-file" setDumpFlag + > "ddump-types" setDumpFlag + > "ddump-vect" setDumpFlag + > "ddump-view-pattern-commoning" setDumpFlag + > "ddump-vt-trace" setDumpFlag + > "ddump-worker-wrapper" setDumpFlag + > "dep-makefile" setDepMakefile + > "dep-suffix" addDepSuffix + > "dfaststring-stats" setDynFlag + > "dno-llvm-mangler" setDynFlag + > "dshow-passes" forceRecompile, setVerbosity + > "dsource-stats" setDumpFlag + > "dstg-lint" setDynFlag + > "dstg-stats" setDynFlag + > "dumpdir" setDumpDir + > "dverbose-core2core" setVerbosity, setVerboseCore2Core + > "dverbose-stg2stg" setDumpFlag + > "dylib-install-name" setDylibInstallName + > "dynload" parseDynLibLoaderMode + > "exclude-module" addDepExcludeMod + > "fasm" setObjTarget + > "fbyte-code" setTarget + > "fcontext-stack" ** sets ctxtStkDepth + > "ffloat-all-lams" ** sets floatLamArgs + > "ffloat-lam-args" ** sets floatLamArgs + > "fglasgow-exts" enableGlasgowExts + > "fliberate-case-threshold" ** sets liberateCaseThreshold + > "fllvm" setObjTarget + > "fmax-simplifier-iterations" ** sets maxSimplIterations + > "fno-code" setTarget, ** sets ghcLink + > "fno-glasgow-exts" disableGlasgowExts + > "fno-liberate-case-threshold" ** sets liberateCaseThreshold + > "fno-prof-auto" ** sets profAuto + > "fno-safe-infer" setSafeHaskell + > "fno-spec-constr-count" ** sets specConstrCount + > "fno-spec-constr-threshold" ** sets specConstrThreshold + > "fobject-code" setTarget + > "fpackage-trust" setPackageTrust + > "fplugin" addPluginModuleName + > "fplugin-opt" addPluginModuleNameOption + > "fprof-auto" ** sets profAuto + > "fprof-auto-calls" ** sets profAuto + > "fprof-auto-exported" ** sets profAuto + > "fprof-auto-top" ** sets profAuto + > "framework" addCmdlineFramework + > "framework-path" addFrameworkPath + > "frule-check" ** sets ruleCheck + > "fsimpl-tick-factor" ** sets simplTickFactor + > "fsimplifier-phases" ** sets simplPhases + > "fspec-constr-count" ** sets specConstrCount + > "fspec-constr-threshold" ** sets specConstrThreshold + > "fstrictness-before" ** sets strictnessBefore + > "fvia-C" <> + > "fvia-c" <> + > "haddock" setDynFlag + > "haddock-opts" addHaddockOpts + > "hcsuf" setHcSuf + > "hidir" setHiDir + > "hisuf" setHiSuf + > "hpcdir" setOptHpcDir + > "i" addImportPath + > "include-pkg-deps" setDepIncludePkgDeps + > "keep-hc-file" setDynFlag + > "keep-hc-files" setDynFlag + > "keep-llvm-file" setObjTarget, setDynFlag + > "keep-llvm-files" setObjTarget, setDynFlag + > "keep-raw-s-file" <> + > "keep-raw-s-files" <> + > "keep-s-file" setDynFlag + > "keep-s-files" setDynFlag + > "keep-tmp-files" setDynFlag + > "l" addOptl + > "main-is" setMainIs + > "monly-2-regs" <> + > "monly-3-regs" <> + > "monly-4-regs" <> + > "msse2" setDynFlag + > "msse4.2" setDynFlag + > "n" <> + > "no-auto" ** sets profAuto + > "no-auto-all" ** sets profAuto + > "no-auto-link-packages" unSetDynFlag + > "no-caf-all" unSetDynFlag + > "no-hs-main" setDynFlag + > "no-link" ** sets ghcLink + > "no-recomp" setDynFlag + > "no-rtsopts" setRtsOptsEnabled + > "o" setOutputFile + > "odir" setObjectDir + > "ohi" setOutputHi + > "optF" alterSettings + > "optL" alterSettings + > "optP" addOptP + > "opta" alterSettings + > "optc" alterSettings + > "optdep--exclude-module" addDepExcludeMod + > "optdep--include-pkg-deps" setDepIncludePkgDeps + > "optdep--include-prelude" setDepIncludePkgDeps + > "optdep-f" setDepMakefile + > "optdep-s" addDepSuffix + > "optdep-w" <> + > "optdep-x" addDepExcludeMod + > "optl" addOptl + > "optlc" alterSettings + > "optlo" alterSettings + > "optm" <> + > "optwindres" alterSettings + > "osuf" setObjectSuf + > "outputdir" setOutputDir + > "pgmF" alterSettings + > "pgmL" alterSettings + > "pgmP" setPgmP + > "pgma" alterSettings + > "pgmc" alterSettings + > "pgmdll" alterSettings + > "pgml" alterSettings + > "pgmlc" alterSettings + > "pgmlo" alterSettings + > "pgmm" <> + > "pgms" alterSettings + > "pgmwindres" alterSettings + > "recomp" unSetDynFlag + > "rtsopts" setRtsOptsEnabled + > "rtsopts=all" setRtsOptsEnabled + > "rtsopts=none" setRtsOptsEnabled + > "rtsopts=some" setRtsOptsEnabled + > "shared" ** sets ghcLink + > "split-objs" setDynFlag + > "stubdir" setStubDir + > "tmpdir" setTmpDir + > "v" setVerbosity + > "w" ** sets warningFlags + > "with-rtsopts" setRtsOpts + + Finally, there is a bunch flags defined in terms of setDynFlag, unSetDynFlag, + setWarningFlag, unSetWarningFlag, setExtensionFlag, unSetExtensionFlag, + setLanguage and setSafeHaskell. + + The same list for package_flags: + + > FLAG DEFINED IN TERMS OF + > ---------------------------------------------------------------------------- + > "package-conf" extraPkgConf_ + > "no-user-package-conf" unSetDynFlag + > "package-name" setPackageName + > "package-id" exposePackageId + > "package" exposePackage + > "hide-package" hidePackage + > "hide-all-packages" setDynFlag + > "ignore-package" ignorePackage + > "syslib" exposePackage + > "trust" trustPackage + > "distrust" distrustPackage + > "distrust-all-packages" setDynFlag + + In addition to the above, we also reset one more field: pkgDatabase. The + pkgDatabase is initialized on the first call to initPackages (and hence the + first call to setSessionDynFlags), which happens at server startup. After + that, subsequent calls to setSessionDynFlags take the _existing_ pkgDatabase, + but applies the "batch package flags" to it (hide-all-packages, + distrust-all-packages). However, it doesn't "unapply" these batch flags. By + restoring the pkgDatabase to the value it gets at server startup, we + effectively restore these batch flags whenever we apply user settings. +------------------------------------------------------------------------------} + +dynFlagsRef :: IORef DynFlags +{-# NOINLINE dynFlagsRef #-} +dynFlagsRef = unsafePerformIO $ newIORef (error "No DynFlags stored yet") + +storeDynFlags :: Ghc () +storeDynFlags = do + dynFlags <- getSessionDynFlags + liftIO $ writeIORef dynFlagsRef dynFlags + +restoreDynFlags :: Ghc DynFlags +restoreDynFlags = do + storedDynFlags <- liftIO $ readIORef dynFlagsRef + currentDynFlags <- getSessionDynFlags + return (currentDynFlags `restoreDynFlagsFrom` storedDynFlags) + +-- | Copy over all fields of DynFlags that are affected by dynamic_flags +-- and package_flags (and only those) +-- +-- See detailed description above. +restoreDynFlagsFrom :: DynFlags -> DynFlags -> DynFlags +restoreDynFlagsFrom new old = new { + cmdlineFrameworks = cmdlineFrameworks old + , cmdlineHcIncludes = cmdlineHcIncludes old + , ctxtStkDepth = ctxtStkDepth old + , depExcludeMods = depExcludeMods old + , depIncludePkgDeps = depIncludePkgDeps old + , depMakefile = depMakefile old + , depSuffixes = depSuffixes old + , dumpDir = dumpDir old + , dumpPrefixForce = dumpPrefixForce old + , dylibInstallName = dylibInstallName old + , dynLibLoader = dynLibLoader old + , extensionFlags = extensionFlags old + , extensions = extensions old + , extraPkgConfs = extraPkgConfs old + , flags = flags old + , floatLamArgs = floatLamArgs old + , frameworkPaths = frameworkPaths old + , ghcLink = ghcLink old + , haddockOptions = haddockOptions old + , hcSuf = hcSuf old + , hiDir = hiDir old + , hiSuf = hiSuf old + , hpcDir = hpcDir old + , hscTarget = hscTarget old + , importPaths = importPaths old + , includePaths = includePaths old + , language = language old + , liberateCaseThreshold = liberateCaseThreshold old + , libraryPaths = libraryPaths old + , mainFunIs = mainFunIs old + , mainModIs = mainModIs old + , maxSimplIterations = maxSimplIterations old + , objectDir = objectDir old + , objectSuf = objectSuf old + , optLevel = optLevel old + , outputFile = outputFile old + , outputHi = outputHi old + , packageFlags = packageFlags old + , pkgDatabase = pkgDatabase old + , pkgTrustOnLoc = pkgTrustOnLoc old + , pluginModNameOpts = pluginModNameOpts old + , pluginModNames = pluginModNames old + , profAuto = profAuto old + , rtsOpts = rtsOpts old + , rtsOptsEnabled = rtsOptsEnabled old + , ruleCheck = ruleCheck old + , safeHaskell = safeHaskell old + , settings = settings old + , shouldDumpSimplPhase = shouldDumpSimplPhase old + , simplPhases = simplPhases old + , simplTickFactor = simplTickFactor old + , specConstrCount = specConstrCount old + , specConstrThreshold = specConstrThreshold old + , strictnessBefore = strictnessBefore old + , stubDir = stubDir old + , thisPackage = thisPackage old + , verbosity = verbosity old + , warningFlags = warningFlags old + } + +{------------------------------------------------------------------------------- + Package keys +-------------------------------------------------------------------------------} + +type PackageKey = GHC.PackageId +type PackageQualifier = Maybe FastString + +packageKeyString :: PackageKey -> String +packageKeyString = packageIdString + +stringToPackageKey :: String -> PackageKey +stringToPackageKey = stringToPackageId + +mainPackageKey :: PackageKey +mainPackageKey = mainPackageId + +lookupPackage :: DynFlags -> PackageKey -> PackageConfig +lookupPackage dflags pkey = + Maybe.fromMaybe + (error $ "lookupPackage: invalid key " ++ packageKeyString pkey) + (Packages.lookupPackage (Packages.pkgIdMap (pkgState dflags)) pkey) + +modulePackageKey :: Module -> PackageKey +modulePackageKey = modulePackageId + +-- | Translate a package key to a source ID (name and version) +-- +-- NOTE: The version of wired-in packages is completely wiped out, but we use a +-- leak in the form of a Cabal package id for the same package, which still +-- contains a version. See +-- +packageKeyToSourceId :: DynFlags -> PackageKey -> (String, String) +packageKeyToSourceId dflags p = + let pkgCfg = lookupPackage dflags p + srcId = Cabal.sourcePackageId pkgCfg + instId = installedToSourceId $ Cabal.installedPackageId pkgCfg + name = pkgName srcId + version = Cabal.pkgVersion srcId `orIfZero` Cabal.pkgVersion instId + in (name, showVersion (stripInPlace version)) + where + orIfZero :: Version -> Version -> Version + orIfZero v a = case v of Version [] [] -> a ; _otherwise -> v + + stripInPlace :: Version -> Version + stripInPlace (Version bs ts) = Version bs (filter (/= "inplace") ts) + +-- | Find an exposed module in an exposed package +findExposedModule :: DynFlags -> PackageQualifier -> ModuleName -> Maybe PackageKey +findExposedModule dflags pkgQual impMod = Maybe.listToMaybe pkgIds + where + pkgAll = Packages.lookupModuleInAllPackages dflags impMod + pkgExposed = map fst $ filter isExposed pkgAll + pkgMatching = filter (matchesQual pkgQual) pkgExposed + pkgIds = map Packages.packageConfigId pkgMatching + + matchesQual :: PackageQualifier -> PackageConfig -> Bool + matchesQual Nothing _ = True + matchesQual (Just fs) p = unpackFS fs == pkgName (Cabal.sourcePackageId p) + + isExposed :: (PackageConfig, Bool) -> Bool + isExposed (pkgCfg, moduleExposed) = Cabal.exposed pkgCfg && moduleExposed + +{------------------------------------------------------------------------------ + Traversing the AST +------------------------------------------------------------------------------} + +ifPostTc :: AstAlg m id -> a -> Maybe a +ifPostTc alg a = + case astPhase alg of + FoldPreTc -> Nothing + FoldPostTc -> Just a + +instance Fold id (HsGroup id) where + fold alg HsGroup { hs_valds + , hs_tyclds + , hs_instds + , hs_derivds + , hs_fixds + , hs_defds + , hs_fords + , hs_warnds + , hs_annds + , hs_ruleds + , hs_vects + , hs_docs } = astMark alg Nothing "HsGroup" $ do + fold alg hs_valds + fold alg hs_tyclds + fold alg hs_instds + fold alg hs_derivds + fold alg hs_fixds + fold alg hs_defds + fold alg hs_fords + fold alg hs_warnds + fold alg hs_annds + fold alg hs_ruleds + fold alg hs_vects + fold alg hs_docs + +instance Fold id (HsValBinds id) where + fold _alg (ValBindsIn {}) = + fail "fold alg: Unexpected ValBindsIn" + fold alg (ValBindsOut binds sigs) = astMark alg Nothing "ValBindsOut" $ do + fold alg (map snd binds) + -- ValBindsOut specifically stores Names, independent of the phase. + -- Traverse only in the right mode (types force this) + case astPhase alg of + FoldPreTc -> fold alg sigs + FoldPostTc -> return Nothing + +instance Fold id (LSig id) where + fold alg (L span (TypeSig names tp)) = astMark alg (Just span) "TypeSig" $ do + forM_ names $ astId alg SigSite + fold alg tp + fold alg (L span (GenericSig names tp)) = astMark alg (Just span) "GenericSig" $ do + forM_ names $ astId alg SigSite + fold alg tp + + -- Only in generated code + fold alg (L span (IdSig _)) = astMark alg (Just span) "IdSig" $ + return Nothing + + -- Annotations + fold alg (L span (FixSig _)) = astMark alg (Just span) "FixSig" $ + return Nothing + fold alg (L span (InlineSig _ _)) = astMark alg (Just span) "InlineSig" $ + return Nothing + fold alg (L span (SpecSig _ _ _)) = astMark alg (Just span) "SpecSig" $ + return Nothing + fold alg (L span (SpecInstSig _)) = astMark alg (Just span) "SpecInstSig" $ + return Nothing + +instance Fold id (LHsType id) where + fold alg (L span (HsFunTy arg res)) = astMark alg (Just span) "HsFunTy" $ + fold alg [arg, res] + fold alg (L span (HsTyVar name)) = astMark alg (Just span) "HsTyVar" $ + astId alg UseSite (L span name) + fold alg (L span (HsForAllTy explicitFlag tyVars ctxt body)) = astMark alg (Just span) "hsForAllTy" $ do + case explicitFlag of + Explicit -> fold alg tyVars + Implicit -> return Nothing + fold alg ctxt + fold alg body + fold alg (L span (HsAppTy fun arg)) = astMark alg (Just span) "HsAppTy" $ + fold alg [fun, arg] + fold alg (L span (HsTupleTy _tupleSort typs)) = astMark alg (Just span) "HsTupleTy" $ + -- tupleSort is unboxed/boxed/etc. + fold alg typs + fold alg (L span (HsListTy typ)) = astMark alg (Just span) "HsListTy" $ + fold alg typ + fold alg (L span (HsPArrTy typ)) = astMark alg (Just span) "HsPArrTy" $ + fold alg typ + fold alg (L span (HsParTy typ)) = astMark alg (Just span) "HsParTy" $ + fold alg typ + fold alg (L span (HsEqTy a b)) = astMark alg (Just span) "HsEqTy" $ + fold alg [a, b] + fold alg (L span (HsDocTy typ _doc)) = astMark alg (Just span) "HsDocTy" $ + -- I don't think HsDocTy actually makes it through the renamer + fold alg typ + fold alg (L span (HsWrapTy _wrapper _typ)) = astMark alg (Just span) "HsWrapTy" $ + -- This is returned only by the type checker, and _typ is not located + return Nothing + fold alg (L span (HsRecTy fields)) = astMark alg (Just span) "HsRecTy" $ + fold alg fields + fold alg (L span (HsKindSig typ kind)) = astMark alg (Just span) "HsKindSig" $ + fold alg [typ, kind] + fold alg (L span (HsBangTy _bang typ)) = astMark alg (Just span) "HsBangTy" $ + fold alg typ + fold alg (L span (HsOpTy left (_wrapper, op) right)) = astMark alg (Just span) "HsOpTy" $ do + fold alg [left, right] + astId alg UseSite op + fold alg (L span (HsIParamTy _var typ)) = astMark alg (Just span) "HsIParamTy" $ + -- _var is not located + fold alg typ + fold alg (L span (HsSpliceTy splice _freevars _postTcKind)) = astMark alg (Just span) "HsSpliceTy" $ + fold alg (L span splice) -- reuse location info + fold alg (L span (HsCoreTy _)) = astMark alg (Just span) "HsCoreTy" $ + -- Not important: doesn't arise until later in the compiler pipeline + return Nothing + fold alg (L span (HsQuasiQuoteTy qquote)) = astMark alg (Just span) "HsQuasiQuoteTy" $ + fold alg (L span qquote) -- reuse location info + fold alg (L span (HsExplicitListTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitListTy" $ + fold alg typs + fold alg (L span (HsExplicitTupleTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitTupleTy" $ + fold alg typs + +instance Fold id (Located (HsSplice id)) where + fold alg (L span (HsSplice _id expr)) = astMark alg (Just span) "HsSplice" $ do + fold alg expr + +instance Fold id (Located (HsQuasiQuote id)) where + fold alg (L span (HsQuasiQuote _id _srcSpan _enclosed)) = astMark alg (Just span) "HsQuasiQuote" $ + -- Unfortunately, no location information is stored within HsQuasiQuote at all + return Nothing + +instance Fold id (LHsTyVarBndr id) where + fold alg (L span (UserTyVar name _postTcKind)) = astMark alg (Just span) "UserTyVar" $ do + astId alg DefSite (L span name) + fold alg (L span (KindedTyVar name kind _postTcKind)) = astMark alg (Just span) "KindedTyVar" $ do + astId alg DefSite (L span name) + fold alg kind + +instance Fold id (LHsContext id) where + fold alg (L span typs) = astMark alg (Just span) "LHsContext" $ + fold alg typs + +instance Fold id (LHsBinds id) where + fold alg = fold alg . bagToList + +instance Fold id (LHsBind id) where + fold alg (L span bind@(FunBind {})) = astMark alg (Just span) "FunBind" $ do + astId alg DefSite (fun_id bind) + fold alg (fun_matches bind) + fold alg (L span bind@(PatBind {})) = astMark alg (Just span) "PatBind" $ do + fold alg (pat_lhs bind) + fold alg (pat_rhs bind) + fold alg (L span _bind@(VarBind {})) = astMark alg (Just span) "VarBind" $ + -- These are only introduced by the type checker, and don't involve user + -- written code. The ghc comments says "located 'only for consistency'" + return Nothing + fold alg (L span bind@(AbsBinds {})) = astMark alg (Just span) "AbsBinds" $ do + forM_ (abs_exports bind) $ \abs_export -> + astId alg DefSite (L typecheckOnly (abe_poly abs_export)) + fold alg (abs_binds bind) + +typecheckOnly :: SrcSpan +typecheckOnly = mkGeneralSrcSpan (fsLit "") + +instance Fold id (MatchGroup id) where + -- We ignore the postTcType, as it doesn't have location information + fold alg (MatchGroup matches _postTcType) = astMark alg Nothing "MatchGroup" $ + fold alg matches + +instance Fold id (LMatch id) where + fold alg (L span (Match pats _type rhss)) = astMark alg (Just span) "Match" $ do + fold alg pats + fold alg rhss + +instance Fold id (GRHSs id) where + fold alg (GRHSs rhss binds) = astMark alg Nothing "GRHSs" $ do + fold alg rhss + fold alg binds + +instance Fold id (LGRHS id) where + fold alg (L span (GRHS _guards rhs)) = astMark alg (Just span) "GRHS" $ + fold alg rhs + +instance Fold id (HsLocalBinds id) where + fold _alg EmptyLocalBinds = + return Nothing + fold alg (HsValBinds binds) = astMark alg Nothing "HsValBinds" $ do + fold alg binds + fold alg (HsIPBinds binds) = + fold alg binds + +instance Fold id (HsIPBinds id) where + fold alg (IPBinds binds _evidence) = + fold alg binds + +instance Fold id (LIPBind id) where + fold alg (L span (IPBind _name expr)) = astMark alg (Just span) "IPBind" $ do + -- Name is not located :( + fold alg expr + +instance Fold id (LHsExpr id) where + fold alg (L span (HsPar expr)) = astMark alg (Just span) "HsPar" $ + fold alg expr + fold alg (L span (ExprWithTySig expr _type)) = astMark alg (Just span) "ExprWithTySig" $ + fold alg expr + fold alg (L span (ExprWithTySigOut expr _type)) = astMark alg (Just span) "ExprWithTySigOut" $ + fold alg expr + fold alg (L span (HsOverLit (OverLit{ol_type}))) = astMark alg (Just span) "HsOverLit" $ do + astExpType alg span (ifPostTc alg ol_type) + fold alg (L span (OpApp left op _fix right)) = astMark alg (Just span) "OpApp" $ do + _leftTy <- fold alg left + opTy <- fold alg op + _rightTy <- fold alg right + astExpType alg span (funRes2 <$> opTy) + fold alg (L span (HsVar id)) = astMark alg (Just span) "HsVar" $ do + astId alg UseSite (L span id) + fold alg (L span (HsWrap wrapper expr)) = astMark alg (Just span) "HsWrap" $ do + ty <- fold alg (L span expr) + astExpType alg span (applyWrapper wrapper <$> ty) + fold alg (L span (HsLet binds expr)) = astMark alg (Just span) "HsLet" $ do + fold alg binds + ty <- fold alg expr + astExpType alg span ty -- Re-astId alg this with the span of the whole let + fold alg (L span (HsApp fun arg)) = astMark alg (Just span) "HsApp" $ do + funTy <- fold alg fun + _argTy <- fold alg arg + astExpType alg span (funRes1 <$> funTy) + fold alg (L span (HsLit lit)) = + -- Intentional omission of the "astMark alg" debugging call here. + -- The syntax "assert" is replaced by GHC by "assertError ", where + -- both "assertError" and the "" are assigned the source span of + -- the original "assert". This means that the (represented as an + -- HsLit) might override "assertError" in the IdMap. + astExpType alg span (ifPostTc alg (hsLitType lit)) + fold alg (L span (HsLam matches@(MatchGroup _ postTcType))) = astMark alg (Just span) "HsLam" $ do + fold alg matches + astExpType alg span (ifPostTc alg postTcType) + fold alg (L span (HsDo _ctxt stmts postTcType)) = astMark alg (Just span) "HsDo" $ do + -- ctxt indicates what kind of statement it is; AFAICT there is no + -- useful information in it for us + fold alg stmts + astExpType alg span (ifPostTc alg postTcType) + fold alg (L span (ExplicitList postTcType exprs)) = astMark alg (Just span) "ExplicitList" $ do + fold alg exprs + astExpType alg span (mkListTy <$> ifPostTc alg postTcType) + fold alg (L span (RecordCon con postTcExpr recordBinds)) = astMark alg (Just span) "RecordCon" $ do + fold alg recordBinds + -- Only traverse the postTcExpr in the right phase (types force us! yay! :) + case astPhase alg of + FoldPreTc -> do + astId alg UseSite con + return Nothing + FoldPostTc -> do + conTy <- fold alg (L (getLoc con) postTcExpr) + astExpType alg span (funResN <$> conTy) + fold alg (L span (HsCase expr matches@(MatchGroup _ postTcType))) = astMark alg (Just span) "HsCase" $ do + fold alg expr + fold alg matches + astExpType alg span (funRes1 <$> ifPostTc alg postTcType) + fold alg (L span (ExplicitTuple args boxity)) = astMark alg (Just span) "ExplicitTuple" $ do + argTys <- mapM (fold alg) args + astExpType alg span (mkTupleTy (boxityNormalTupleSort boxity) <$> sequence argTys) + fold alg (L span (HsIf _rebind cond true false)) = astMark alg (Just span) "HsIf" $ do + _condTy <- fold alg cond + _trueTy <- fold alg true + falseTy <- fold alg false + astExpType alg span falseTy + fold alg (L span (SectionL arg op)) = astMark alg (Just span) "SectionL" $ do + _argTy <- fold alg arg + opTy <- fold alg op + astExpType alg span (mkSectionLTy <$> opTy) + where + mkSectionLTy ty = let (_arg1, arg2, res) = splitFunTy2 ty + in mkFunTy arg2 res + fold alg (L span (SectionR op arg)) = astMark alg (Just span) "SectionR" $ do + opTy <- fold alg op + _argTy <- fold alg arg + astExpType alg span (mkSectionRTy <$> opTy) + where + mkSectionRTy ty = let (arg1, _arg2, res) = splitFunTy2 ty + in mkFunTy arg1 res + fold alg (L span (HsIPVar _name)) = astMark alg (Just span) "HsIPVar" $ + -- _name is not located :( + return Nothing + fold alg (L span (NegApp expr _rebind)) = astMark alg (Just span) "NegApp" $ do + ty <- fold alg expr + astExpType alg span ty + fold alg (L span (HsBracket th)) = astMark alg (Just span) "HsBracket" $ + fold alg th + fold alg (L span (HsBracketOut th pendingSplices)) = astMark alg (Just span) "HsBracketOut" $ do + -- Given something like + -- + -- > \x xs -> [| x : xs |] + -- + -- @pendingSplices@ contains + -- + -- > [ "x", "Language.Haskell.TH.Syntax.lift x" + -- > , "xs", "Language.Haskell.TH.Syntax.lift xs" + -- > ] + -- + -- Sadly, however, ghc attaches to these splices. + -- Moreover, we don't get any type information about the whole bracket + -- expression either :( + case astPhase alg of + FoldPreTc -> fold alg th + FoldPostTc -> do forM_ pendingSplices $ \(_name, splice) -> + fold alg splice + return Nothing + fold alg (L span (RecordUpd expr binds _dataCons _postTcTypeInp _postTcTypeOutp)) = astMark alg (Just span) "RecordUpd" $ do + recordTy <- fold alg expr + fold alg binds + astExpType alg span recordTy -- The type doesn't change + fold alg (L span (HsProc pat body)) = astMark alg (Just span) "HsProc" $ do + fold alg pat + fold alg body + fold alg (L span (HsArrApp arr inp _postTcType _arrType _orient)) = astMark alg (Just span) "HsArrApp" $ do + fold alg [arr, inp] + fold alg (L span (HsArrForm expr _fixity cmds)) = astMark alg (Just span) "HsArrForm" $ do + fold alg expr + fold alg cmds + fold alg (L span (HsTick _tickish expr)) = astMark alg (Just span) "HsTick" $ do + fold alg expr + fold alg (L span (HsBinTick _trueTick _falseTick expr)) = astMark alg (Just span) "HsBinTick" $ do + fold alg expr + fold alg (L span (HsTickPragma _span expr)) = astMark alg (Just span) "HsTickPragma" $ do + fold alg expr + fold alg (L span (HsSCC _string expr)) = astMark alg (Just span) "HsSCC" $ do + fold alg expr + fold alg (L span (HsCoreAnn _string expr)) = astMark alg (Just span) "HsCoreAnn" $ do + fold alg expr + fold alg (L span (HsSpliceE splice)) = astMark alg (Just span) "HsSpliceE" $ do + fold alg (L span splice) -- reuse span + fold alg (L span (HsQuasiQuoteE qquote)) = astMark alg (Just span) "HsQuasiQuoteE" $ do + fold alg (L span qquote) -- reuse span + fold alg (L span (ExplicitPArr _postTcType exprs)) = astMark alg (Just span) "ExplicitPArr" $ do + fold alg exprs + fold alg (L span (PArrSeq _postTcType seqInfo)) = astMark alg (Just span) "PArrSeq" $ do + fold alg seqInfo + + -- According to the comments in HsExpr.lhs, + -- "These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing." + fold alg (L span EWildPat) = astMark alg (Just span) "EWildPat" $ + return Nothing + fold alg (L span (EAsPat _ _)) = astMark alg (Just span) "EAsPat" $ + return Nothing + fold alg (L span (EViewPat _ _)) = astMark alg (Just span) "EViewPat" $ + return Nothing + fold alg (L span (ELazyPat _)) = astMark alg (Just span) "ELazyPat" $ + return Nothing + fold alg (L span (HsType _ )) = astMark alg (Just span) "HsType" $ + return Nothing + fold alg (L span (ArithSeq postTcExpr seqInfo)) = astMark alg (Just span) "ArithSeq" $ do + fold alg seqInfo + case astPhase alg of + FoldPreTc -> return Nothing + FoldPostTc -> fold alg (L span postTcExpr) + +instance Fold id (ArithSeqInfo id) where + fold alg (From expr) = astMark alg Nothing "From" $ + fold alg expr + fold alg (FromThen frm thn) = astMark alg Nothing "FromThen" $ + fold alg [frm, thn] + fold alg (FromTo frm to) = astMark alg Nothing "FromTo" $ + fold alg [frm, to] + fold alg (FromThenTo frm thn to) = astMark alg Nothing "FromThenTo" $ + fold alg [frm, thn, to] + +instance Fold id (LHsCmdTop id) where + fold alg (L span (HsCmdTop cmd _postTcTypeInp _postTcTypeRet _syntaxTable)) = astMark alg (Just span) "HsCmdTop" $ + fold alg cmd + +instance Fold id (HsBracket id) where + fold alg (ExpBr expr) = astMark alg Nothing "ExpBr" $ + fold alg expr + fold alg (PatBr pat) = astMark alg Nothing "PatBr" $ + fold alg pat + fold alg (DecBrG group) = astMark alg Nothing "DecBrG" $ + fold alg group + fold alg (TypBr typ) = astMark alg Nothing "TypBr" $ + fold alg typ + fold alg (VarBr _namespace _id) = astMark alg Nothing "VarBr" $ + -- No location information, sadly + return Nothing + fold alg (DecBrL decls) = astMark alg Nothing "DecBrL" $ + fold alg decls + +instance Fold id (HsTupArg id) where + fold alg (Present arg) = + fold alg arg + fold _alg (Missing _postTcType) = + return Nothing + +instance Fold id a => Fold id (HsRecFields id a) where + fold alg (HsRecFields rec_flds _rec_dotdot) = astMark alg Nothing "HsRecFields" $ + fold alg rec_flds + +instance Fold id a => Fold id (HsRecField id a) where + fold alg (HsRecField id arg _pun) = astMark alg Nothing "HsRecField" $ do + astId alg UseSite id + fold alg arg + +-- The meaning of the constructors of LStmt isn't so obvious; see various +-- notes in ghc/compiler/hsSyn/HsExpr.lhs +instance Fold id (LStmt id) where + fold alg (L span (ExprStmt expr _seq _guard _postTcType)) = astMark alg (Just span) "ExprStmt" $ + -- Neither _seq nor _guard are located + fold alg expr + fold alg (L span (BindStmt pat expr _bind _fail)) = astMark alg (Just span) "BindStmt" $ do + -- Neither _bind or _fail are located + fold alg pat + fold alg expr + fold alg (L span (LetStmt binds)) = astMark alg (Just span) "LetStmt" $ + fold alg binds + fold alg (L span (LastStmt expr _return)) = astMark alg (Just span) "LastStmt" $ + fold alg expr + fold alg (L span stmt@(RecStmt {})) = astMark alg (Just span) "RecStmt" $ do + fold alg (recS_stmts stmt) + + fold alg (L span (TransStmt {})) = astUnsupported alg (Just span) "TransStmt" + fold alg (L span (ParStmt _ _ _ _)) = astUnsupported alg (Just span) "ParStmt" + +instance Fold id (LPat id) where + fold alg (L span (WildPat postTcType)) = astMark alg (Just span) "WildPat" $ + astExpType alg span (ifPostTc alg postTcType) + fold alg (L span (VarPat id)) = astMark alg (Just span) "VarPat" $ + astId alg DefSite (L span id) + fold alg (L span (LazyPat pat)) = astMark alg (Just span) "LazyPat" $ + fold alg pat + fold alg (L span (AsPat id pat)) = astMark alg (Just span) "AsPat" $ do + astId alg DefSite id + fold alg pat + fold alg (L span (ParPat pat)) = astMark alg (Just span) "ParPat" $ + fold alg pat + fold alg (L span (BangPat pat)) = astMark alg (Just span) "BangPat" $ + fold alg pat + fold alg (L span (ListPat pats _postTcType)) = astMark alg (Just span) "ListPat" $ + fold alg pats + fold alg (L span (TuplePat pats _boxity _postTcType)) = astMark alg (Just span) "TuplePat" $ + fold alg pats + fold alg (L span (PArrPat pats _postTcType)) = astMark alg (Just span) "PArrPat" $ + fold alg pats + fold alg (L span (ConPatIn con details)) = astMark alg (Just span) "ConPatIn" $ do + -- Unlike ValBindsIn and HsValBindsIn, we *do* get ConPatIn + astId alg UseSite con -- the constructor name is non-binding + fold alg details + fold alg (L span (ConPatOut {pat_con, pat_args})) = astMark alg (Just span) "ConPatOut" $ do + -- this pattern match on unit is necessary to avoid ghc bug (not sure why) + () <- case astPhase alg of + FoldPreTc -> do astId alg UseSite (L (getLoc pat_con) (dataConName (unLoc pat_con))) + return () + FoldPostTc -> return () + fold alg pat_args + fold alg (L span (LitPat _)) = astMark alg (Just span) "LitPat" $ + return Nothing + fold alg (L span (NPat _ _ _)) = astMark alg (Just span) "NPat" $ + return Nothing + fold alg (L span (NPlusKPat id _lit _rebind1 _rebind2)) = astMark alg (Just span) "NPlusKPat" $ do + astId alg DefSite id + fold alg (L span (ViewPat expr pat _postTcType)) = astMark alg (Just span) "ViewPat" $ do + fold alg expr + fold alg pat + fold alg (L span (SigPatIn pat typ)) = astMark alg (Just span) "SigPatIn" $ do + fold alg pat + fold alg typ + fold alg (L span (SigPatOut pat _typ)) = astMark alg (Just span) "SigPatOut" $ do + -- _typ is not located + fold alg pat + fold alg (L span (QuasiQuotePat qquote)) = astMark alg (Just span) "QuasiQuotePat" $ + fold alg (L span qquote) -- reuse span + + -- During translation only + fold alg (L span (CoPat _ _ _)) = astMark alg (Just span) "CoPat" $ + return Nothing + +instance (Fold id arg, Fold id rec) => Fold id (HsConDetails arg rec) where + fold alg (PrefixCon args) = astMark alg Nothing "PrefixCon" $ + fold alg args + fold alg (RecCon rec) = astMark alg Nothing "RecCon" $ + fold alg rec + fold alg (InfixCon a b) = astMark alg Nothing "InfixCon" $ + fold alg [a, b] + +instance Fold id (LTyClDecl id) where + fold alg (L span decl@(TyData {})) = astMark alg (Just span) "TyData" $ do + fold alg (tcdCtxt decl) + astId alg DefSite (tcdLName decl) + fold alg (tcdTyVars decl) + fold alg (tcdTyPats decl) + fold alg (tcdKindSig decl) + fold alg (tcdCons decl) + fold alg (tcdDerivs decl) + fold alg (L span decl@(ClassDecl {})) = astMark alg (Just span) "ClassDecl" $ do + fold alg (tcdCtxt decl) + astId alg DefSite (tcdLName decl) + fold alg (tcdTyVars decl) + -- Sadly, we don't get location info for the functional dependencies + fold alg (tcdSigs decl) + fold alg (tcdMeths decl) + fold alg (tcdATs decl) + fold alg (tcdATDefs decl) + fold alg (tcdDocs decl) + fold alg (L span decl@(TySynonym {})) = astMark alg (Just span) "TySynonym" $ do + -- See "Representation of indexed types" in compiler/hsSyn/HsDecls.lhs + case tcdTyPats decl of + Nothing -> astId alg DefSite (tcdLName decl) + Just _ -> astId alg UseSite (tcdLName decl) + fold alg (tcdTyVars decl) + fold alg (tcdTyPats decl) + fold alg (tcdSynRhs decl) + fold alg (L span decl@(TyFamily {})) = astMark alg (Just span) "TyFamily" $ do + astId alg DefSite (tcdLName decl) + fold alg (tcdTyVars decl) + fold alg (tcdKind decl) + fold alg (L span _decl@(ForeignType {})) = astUnsupported alg (Just span) "ForeignType" + +instance Fold id (LConDecl id) where + fold alg (L span decl@(ConDecl {})) = astMark alg (Just span) "ConDecl" $ do + astId alg DefSite (con_name decl) + fold alg (con_qvars decl) + fold alg (con_cxt decl) + fold alg (con_details decl) + fold alg (con_res decl) + +instance Fold id (ResType id) where + fold alg ResTyH98 = astMark alg Nothing "ResTyH98" $ do + return Nothing -- Nothing to do + fold alg (ResTyGADT typ) = astMark alg Nothing "ResTyGADT" $ do + fold alg typ + +instance Fold id (ConDeclField id) where + fold alg (ConDeclField name typ _doc) = do + astId alg DefSite name + fold alg typ + +instance Fold id (LInstDecl id) where + fold alg (L span (InstDecl typ binds sigs accTypes)) = astMark alg (Just span) "LInstDecl" $ do + fold alg typ + fold alg binds + fold alg sigs + fold alg accTypes + +instance Fold id (LDerivDecl id) where + fold alg (L span (DerivDecl deriv_type)) = astMark alg (Just span) "LDerivDecl" $ do + fold alg deriv_type + +instance Fold id (LFixitySig id) where + fold alg (L span (FixitySig name _fixity)) = astMark alg (Just span) "LFixitySig" $ do + astId alg SigSite name + +instance Fold id (LDefaultDecl id) where + fold alg (L span (DefaultDecl typs)) = astMark alg (Just span) "LDefaultDecl" $ do + fold alg typs + +instance Fold id (LForeignDecl id) where + fold alg (L span (ForeignImport name sig _coercion _import)) = astMark alg (Just span) "ForeignImport" $ do + astId alg DefSite name + fold alg sig + fold alg (L span (ForeignExport name sig _coercion _export)) = astMark alg (Just span) "ForeignExport" $ do + astId alg UseSite name + fold alg sig + +instance Fold id (LWarnDecl id) where + fold alg (L span (Warning name _txt)) = astMark alg (Just span) "Warning" $ do + -- We use the span of the entire warning because we don't get location info for name + astId alg UseSite (L span name) + +instance Fold id (LAnnDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LAnnDecl" + +instance Fold id (LRuleDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LRuleDecl" + +instance Fold id (LVectDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LVectDecl" + +instance Fold id LDocDecl where + fold alg (L span _) = astMark alg (Just span) "LDocDec" $ + -- Nothing to do + return Nothing + +instance Fold id (Located (SpliceDecl id)) where + fold alg (L span (SpliceDecl expr _explicit)) = astMark alg (Just span) "SpliceDecl" $ do + fold alg expr + +-- LHsDecl is a wrapper around the various kinds of declarations; the wrapped +-- declarations don't have location information of themselves, so we reuse +-- the location info of the wrapper +instance Fold id (LHsDecl id) where + fold alg (L span (TyClD tyClD)) = astMark alg (Just span) "TyClD" $ + fold alg (L span tyClD) + fold alg (L span (InstD instD)) = astMark alg (Just span) "InstD" $ + fold alg (L span instD) + fold alg (L span (DerivD derivD)) = astMark alg (Just span) "DerivD" $ + fold alg (L span derivD) + fold alg (L span (ValD valD)) = astMark alg (Just span) "ValD" $ + fold alg (L span valD) + fold alg (L span (SigD sigD)) = astMark alg (Just span) "SigD" $ + fold alg (L span sigD) + fold alg (L span (DefD defD)) = astMark alg (Just span) "DefD" $ + fold alg (L span defD) + fold alg (L span (ForD forD)) = astMark alg (Just span) "ForD" $ + fold alg (L span forD) + fold alg (L span (WarningD warningD)) = astMark alg (Just span) "WarningD" $ + fold alg (L span warningD) + fold alg (L span (AnnD annD)) = astMark alg (Just span) "AnnD" $ + fold alg (L span annD) + fold alg (L span (RuleD ruleD)) = astMark alg (Just span) "RuleD" $ + fold alg (L span ruleD) + fold alg (L span (VectD vectD)) = astMark alg (Just span) "VectD" $ + fold alg (L span vectD) + fold alg (L span (SpliceD spliceD)) = astMark alg (Just span) "SpliceD" $ + fold alg (L span spliceD) + fold alg (L span (DocD docD)) = astMark alg (Just span) "DocD" $ + fold alg (L span docD) + fold alg (L span (QuasiQuoteD quasiQuoteD)) = astMark alg (Just span) "QuasiQuoteD" $ + fold alg (L span quasiQuoteD) + +{------------------------------------------------------------------------------ + Operations on types +------------------------------------------------------------------------------} + +applyWrapper :: HsWrapper -> Type -> Type +applyWrapper WpHole t = t -- identity +applyWrapper (WpTyApp t') t = applyTy t t' +applyWrapper (WpEvApp _) t = funRes1 t +applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t +applyWrapper (WpCast coercion) _ = let Pair _ t = tcCoercionKind coercion in t +applyWrapper (WpTyLam v) t = mkForAllTy v t +applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t +applyWrapper (WpLet _) t = t -- we don't care about evidence _terms_ + +-- | Given @a -> b@, return @b@ +funRes1 :: Type -> Type +funRes1 = snd . splitFunTy + +-- | Given @a1 -> a2 -> b@, return @b@ +funRes2 :: Type -> Type +funRes2 = funRes1 . funRes1 + +-- | Given @a1 -> a2 -> ... -> b@, return @b@ +funResN :: Type -> Type +funResN = snd . splitFunTys + +-- | Given @a -> b -> c@, return @(a, b, c)@ +splitFunTy2 :: Type -> (Type, Type, Type) +splitFunTy2 ty0 = let (arg1, ty1) = splitFunTy ty0 + (arg2, ty2) = splitFunTy ty1 + in (arg1, arg2, ty2) + +typeOfTyThing :: TyThing -> Maybe Type +typeOfTyThing (ADataCon dataCon) = Just $ dataConRepType dataCon +typeOfTyThing _ = Nothing + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Parse an installed package ID as if it was a source package ID +-- +-- NOTE: This no longer works for ghc 7.10 and up. +installedToSourceId :: Cabal.InstalledPackageId -> Cabal.PackageId +installedToSourceId (Cabal.InstalledPackageId instId) = parseSourceId instId + +-- | Parse a source package ID +-- +-- Returns an empty package ID if the parse failed. +parseSourceId :: String -> Cabal.PackageId +parseSourceId = emptyOnParseFailure + . Maybe.mapMaybe successfulParse + . Cabal.readP_to_S Cabal.parse + where + successfulParse :: (a, String) -> Maybe a + successfulParse (a, unparsed) = if null unparsed then Just a else Nothing + + emptyOnParseFailure :: [Cabal.PackageId] -> Cabal.PackageId + emptyOnParseFailure (i:_) = i + emptyOnParseFailure [] = Cabal.PackageIdentifier { + pkgName = Cabal.PackageName "" + , pkgVersion = Version [] [] + } + +pkgName :: Cabal.PackageIdentifier -> String +pkgName pkgId = let Cabal.PackageName nm = Cabal.pkgName pkgId in nm diff --git a/GhcShim/GhcShim78.hs b/GhcShim/GhcShim78.hs new file mode 100644 --- /dev/null +++ b/GhcShim/GhcShim78.hs @@ -0,0 +1,1621 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, StandaloneDeriving, MultiParamTypeClasses, GADTs #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-} +module GhcShim.GhcShim78 + ( -- * Pretty-printing + showSDoc + , pretty + , prettyM + , prettyType + , prettyTypeM + -- * Errors + , sourceErrorSpan + -- * Breakpoints + , getBreak + , setBreak + -- * Time + , GhcTime + -- * Setup + , ghcGetVersion + , packageDBFlags + , setGhcOptions + , storeDynFlags + -- * Package keys (see GhcShim.hs). + , PackageKey + , PackageQualifier + , lookupPackage + , mainPackageKey + , modulePackageKey + , packageKeyString + , stringToPackageKey + , packageKeyToSourceId + , findExposedModule + -- * Folding + , AstAlg(..) + , fold + -- * Operations on types + , typeOfTyThing + -- * Re-exports + , tidyOpenType + ) where + +import Prelude hiding (id, span) +import Control.Monad (void, forM_, liftM) +import Data.IORef +import Data.Time (UTCTime) +import Data.Version +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Maybe as Maybe + +import Bag +import BasicTypes hiding (Version) +import ConLike (ConLike(RealDataCon)) +import DataCon (dataConRepType) +import DynFlags +import ErrUtils +import FastString +import GHC hiding (getBreak) +import Linker +import Module +import MonadUtils +import Outputable hiding (showSDoc) +import PackageConfig (PackageConfig) +import Pair +import PprTyThing +import Pretty +import SrcLoc +import TcEvidence +import TcHsSyn +import TcType +import Type +import TysWiredIn +import qualified BreakArray +import qualified Packages + +import qualified Distribution.Package as Cabal +import qualified Distribution.InstalledPackageInfo as Cabal +import qualified Distribution.Text as Cabal +import qualified Distribution.Compat.ReadP as Cabal + +import GhcShim.API +import IdeSession.GHC.API (GhcVersion(..)) + +{------------------------------------------------------------------------------ + Pretty-printing +------------------------------------------------------------------------------} + +showSDoc :: DynFlags -> PprStyle -> SDoc -> String +showSDoc dflags pprStyle doc = + showDoc OneLineMode 100 + $ runSDoc doc + $ initSDocContext dflags pprStyle + +pretty :: Outputable a => DynFlags -> PprStyle -> a -> String +pretty dynFlags pprStyle = showSDoc dynFlags pprStyle . ppr + +prettyType :: DynFlags -> PprStyle -> Bool -> Type -> String +prettyType dynFlags pprStyle showForalls typ = + showSDoc dynFlags' pprStyle (pprTypeForUser typ) + where + dynFlags' :: DynFlags + dynFlags' | showForalls = dynFlags `gopt_set` Opt_PrintExplicitForalls + | otherwise = dynFlags `gopt_unset` Opt_PrintExplicitForalls + +prettyM :: (Outputable a, Monad m, HasDynFlags m) => PprStyle -> a -> m String +prettyM pprStyle x = do + dynFlags <- getDynFlags + return (pretty dynFlags pprStyle x) + +prettyTypeM :: (Monad m, HasDynFlags m) => PprStyle -> Bool -> Type -> m String +prettyTypeM pprStyle showForalls typ = do + dynFlags <- getDynFlags + return $ prettyType dynFlags pprStyle showForalls typ + +{------------------------------------------------------------------------------ + Show instances +------------------------------------------------------------------------------} + +deriving instance Show Severity + +{------------------------------------------------------------------------------ + Source errors +------------------------------------------------------------------------------} + +sourceErrorSpan :: ErrMsg -> Maybe SrcSpan +sourceErrorSpan errMsg = case errMsgSpan errMsg of + real@RealSrcSpan{} -> Just real + _ -> Nothing + +{------------------------------------------------------------------------------ + Breakpoints +------------------------------------------------------------------------------} + +getBreak :: BreakArray -> Int -> Ghc (Maybe Bool) +getBreak array index = do + dflags <- getDynFlags + val <- liftIO $ BreakArray.getBreak dflags array index + return ((== 1) `liftM` val) + +setBreak :: BreakArray -> Int -> Bool -> Ghc () +setBreak array index value = do + dflags <- getDynFlags + void . liftIO $ if value then BreakArray.setBreakOn dflags array index + else BreakArray.setBreakOff dflags array index + +{------------------------------------------------------------------------------ + Time +------------------------------------------------------------------------------} + +type GhcTime = UTCTime + +{------------------------------------------------------------------------------ + Setup +------------------------------------------------------------------------------} + +ghcGetVersion :: GhcVersion +ghcGetVersion = GHC_7_8 + +packageDBFlags :: Bool -> [String] -> [String] +packageDBFlags userDB specificDBs = + ["-no-user-package-db" | not userDB] + ++ concat [["-package-db", db] | db <- specificDBs] + +-- | Set GHC options +-- +-- This is meant to be stateless. It is important to call storeDynFlags at least +-- once before calling setGhcOptions so that we know what state to restore to +-- before setting the options. +-- +-- Returns unrecognized options and warnings +setGhcOptions :: [String] -> Ghc ([String], [String]) +setGhcOptions opts = do + dflags <- restoreDynFlags + (dflags', leftover, warnings) <- parseDynamicFlags dflags (map noLoc opts) + setupLinkerState =<< setSessionDynFlags dflags' + return (map unLoc leftover, map unLoc warnings) + +-- | Setup linker state to deal with changed package flags +-- +-- This follows newDynFlags in ghci, except that in 7.8 there is also the +-- notion of "interactive dynflags", which we are ignoring completely. +-- I'm not sure if that's ok or not. +setupLinkerState :: [PackageId] -> Ghc () +setupLinkerState newPackages = do + dflags <- getSessionDynFlags + setTargets [] + load LoadAllTargets + liftIO $ linkPackages dflags newPackages + +{------------------------------------------------------------------------------ + Backup DynFlags + + Sadly, this hardcodes quite a bit of version-specific information about ghc's + inner workings. Unfortunately, there is no easy way to know which parts of + DynFlags should and should not be restored to restore flags. The flag + specification is given by (see packageDynamicFlags in compiler/main/GHC.hs) + + > package_flags ++ dynamic_flags + + both of which are defined in DynFlags.hs. They are not exported, but this + would not be particularly useful anyway, as the action associated with a + flag is given by a shallow embedding, so we cannot walk over them and extract + the necessary info about DynFlags. At least, we cannot do that in code -- we + can do it manually, and that is precisely what I've done to obtain the list + below. Of course, this means it's somewhat error prone. + + In order so that this code can be audited and cross-checked against the + actual ghc version, and so that it can be modified for future ghc versions, + we don't just list the end result if this manual traversal, but document the + process. + + Each of the command line options are defined in terms of a auxiliary + functions that specify their effect on DynFlags. These auxiliary functions + are listed below, along with which parts of DynFlags they modify: + + > FUNCTION MODIFIES FIELD(s) OF DYNFLAGS + > ---------------------------------------------------------------------------- + > addCmdlineFramework cmdlineFrameworks + > addCmdlineHCInclude cmdlineHcIncludes + > addDepExcludeMod depExcludeMods + > addDepSuffix depSuffixes + > addFrameworkPath frameworkPaths + > addGhciScript ghciScripts + > addHaddockOpts haddockOptions + > addImportPath importPaths + > addIncludePath includePaths + > addLdInputs ldInputs + > addLibraryPath libraryPaths + > addOptP settings + > addOptc settings + > addOptl settings + > addPkgConfRef extraPkgConfs + > addPluginModuleName pluginModNames + > addPluginModuleNameOption pluginModNameOpts + > addWay ways, packageFlags, extensions, extensionFlags, generalFlags + > alterSettings settings + > clearPkgConf extraPkgConfs + > disableGlasgowExts generalFlags, extensions, extensionFlags + > distrustPackage packageFlags + > enableGlasgowExts generalFlags, extensions, extensionFlags + > exposePackage packageFlags + > exposePackageId packageFlags + > forceRecompile generalFlags + > hidePackage packageFlags + > ignorePackage packageFlags + > parseDynLibLoaderMode dynLibLoader + > removeGlobalPkgConf extraPkgConfs + > removeUserPkgConf extraPkgConfs + > removeWayDyn ways + > setDPHOpt optLevel, generalFlags, maxSimplIterations, simplPhases + > setDepIncludePkgDeps depIncludePkgDeps + > setDepMakefile depMakefile + > setDumpDir dumpDir + > setDumpFlag dumpFlags, generalFlags + > setDumpFlag' dumpFlags, generalFlags + > setDumpPrefixForce dumpPrefixForce + > setDumpSimplPhases generalFlags, shouldDumpSimplPhase + > setDylibInstallName dylibInstallName + > setDynHiSuf dynHiSuf + > setDynObjectSuf dynObjectSuf + > setDynOutputFile dynOutputFile + > setExtensionFlag extensions, extensionFlags + > setGeneralFlag generalFlags + > setHcSuf hcSuf + > setHiDir hiDir + > setHiSuf hiSuf + > setInteractivePrint interactivePrint + > setLanguage language, extensionFlags + > setMainIs mainFunIs, mainModIs + > setObjTarget hscTarget + > setObjectDir objectDir + > setObjectSuf objectSuf + > setOptHpcDir hpcDir + > setOptLevel optLevel, generalFlags + > setOutputDir objectDir, hiDir, stubDir, dumpDir + > setOutputFile outputFile + > setOutputHi outputHi + > setPackageName thisPackage + > setPackageTrust generalFlags, pkgTrustOnLoc + > setPgmP settings + > setRtsOpts rtsOpts + > setRtsOptsEnabled rtsOptsEnabled + > setSafeHaskell safeHaskell + > setStubDir stubDir + > setTarget hscTarget + > setTargetWithPlatform hscTarget + > setTmpDir settings + > setVerboseCore2Core dumpFlags, generalFlags, shouldDumpSimplPhase + > setVerbosity verbosity + > setWarningFlag warningFlags + > trustPackage packageFlags + > unSetExtensionFlag extensions, extensionFlags + > unSetGeneralFlag generalFlags + > unSetWarningFlag warningFlags + + Below is a list of the dynamic_flags in alphabetical order along with the + auxiliary function that they use. A handful of these flags define their + effect on DynFlags directly; these are marked (**). + + > FLAG DEFINED IN TERMS OF + > ---------------------------------------------------------------------------- + > "#include" addCmdlineHCInclude + > "D" addOptP + > "F" setGeneralFlag + > "H" ** sets ghcHeapSize + > "I" addIncludePath + > "L" addLibraryPath + > "O" setOptLevel + > "O" setOptLevel + > "Odph" setDPHOpt + > "Onot" setOptLevel + > "Rghc-timing" ** sets enableTimeStats + > "U" addOptP + > "W" setWarningFlag + > "Wall" setWarningFlag + > "Werror" setGeneralFlag + > "Wnot" ** sets warningFlags + > "Wwarn" unSetGeneralFlag + > "auto" ** sets profAuto + > "auto-all" ** sets profAuto + > "caf-all" setGeneralFlag + > "cpp" setExtensionFlag + > "dasm-lint" setGeneralFlag + > "dcmm-lint" setGeneralFlag + > "dcore-lint" setGeneralFlag + > "ddump-asm" setDumpFlag + > "ddump-asm-conflicts" setDumpFlag + > "ddump-asm-expanded" setDumpFlag + > "ddump-asm-liveness" setDumpFlag + > "ddump-asm-native" setDumpFlag + > "ddump-asm-regalloc" setDumpFlag + > "ddump-asm-regalloc-stages" setDumpFlag + > "ddump-asm-stats" setDumpFlag + > "ddump-bcos" setDumpFlag + > "ddump-cmm" setDumpFlag + > "ddump-cmm-cbe" setDumpFlag + > "ddump-cmm-cfg" setDumpFlag + > "ddump-cmm-cps" setDumpFlag + > "ddump-cmm-info" setDumpFlag + > "ddump-cmm-proc" setDumpFlag + > "ddump-cmm-procmap" setDumpFlag + > "ddump-cmm-raw" setDumpFlag + > "ddump-cmm-sink" setDumpFlag + > "ddump-cmm-sp" setDumpFlag + > "ddump-cmm-split" setDumpFlag + > "ddump-core-pipeline" setDumpFlag + > "ddump-core-stats" setDumpFlag + > "ddump-cs-trace" setDumpFlag + > "ddump-cse" setDumpFlag + > "ddump-deriv" setDumpFlag + > "ddump-ds" setDumpFlag + > "ddump-file-prefix" setDumpPrefixForce + > "ddump-foreign" setDumpFlag + > "ddump-hi" setDumpFlag + > "ddump-hi-diffs" setDumpFlag + > "ddump-hpc" setDumpFlag + > "ddump-if-trace" setDumpFlag + > "ddump-inlinings" setDumpFlag + > "ddump-llvm" setObjTarget, setDumpFlag' + > "ddump-minimal-imports" setGeneralFlag + > "ddump-mod-cycles" setDumpFlag + > "ddump-occur-anal" setDumpFlag + > "ddump-opt-cmm" setDumpFlag + > "ddump-parsed" setDumpFlag + > "ddump-prep" setDumpFlag + > "ddump-rn" setDumpFlag + > "ddump-rn-stats" setDumpFlag + > "ddump-rn-trace" setDumpFlag + > "ddump-rtti" setDumpFlag + > "ddump-rule-firings" setDumpFlag + > "ddump-rule-rewrites" setDumpFlag + > "ddump-rules" setDumpFlag + > "ddump-simpl" setDumpFlag + > "ddump-simpl-iterations" setDumpFlag + > "ddump-simpl-phases" setDumpSimplPhases + > "ddump-simpl-stats" setDumpFlag + > "ddump-simpl-trace" setDumpFlag + > "ddump-spec" setDumpFlag + > "ddump-splices" setDumpFlag + > "ddump-stg" setDumpFlag + > "ddump-stranal" setDumpFlag + > "ddump-strsigs" setDumpFlag + > "ddump-tc" setDumpFlag + > "ddump-tc-trace" setDumpFlag' + > "ddump-ticked" setDumpFlag + > "ddump-to-file" setGeneralFlag + > "ddump-types" setDumpFlag + > "ddump-vect" setDumpFlag + > "ddump-view-pattern-commoning" setDumpFlag + > "ddump-vt-trace" setDumpFlag + > "ddump-worker-wrapper" setDumpFlag + > "debug" addWay + > "dep-makefile" setDepMakefile + > "dep-suffix" addDepSuffix + > "dfaststring-stats" setGeneralFlag + > "dll-split" ** sets dllSplitFile, dllSplit + > "dno-llvm-mangler" setGeneralFlag + > "dppr-cols" ** sets pprCols + > "dppr-user-length" ** sets pprUserLength + > "dshow-passes" forceRecompile, setVerbosity + > "dsource-stats" setDumpFlag + > "dstg-lint" setGeneralFlag + > "dstg-stats" setGeneralFlag + > "dsuppress-all" setGeneralFlag + > "dtrace-level" ** sets traceLevel + > "dumpdir" setDumpDir + > "dverbose-core2core" setVerbosity, setVerboseCore2Core + > "dverbose-stg2stg" setDumpFlag + > "dylib-install-name" setDylibInstallName + > "dynamic" addWay + > "dynamic-too" setGeneralFlag + > "dynhisuf" setDynHiSuf + > "dynload" parseDynLibLoaderMode + > "dyno" setDynOutputFile + > "dynosuf" setDynObjectSuf + > "eventlog" addWay + > "exclude-module" addDepExcludeMod + > "fPIC" setGeneralFlag + > "fasm" setObjTarget + > "fbyte-code" setTarget + > "fcontext-stack" ** sets ctxtStkDepth + > "ffloat-all-lams" ** sets floatLamArgs + > "ffloat-lam-args" ** sets floatLamArgs + > "fghci-hist-size" ** sets ghciHistSize + > "fglasgow-exts" enableGlasgowExts + > "fhistory-size" ** sets historySize + > "fliberate-case-threshold" ** sets liberateCaseThreshold + > "fllvm" setObjTarget + > "fmax-relevant-binds" ** sets maxRelevantBinds + > "fmax-simplifier-iterations" ** sets maxSimplIterations + > "fmax-worker-args" ** sets maxWorkerArgs + > "fno-PIC" unSetGeneralFlag + > "fno-code" setTarget, ** sets ghcLink + > "fno-glasgow-exts" disableGlasgowExts + > "fno-liberate-case-threshold" ** sets liberateCaseThreshold + > "fno-max-relevant-binds" ** sets maxRelevantBinds + > "fno-prof-auto" ** sets profAuto + > "fno-safe-infer" setSafeHaskell + > "fno-spec-constr-count" ** sets specConstrCount + > "fno-spec-constr-threshold" ** sets specConstrThreshold + > "fobject-code" setTargetWithPlatform + > "fpackage-trust" setPackageTrust + > "fplugin" addPluginModuleName + > "fplugin-opt" addPluginModuleNameOption + > "fprof-auto" ** sets profAuto + > "fprof-auto-calls" ** sets profAuto + > "fprof-auto-exported" ** sets profAuto + > "fprof-auto-top" ** sets profAuto + > "framework" addCmdlineFramework + > "framework-path" addFrameworkPath + > "frule-check" ** sets ruleCheck + > "fsimpl-tick-factor" ** sets simplTickFactor + > "fsimplifier-phases" ** sets simplPhases + > "fspec-constr-count" ** sets specConstrCount + > "fspec-constr-recursive" ** sets specConstrRecursive + > "fspec-constr-threshold" ** sets specConstrThreshold + > "fstrictness-before" ** sets strictnessBefore + > "ftype-function-depth" ** sets tyFunStkDepth + > "funfolding-creation-threshold" ** sets ufCreationThreshold + > "funfolding-dict-discount" ** sets ufDictDiscount + > "funfolding-fun-discount" ** sets ufFunAppDiscount + > "funfolding-keeness-factor" ** sets ufKeenessFactor + > "funfolding-use-threshold" ** sets ufUseThreshold + > "fvia-C" <> + > "fvia-c" <> + > "ghci-script" addGhciScript + > "gransim" addWay + > "haddock" setGeneralFlag + > "haddock-opts" addHaddockOpts + > "hcsuf" setHcSuf + > "hidir" setHiDir + > "hisuf" setHiSuf + > "hpcdir" setOptHpcDir + > "i" addImportPath + > "include-pkg-deps" setDepIncludePkgDeps + > "interactive-print" setInteractivePrint + > "j" ** sets parMakeCount + > "keep-hc-file" setGeneralFlag + > "keep-hc-files" setGeneralFlag + > "keep-llvm-file" setObjTarget, setGeneralFlag + > "keep-llvm-files" setObjTarget, setGeneralFlag + > "keep-raw-s-file" <> + > "keep-raw-s-files" <> + > "keep-s-file" setGeneralFlag + > "keep-s-files" setGeneralFlag + > "keep-tmp-files" setGeneralFlag + > "l" addLdInputs + > "main-is" setMainIs + > "mavx" ** sets avx + > "mavx2" ** sets avx2 + > "mavx512cd" ** sets avx512cd + > "mavx512er" ** sets avx512er + > "mavx512f" ** sets avx512f + > "mavx512pf" ** sets avx512pf + > "monly-2-regs" <> + > "monly-3-regs" <> + > "monly-4-regs" <> + > "msse" ** sets sseVersion + > "n" <> + > "ndp" addWay + > "no-auto" ** sets profAuto + > "no-auto-all" ** sets profAuto + > "no-auto-link-packages" unSetGeneralFlag + > "no-caf-all" unSetGeneralFlag + > "no-hs-main" setGeneralFlag + > "no-link" ** sets ghcLink + > "no-recomp" setGeneralFlag + > "no-rtsopts" setRtsOptsEnabled + > "o" setOutputFile + > "odir" setObjectDir + > "ohi" setOutputHi + > "optF" alterSettings + > "optL" alterSettings + > "optP" addOptP + > "opta" alterSettings + > "optc" addOptc + > "optdep--exclude-module" addDepExcludeMod + > "optdep--include-pkg-deps" setDepIncludePkgDeps + > "optdep--include-prelude" setDepIncludePkgDeps + > "optdep-f" setDepMakefile + > "optdep-s" addDepSuffix + > "optdep-w" <> + > "optdep-x" addDepExcludeMod + > "optl" addOptl + > "optlc" alterSettings + > "optlo" alterSettings + > "optm" <> + > "optwindres" alterSettings + > "osuf" setObjectSuf + > "outputdir" setOutputDir + > "parallel" addWay + > "pgmF" alterSettings + > "pgmL" alterSettings + > "pgmP" setPgmP + > "pgma" alterSettings + > "pgmc" alterSettings + > "pgmdll" alterSettings + > "pgml" alterSettings + > "pgmlc" alterSettings + > "pgmlibtool" alterSettings + > "pgmlo" alterSettings + > "pgmm" <> + > "pgms" alterSettings + > "pgmwindres" alterSettings + > "prof" addWay + > "rdynamic" <> + > "recomp" unSetGeneralFlag + > "relative-dynlib-paths" setGeneralFlag + > "rtsopts" setRtsOptsEnabled + > "rtsopts=all" setRtsOptsEnabled + > "rtsopts=none" setRtsOptsEnabled + > "rtsopts=some" setRtsOptsEnabled + > "shared" ** sets ghcLink + > "smp" addWay + > "split-objs" setGeneralFlag + > "static" removeWayDyn + > "staticlib" ** sets ghcLink + > "stubdir" setStubDir + > "threaded" addWay + > "ticky" setGeneralFlag + > "ticky-LNE" setGeneralFlag + > "ticky-allocd" setGeneralFlag + > "ticky-dyn-thunk" setGeneralFlag + > "tmpdir" setTmpDir + > "v" setVerbosity + > "w" ** sets warningFlags + > "with-rtsopts" setRtsOpts + + Finally, there is a bunch of flags defined in terms of setGeneralFlag, + unSetGeneralFlag, setWarningFlag, unSetWarningFlag, setExtensionFlag, + unSetExtensionFlag, setLanguage, and setSafeHaskell. + + The same list for package_flags: + + > FLAG DEFINED IN TERMS OF + > ---------------------------------------------------------------------------- + > "clear-package-db" clearPkgConf + > "distrust" distrustPackage + > "distrust-all-packages" setGeneralFlag + > "global-package-db" addPkgConfRef + > "hide-all-packages" setGeneralFlag + > "hide-package" hidePackage + > "ignore-package" ignorePackage + > "no-global-package-db" removeGlobalPkgConf + > "no-user-package-conf" removeUserPkgConf + > "no-user-package-db" removeUserPkgConf + > "package" exposePackage + > "package-conf" addPkgConfRef + > "package-db" addPkgConfRef + > "package-id" exposePackageId + > "package-name" setPackageName + > "syslib" exposePackage + > "trust" trustPackage + > "user-package-db" addPkgConfRef + + In addition to the above, we also reset one more field: pkgDatabase. The + pkgDatabase is initialized on the first call to initPackages (and hence the + first call to setSessionDynFlags), which happens at server startup. After + that, subsequent calls to setSessionDynFlags take the _existing_ pkgDatabase, + but applies the "batch package flags" to it (hide-all-packages, + distrust-all-packages). However, it doesn't "unapply" these batch flags. By + restoring the pkgDatabase to the value it gets at server startup, we + effectively restore these batch flags whenever we apply user settings. +------------------------------------------------------------------------------} + +dynFlagsRef :: IORef DynFlags +{-# NOINLINE dynFlagsRef #-} +dynFlagsRef = unsafePerformIO $ newIORef (error "No DynFlags stored yet") + +storeDynFlags :: Ghc () +storeDynFlags = do + dynFlags <- getSessionDynFlags + liftIO $ writeIORef dynFlagsRef dynFlags + +restoreDynFlags :: Ghc DynFlags +restoreDynFlags = do + storedDynFlags <- liftIO $ readIORef dynFlagsRef + currentDynFlags <- getSessionDynFlags + return (currentDynFlags `restoreDynFlagsFrom` storedDynFlags) + +-- | Copy over all fields of DynFlags that are affected by dynamic_flags +-- and package_flags (and only those) +-- +-- See detailed description above. +restoreDynFlagsFrom :: DynFlags -> DynFlags -> DynFlags +restoreDynFlagsFrom new old = new { + avx = avx old + , avx2 = avx2 old + , avx512cd = avx512cd old + , avx512er = avx512er old + , avx512f = avx512f old + , avx512pf = avx512pf old + , cmdlineFrameworks = cmdlineFrameworks old + , cmdlineHcIncludes = cmdlineHcIncludes old + , ctxtStkDepth = ctxtStkDepth old + , depExcludeMods = depExcludeMods old + , depIncludePkgDeps = depIncludePkgDeps old + , depMakefile = depMakefile old + , depSuffixes = depSuffixes old + , dllSplit = dllSplit old + , dllSplitFile = dllSplitFile old + , dumpDir = dumpDir old + , dumpFlags = dumpFlags old + , dumpPrefixForce = dumpPrefixForce old + , dylibInstallName = dylibInstallName old + , dynHiSuf = dynHiSuf old + , dynLibLoader = dynLibLoader old + , dynObjectSuf = dynObjectSuf old + , dynOutputFile = dynOutputFile old + , enableTimeStats = enableTimeStats old + , extensionFlags = extensionFlags old + , extensions = extensions old + , extraPkgConfs = extraPkgConfs old + , floatLamArgs = floatLamArgs old + , frameworkPaths = frameworkPaths old + , generalFlags = generalFlags old + , ghcHeapSize = ghcHeapSize old + , ghcLink = ghcLink old + , ghciHistSize = ghciHistSize old + , ghciScripts = ghciScripts old + , haddockOptions = haddockOptions old + , hcSuf = hcSuf old + , hiDir = hiDir old + , hiSuf = hiSuf old + , historySize = historySize old + , hpcDir = hpcDir old + , hscTarget = hscTarget old + , importPaths = importPaths old + , includePaths = includePaths old + , interactivePrint = interactivePrint old + , language = language old + , ldInputs = ldInputs old + , liberateCaseThreshold = liberateCaseThreshold old + , libraryPaths = libraryPaths old + , mainFunIs = mainFunIs old + , mainModIs = mainModIs old + , maxRelevantBinds = maxRelevantBinds old + , maxSimplIterations = maxSimplIterations old + , maxWorkerArgs = maxWorkerArgs old + , objectDir = objectDir old + , objectSuf = objectSuf old + , optLevel = optLevel old + , outputFile = outputFile old + , outputHi = outputHi old + , packageFlags = packageFlags old + , parMakeCount = parMakeCount old + , pkgDatabase = pkgDatabase old + , pkgTrustOnLoc = pkgTrustOnLoc old + , pluginModNameOpts = pluginModNameOpts old + , pluginModNames = pluginModNames old + , pprCols = pprCols old + , pprUserLength = pprUserLength old + , profAuto = profAuto old + , rtsOpts = rtsOpts old + , rtsOptsEnabled = rtsOptsEnabled old + , ruleCheck = ruleCheck old + , safeHaskell = safeHaskell old + , settings = settings old + , shouldDumpSimplPhase = shouldDumpSimplPhase old + , simplPhases = simplPhases old + , simplTickFactor = simplTickFactor old + , specConstrCount = specConstrCount old + , specConstrRecursive = specConstrRecursive old + , specConstrThreshold = specConstrThreshold old + , sseVersion = sseVersion old + , strictnessBefore = strictnessBefore old + , stubDir = stubDir old + , thisPackage = thisPackage old + , traceLevel = traceLevel old + , tyFunStkDepth = tyFunStkDepth old + , ufCreationThreshold = ufCreationThreshold old + , ufDictDiscount = ufDictDiscount old + , ufFunAppDiscount = ufFunAppDiscount old + , ufKeenessFactor = ufKeenessFactor old + , ufUseThreshold = ufUseThreshold old + , verbosity = verbosity old + , warningFlags = warningFlags old + , ways = ways old + } + +{------------------------------------------------------------------------------- + Package keys +-------------------------------------------------------------------------------} + +type PackageKey = GHC.PackageId +type PackageQualifier = Maybe FastString + +packageKeyString :: PackageKey -> String +packageKeyString = packageIdString + +stringToPackageKey :: String -> PackageKey +stringToPackageKey = stringToPackageId + +mainPackageKey :: PackageKey +mainPackageKey = mainPackageId + +lookupPackage :: DynFlags -> PackageKey -> PackageConfig +lookupPackage dflags pkey = + Maybe.fromMaybe + (error $ "lookupPackage: invalid key " ++ packageKeyString pkey) + (Packages.lookupPackage (Packages.pkgIdMap (pkgState dflags)) pkey) + +modulePackageKey :: Module -> PackageKey +modulePackageKey = modulePackageId + +-- | Translate a package key to a source ID (name and version) +-- +-- NOTE: The version of wired-in packages is completely wiped out, but we use a +-- leak in the form of a Cabal package id for the same package, which still +-- contains a version. See +-- +packageKeyToSourceId :: DynFlags -> PackageKey -> (String, String) +packageKeyToSourceId dflags p = + let pkgCfg = lookupPackage dflags p + srcId = Cabal.sourcePackageId pkgCfg + instId = installedToSourceId $ Cabal.installedPackageId pkgCfg + name = pkgName srcId + version = Cabal.pkgVersion srcId `orIfZero` Cabal.pkgVersion instId + in (name, showVersion (stripInPlace version)) + where + orIfZero :: Version -> Version -> Version + orIfZero v a = case v of Version [] [] -> a ; _otherwise -> v + + stripInPlace :: Version -> Version + stripInPlace (Version bs ts) = Version bs (filter (/= "inplace") ts) + +-- | Find an exposed module in an exposed package +findExposedModule :: DynFlags -> PackageQualifier -> ModuleName -> Maybe PackageKey +findExposedModule dflags pkgQual impMod = Maybe.listToMaybe pkgIds + where + pkgAll = Packages.lookupModuleInAllPackages dflags impMod + pkgExposed = map fst $ filter isExposed pkgAll + pkgMatching = filter (matchesQual pkgQual) pkgExposed + pkgIds = map Packages.packageConfigId pkgMatching + + matchesQual :: PackageQualifier -> PackageConfig -> Bool + matchesQual Nothing _ = True + matchesQual (Just fs) p = unpackFS fs == pkgName (Cabal.sourcePackageId p) + + isExposed :: (PackageConfig, Bool) -> Bool + isExposed (pkgCfg, moduleExposed) = Cabal.exposed pkgCfg && moduleExposed + +{------------------------------------------------------------------------------ + Traversing the AST +------------------------------------------------------------------------------} + +ifPostTc :: AstAlg m id -> a -> Maybe a +ifPostTc alg a = + case astPhase alg of + FoldPreTc -> Nothing + FoldPostTc -> Just a + +instance Fold id (HsGroup id) where + fold alg HsGroup { hs_valds + , hs_tyclds + , hs_instds + , hs_derivds + , hs_fixds + , hs_defds + , hs_fords + , hs_warnds + , hs_annds + , hs_ruleds + , hs_vects + , hs_docs } = astMark alg Nothing "HsGroup" $ do + fold alg hs_valds + fold alg hs_tyclds + fold alg hs_instds + fold alg hs_derivds + fold alg hs_fixds + fold alg hs_defds + fold alg hs_fords + fold alg hs_warnds + fold alg hs_annds + fold alg hs_ruleds + fold alg hs_vects + fold alg hs_docs + +instance Fold id (HsValBinds id) where + fold _alg (ValBindsIn {}) = + fail "fold alg: Unexpected ValBindsIn" + fold alg (ValBindsOut binds sigs) = astMark alg Nothing "ValBindsOut" $ do + fold alg (map snd binds) + -- ValBindsOut specifically stores Names, independent of the phase. + -- Traverse only in the right mode (types force this) + case astPhase alg of + FoldPreTc -> fold alg sigs + FoldPostTc -> return Nothing + +instance Fold id (LSig id) where + fold alg (L span (TypeSig names tp)) = astMark alg (Just span) "TypeSig" $ do + forM_ names $ astId alg SigSite + fold alg tp + fold alg (L span (PatSynSig name + _{-TODO?: (HsPatSynDetails (LHsType name))-} + tp + _{-TODO?: (LHsContext name)-} + _{-TODO?: (LHsContext name)-}) + ) = astMark alg (Just span) "PatSynSig" $ do + astId alg SigSite name + fold alg tp + fold alg (L span (GenericSig names tp)) = astMark alg (Just span) "GenericSig" $ do + forM_ names $ astId alg SigSite + fold alg tp + + -- Only in generated code + fold alg (L span (IdSig _)) = astMark alg (Just span) "IdSig" $ + return Nothing + + -- Annotations + fold alg (L span (FixSig _)) = astMark alg (Just span) "FixSig" $ + return Nothing + fold alg (L span (InlineSig _ _)) = astMark alg (Just span) "InlineSig" $ + return Nothing + fold alg (L span (SpecSig _ _ _)) = astMark alg (Just span) "SpecSig" $ + return Nothing + fold alg (L span (SpecInstSig _)) = astMark alg (Just span) "SpecInstSig" $ + return Nothing + fold alg (L span (MinimalSig _)) = astMark alg (Just span) "MinimalSig" $ + return Nothing + +instance Fold id (LHsType id) where + fold alg (L span (HsFunTy arg res)) = astMark alg (Just span) "HsFunTy" $ + fold alg [arg, res] + fold alg (L span (HsTyVar name)) = astMark alg (Just span) "HsTyVar" $ + astId alg UseSite (L span name) + fold alg (L span (HsForAllTy explicitFlag tyVars ctxt body)) = astMark alg (Just span) "hsForAllTy" $ do + case explicitFlag of + Explicit -> fold alg tyVars + Implicit -> return Nothing + fold alg ctxt + fold alg body + fold alg (L span (HsAppTy fun arg)) = astMark alg (Just span) "HsAppTy" $ + fold alg [fun, arg] + fold alg (L span (HsTupleTy _tupleSort typs)) = astMark alg (Just span) "HsTupleTy" $ + -- tupleSort is unboxed/boxed/etc. + fold alg typs + fold alg (L span (HsListTy typ)) = astMark alg (Just span) "HsListTy" $ + fold alg typ + fold alg (L span (HsPArrTy typ)) = astMark alg (Just span) "HsPArrTy" $ + fold alg typ + fold alg (L span (HsParTy typ)) = astMark alg (Just span) "HsParTy" $ + fold alg typ + fold alg (L span (HsEqTy a b)) = astMark alg (Just span) "HsEqTy" $ + fold alg [a, b] + fold alg (L span (HsDocTy typ _doc)) = astMark alg (Just span) "HsDocTy" $ + -- I don't think HsDocTy actually makes it through the renamer + fold alg typ + fold alg (L span (HsWrapTy _wrapper _typ)) = astMark alg (Just span) "HsWrapTy" $ + -- This is returned only by the type checker, and _typ is not located + return Nothing + fold alg (L span (HsRecTy fields)) = astMark alg (Just span) "HsRecTy" $ + fold alg fields + fold alg (L span (HsKindSig typ kind)) = astMark alg (Just span) "HsKindSig" $ + fold alg [typ, kind] + fold alg (L span (HsBangTy _bang typ)) = astMark alg (Just span) "HsBangTy" $ + fold alg typ + fold alg (L span (HsOpTy left (_wrapper, op) right)) = astMark alg (Just span) "HsOpTy" $ do + fold alg [left, right] + astId alg UseSite op + fold alg (L span (HsIParamTy _var typ)) = astMark alg (Just span) "HsIParamTy" $ + -- _var is not located + fold alg typ + fold alg (L span (HsSpliceTy splice _postTcKind)) = astMark alg (Just span) "HsSpliceTy" $ + fold alg splice + fold alg (L span (HsCoreTy _)) = astMark alg (Just span) "HsCoreTy" $ + -- Not important: doesn't arise until later in the compiler pipeline + return Nothing + fold alg (L span (HsQuasiQuoteTy qquote)) = astMark alg (Just span) "HsQuasiQuoteTy" $ + fold alg (L span qquote) -- reuse location info + fold alg (L span (HsExplicitListTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitListTy" $ + fold alg typs + fold alg (L span (HsExplicitTupleTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitTupleTy" $ + fold alg typs + fold alg (L span (HsTyLit _hsTyLit)) = astMark alg (Just span) "HsTyLit" $ + return Nothing + +instance Fold id (HsSplice id) where + fold alg (HsSplice _id expr) = astMark alg Nothing "HsSplice" $ do + fold alg expr + +instance Fold id (Located (HsQuasiQuote id)) where + fold alg (L span (HsQuasiQuote _id _srcSpan _enclosed)) = astMark alg (Just span) "HsQuasiQuote" $ + -- Unfortunately, no location information is stored within HsQuasiQuote at all + return Nothing + +instance Fold id (LHsTyVarBndr id) where + fold alg (L span (UserTyVar name)) = astMark alg (Just span) "UserTyVar" $ do + astId alg DefSite (L span name) + fold alg (L span (KindedTyVar name kind)) = astMark alg (Just span) "KindedTyVar" $ do + astId alg DefSite (L span name) + fold alg kind + +instance Fold id (LHsContext id) where + fold alg (L span typs) = astMark alg (Just span) "LHsContext" $ + fold alg typs + +instance Fold id (LHsBinds id) where + fold alg = fold alg . bagToList + +instance Fold id (LHsBind id) where + fold alg (L span bind@(FunBind {})) = astMark alg (Just span) "FunBind" $ do + astId alg DefSite (fun_id bind) + fold alg (fun_matches bind) + fold alg (L span bind@(PatBind {})) = astMark alg (Just span) "PatBind" $ do + fold alg (pat_lhs bind) + fold alg (pat_rhs bind) + fold alg (L span _bind@(VarBind {})) = astMark alg (Just span) "VarBind" $ + -- These are only introduced by the type checker, and don't involve user + -- written code. The ghc comments says "located 'only for consistency'" + return Nothing + fold alg (L span bind@(AbsBinds {})) = astMark alg (Just span) "AbsBinds" $ do + forM_ (abs_exports bind) $ \abs_export -> + astId alg DefSite (L typecheckOnly (abe_poly abs_export)) + fold alg (abs_binds bind) + fold alg (L span bind@(PatSynBind {})) = astMark alg (Just span) + "PatSynBind" $ do + astId alg DefSite (patsyn_id bind) + fold alg (patsyn_def bind) + -- TODO?: patsyn_args :: HsPatSynDetails (Located idR) + -- patsyn_dir :: HsPatSynDir idR + +typecheckOnly :: SrcSpan +typecheckOnly = mkGeneralSrcSpan (fsLit "") + +instance Fold id body => Fold id (MatchGroup id body) where + -- We ignore the postTcType, as it doesn't have location information + -- TODO: _mg_origin distinguishes between FromSource and Generated. + -- May be useful to take that into account? (Here and elsewhere) + fold alg (MG mg_alts _mg_arg_tys _mg_res_ty _mg_origin) = astMark alg Nothing "MG" $ + fold alg mg_alts + +instance Fold id body => Fold id (LMatch id body) where + fold alg (L span (Match pats _type rhss)) = astMark alg (Just span) "Match" $ do + fold alg pats + fold alg rhss + +instance Fold id body => Fold id (GRHSs id body) where + fold alg (GRHSs rhss binds) = astMark alg Nothing "GRHSs" $ do + fold alg rhss + fold alg binds + +instance Fold id body => Fold id (LGRHS id body) where + fold alg (L span (GRHS _guards rhs)) = astMark alg (Just span) "GRHS" $ + fold alg rhs + +instance Fold id (HsLocalBinds id) where + fold _alg EmptyLocalBinds = + return Nothing + fold _alg (HsValBinds (ValBindsIn _ _)) = + fail "fold alg: Unexpected ValBindsIn (after renamer these should not exist)" + fold alg (HsValBinds binds) = astMark alg Nothing "HsValBinds" $ do + fold alg binds + fold alg (HsIPBinds binds) = + fold alg binds + +instance Fold id (HsIPBinds id) where + fold alg (IPBinds binds _evidence) = + fold alg binds + +instance Fold id (LIPBind id) where + fold alg (L span (IPBind _name expr)) = astMark alg (Just span) "IPBind" $ do + -- Name is not located :( + fold alg expr + +instance Fold id (LHsExpr id) where + fold alg (L span (HsPar expr)) = astMark alg (Just span) "HsPar" $ + fold alg expr + fold alg (L span (ExprWithTySig expr _type)) = astMark alg (Just span) "ExprWithTySig" $ + fold alg expr + fold alg (L span (ExprWithTySigOut expr _type)) = astMark alg (Just span) "ExprWithTySigOut" $ + fold alg expr + fold alg (L span (HsOverLit (OverLit{ol_type}))) = astMark alg (Just span) "HsOverLit" $ do + astExpType alg span (ifPostTc alg ol_type) + fold alg (L span (OpApp left op _fix right)) = astMark alg (Just span) "OpApp" $ do + _leftTy <- fold alg left + opTy <- fold alg op + _rightTy <- fold alg right + astExpType alg span (funRes2 <$> opTy) + fold alg (L span (HsVar id)) = astMark alg (Just span) "HsVar" $ do + astId alg UseSite (L span id) + fold alg (L span (HsWrap wrapper expr)) = astMark alg (Just span) "HsWrap" $ do + ty <- fold alg (L span expr) + astExpType alg span (applyWrapper wrapper <$> ty) + fold alg (L span (HsLet binds expr)) = astMark alg (Just span) "HsLet" $ do + fold alg binds + ty <- fold alg expr + astExpType alg span ty -- Re-astId alg this with the span of the whole let + fold alg (L span (HsApp fun arg)) = astMark alg (Just span) "HsApp" $ do + funTy <- fold alg fun + _argTy <- fold alg arg + astExpType alg span (funRes1 <$> funTy) + fold alg (L span (HsLit lit)) = + -- Intentional omission of the "astMark alg" debugging call here. + -- The syntax "assert" is replaced by GHC by "assertError ", where + -- both "assertError" and the "" are assigned the source span of + -- the original "assert". This means that the (represented as an + -- HsLit) might override "assertError" in the IdMap. + astExpType alg span (ifPostTc alg (hsLitType lit)) + fold alg (L span (HsLam matches@(MG _ mg_arg_tys mg_res_ty _ms_origin))) = astMark alg (Just span) "HsLam" $ do + fold alg matches + let lamTy = do arg_tys <- sequence $ map (ifPostTc alg) mg_arg_tys + res_ty <- ifPostTc alg mg_res_ty + return (mkFunTys arg_tys res_ty) + astExpType alg span lamTy + fold alg (L span (HsDo _ctxt stmts postTcType)) = astMark alg (Just span) "HsDo" $ do + -- ctxt indicates what kind of statement it is; AFAICT there is no + -- useful information in it for us + fold alg stmts + astExpType alg span (ifPostTc alg postTcType) + fold alg (L span (ExplicitList postTcType _mSyntaxExpr exprs)) = astMark alg (Just span) "ExplicitList" $ do + fold alg exprs + astExpType alg span (mkListTy <$> ifPostTc alg postTcType) + fold alg (L span (RecordCon con postTcExpr recordBinds)) = astMark alg (Just span) "RecordCon" $ do + fold alg recordBinds + -- Only traverse the postTcExpr in the right phase (types force us! yay! :) + case astPhase alg of + FoldPreTc -> do + astId alg UseSite con + return Nothing + FoldPostTc -> do + conTy <- fold alg (L (getLoc con) postTcExpr) + astExpType alg span (funResN <$> conTy) + fold alg (L span (HsCase expr matches@(MG _ _mg_arg_tys mg_res_ty _mg_origin))) = astMark alg (Just span) "HsCase" $ do + fold alg expr + fold alg matches + astExpType alg span (ifPostTc alg mg_res_ty) + fold alg (L span (ExplicitTuple args boxity)) = astMark alg (Just span) "ExplicitTuple" $ do + argTys <- mapM (fold alg) args + astExpType alg span (mkTupleTy (boxityNormalTupleSort boxity) <$> sequence argTys) + fold alg (L span (HsIf _rebind cond true false)) = astMark alg (Just span) "HsIf" $ do + _condTy <- fold alg cond + _trueTy <- fold alg true + falseTy <- fold alg false + astExpType alg span falseTy + fold alg (L span (SectionL arg op)) = astMark alg (Just span) "SectionL" $ do + _argTy <- fold alg arg + opTy <- fold alg op + astExpType alg span (mkSectionLTy <$> opTy) + where + mkSectionLTy ty = let (_arg1, arg2, res) = splitFunTy2 ty + in mkFunTy arg2 res + fold alg (L span (SectionR op arg)) = astMark alg (Just span) "SectionR" $ do + opTy <- fold alg op + _argTy <- fold alg arg + astExpType alg span (mkSectionRTy <$> opTy) + where + mkSectionRTy ty = let (arg1, _arg2, res) = splitFunTy2 ty + in mkFunTy arg1 res + fold alg (L span (HsIPVar _name)) = astMark alg (Just span) "HsIPVar" $ + -- _name is not located :( + return Nothing + fold alg (L span (NegApp expr _rebind)) = astMark alg (Just span) "NegApp" $ do + ty <- fold alg expr + astExpType alg span ty + fold alg (L span (HsBracket th)) = astMark alg (Just span) "HsBracket" $ + fold alg th + fold alg (L span (HsRnBracketOut th pendingSplices)) = astMark alg (Just span) "HsRnBracketOut" $ do + -- HsRnBracketOut is used pre type checking (contains Names only) + case astPhase alg of + FoldPreTc -> do fold alg pendingSplices + fold alg th + return Nothing + FoldPostTc -> return Nothing + fold alg (L span (HsTcBracketOut _th pendingSplices)) = astMark alg (Just span) "HsTcBracketOut" $ do + -- Given something like + -- + -- > \x xs -> [| x : xs |] + -- + -- @pendingSplices@ contains + -- + -- > [ "x", "Language.Haskell.TH.Syntax.lift x" + -- > , "xs", "Language.Haskell.TH.Syntax.lift xs" + -- > ] + -- + -- Sadly, however, ghc attaches to these splices. + -- Moreover, we don't get any type information about the whole bracket + -- expression either :( + case astPhase alg of + FoldPreTc -> return Nothing -- already traversed in HsRnBracketOut + FoldPostTc -> do forM_ pendingSplices $ \(_name, splice) -> + fold alg splice + return Nothing + fold alg (L span (RecordUpd expr binds _dataCons _postTcTypeInp _postTcTypeOutp)) = astMark alg (Just span) "RecordUpd" $ do + recordTy <- fold alg expr + fold alg binds + astExpType alg span recordTy -- The type doesn't change + fold alg (L span (HsProc pat body)) = astMark alg (Just span) "HsProc" $ do + fold alg pat + fold alg body + fold alg (L span (HsArrApp arr inp _postTcType _arrType _orient)) = astMark alg (Just span) "HsArrApp" $ do + fold alg [arr, inp] + fold alg (L span (HsArrForm expr _fixity cmds)) = astMark alg (Just span) "HsArrForm" $ do + fold alg expr + fold alg cmds + fold alg (L span (HsTick _tickish expr)) = astMark alg (Just span) "HsTick" $ do + fold alg expr + fold alg (L span (HsBinTick _trueTick _falseTick expr)) = astMark alg (Just span) "HsBinTick" $ do + fold alg expr + fold alg (L span (HsTickPragma _span expr)) = astMark alg (Just span) "HsTickPragma" $ do + fold alg expr + fold alg (L span (HsSCC _string expr)) = astMark alg (Just span) "HsSCC" $ do + fold alg expr + fold alg (L span (HsCoreAnn _string expr)) = astMark alg (Just span) "HsCoreAnn" $ do + fold alg expr + fold alg (L span (HsSpliceE _isTyped splice)) = astMark alg (Just span) "HsSpliceE" $ do + fold alg splice + fold alg (L span (HsQuasiQuoteE qquote)) = astMark alg (Just span) "HsQuasiQuoteE" $ do + fold alg (L span qquote) -- reuse span + fold alg (L span (ExplicitPArr _postTcType exprs)) = astMark alg (Just span) "ExplicitPArr" $ do + fold alg exprs + fold alg (L span (PArrSeq _postTcType seqInfo)) = astMark alg (Just span) "PArrSeq" $ do + fold alg seqInfo + + -- According to the comments in HsExpr.lhs, + -- "These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing." + fold alg (L span EWildPat) = astMark alg (Just span) "EWildPat" $ + return Nothing + fold alg (L span (EAsPat _ _)) = astMark alg (Just span) "EAsPat" $ + return Nothing + fold alg (L span (EViewPat _ _)) = astMark alg (Just span) "EViewPat" $ + return Nothing + fold alg (L span (ELazyPat _)) = astMark alg (Just span) "ELazyPat" $ + return Nothing + fold alg (L span (HsType _ )) = astMark alg (Just span) "HsType" $ + return Nothing + fold alg (L span (ArithSeq postTcExpr _mSyntaxExpr seqInfo)) = astMark alg (Just span) "ArithSeq" $ do + fold alg seqInfo + case astPhase alg of + FoldPreTc -> return Nothing + FoldPostTc -> fold alg (L span postTcExpr) + + -- New expressions + fold _ (L _ (HsLamCase _ _)) = + return Nothing -- FIXME + fold _ (L _ (HsMultiIf _ _)) = + return Nothing -- FIXME + + -- Unbound variables are errors? + fold _alg (L _span (HsUnboundVar _rdrName)) = + return Nothing + +instance Fold id (ArithSeqInfo id) where + fold alg (From expr) = astMark alg Nothing "From" $ + fold alg expr + fold alg (FromThen frm thn) = astMark alg Nothing "FromThen" $ + fold alg [frm, thn] + fold alg (FromTo frm to) = astMark alg Nothing "FromTo" $ + fold alg [frm, to] + fold alg (FromThenTo frm thn to) = astMark alg Nothing "FromThenTo" $ + fold alg [frm, thn, to] + +instance Fold id (LHsCmdTop id) where + fold alg (L span (HsCmdTop cmd _postTcTypeInp _postTcTypeRet _syntaxTable)) = astMark alg (Just span) "HsCmdTop" $ + fold alg cmd + +instance Fold id (HsBracket id) where + fold alg (ExpBr expr) = astMark alg Nothing "ExpBr" $ + fold alg expr + fold alg (PatBr pat) = astMark alg Nothing "PatBr" $ + fold alg pat + fold alg (DecBrG group) = astMark alg Nothing "DecBrG" $ + fold alg group + fold alg (TypBr typ) = astMark alg Nothing "TypBr" $ + fold alg typ + fold alg (VarBr _namespace _id) = astMark alg Nothing "VarBr" $ + -- No location information, sadly + return Nothing + fold alg (DecBrL decls) = astMark alg Nothing "DecBrL" $ + fold alg decls + fold alg (TExpBr expr) = astMark alg Nothing "TExpBr" $ + fold alg expr + +instance Fold Name PendingRnSplice where + fold alg (PendingRnExpSplice splice) = astMark alg Nothing "PendingRnExpSplice" $ + fold alg splice + fold alg (PendingRnPatSplice splice) = astMark alg Nothing "PendingRnPatSplice" $ + fold alg splice + fold alg (PendingRnTypeSplice splice) = astMark alg Nothing "PendingRnTypeSplice" $ + fold alg splice + fold alg (PendingRnDeclSplice splice) = astMark alg Nothing "PendingRnDeclSplice" $ + fold alg splice + fold alg (PendingRnCrossStageSplice _) = astMark alg Nothing "PendingRnCrossStageSplice" $ + -- No location info + return Nothing + +instance Fold id (HsTupArg id) where + fold alg (Present arg) = + fold alg arg + fold _alg (Missing _postTcType) = + return Nothing + +instance Fold id a => Fold id (HsRecFields id a) where + fold alg (HsRecFields rec_flds _rec_dotdot) = astMark alg Nothing "HsRecFields" $ + fold alg rec_flds + +instance Fold id a => Fold id (HsRecField id a) where + fold alg (HsRecField id arg _pun) = astMark alg Nothing "HsRecField" $ do + astId alg UseSite id + fold alg arg + +-- The meaning of the constructors of LStmt isn't so obvious; see various +-- notes in ghc/compiler/hsSyn/HsExpr.lhs +instance Fold id body => Fold id (LStmt id body) where + fold alg (L span (LastStmt body _syntaxExpr)) = astMark alg (Just span) "LastStmt" $ do + fold alg body + fold alg (L span (BindStmt pat expr _bind _fail)) = astMark alg (Just span) "BindStmt" $ do + -- Neither _bind or _fail are located + fold alg pat + fold alg expr + fold alg (L span (BodyStmt body _seq _guard _postTcType)) = astMark alg (Just span) "BodyStmt" $ do + -- TODO: should we do something with _postTcType? + -- (Comment in HsExpr.lhs says it's for arrows) + fold alg body + fold alg (L span (LetStmt binds)) = astMark alg (Just span) "LetStmt" $ + fold alg binds + fold alg (L span stmt@(RecStmt {})) = astMark alg (Just span) "RecStmt" $ do + fold alg (recS_stmts stmt) + + fold alg (L span (TransStmt {})) = astUnsupported alg (Just span) "TransStmt" + fold alg (L span (ParStmt _ _ _)) = astUnsupported alg (Just span) "ParStmt" + +instance Fold id (LPat id) where + fold alg (L span (WildPat postTcType)) = astMark alg (Just span) "WildPat" $ + astExpType alg span (ifPostTc alg postTcType) + fold alg (L span (VarPat id)) = astMark alg (Just span) "VarPat" $ + astId alg DefSite (L span id) + fold alg (L span (LazyPat pat)) = astMark alg (Just span) "LazyPat" $ + fold alg pat + fold alg (L span (AsPat id pat)) = astMark alg (Just span) "AsPat" $ do + astId alg DefSite id + fold alg pat + fold alg (L span (ParPat pat)) = astMark alg (Just span) "ParPat" $ + fold alg pat + fold alg (L span (BangPat pat)) = astMark alg (Just span) "BangPat" $ + fold alg pat + fold alg (L span (ListPat pats _postTcType _mSyntaxExpr)) = astMark alg (Just span) "ListPat" $ + fold alg pats + fold alg (L span (TuplePat pats _boxity _postTcType)) = astMark alg (Just span) "TuplePat" $ + fold alg pats + fold alg (L span (PArrPat pats _postTcType)) = astMark alg (Just span) "PArrPat" $ + fold alg pats + fold alg (L span (ConPatIn con details)) = astMark alg (Just span) "ConPatIn" $ do + -- Unlike ValBindsIn and HsValBindsIn, we *do* get ConPatIn + astId alg UseSite con -- the constructor name is non-binding + fold alg details + fold alg (L span (ConPatOut {pat_con, pat_args})) = astMark alg (Just span) "ConPatOut" $ do + () <- case astPhase alg of + FoldPreTc -> do astId alg UseSite (L (getLoc pat_con) (getName (unLoc pat_con))) + return () + FoldPostTc -> return () + fold alg pat_args + fold alg (L span (LitPat _)) = astMark alg (Just span) "LitPat" $ + return Nothing + fold alg (L span (NPat _ _ _)) = astMark alg (Just span) "NPat" $ + return Nothing + fold alg (L span (NPlusKPat id _lit _rebind1 _rebind2)) = astMark alg (Just span) "NPlusKPat" $ do + astId alg DefSite id + fold alg (L span (ViewPat expr pat _postTcType)) = astMark alg (Just span) "ViewPat" $ do + fold alg expr + fold alg pat + fold alg (L span (SigPatIn pat typ)) = astMark alg (Just span) "SigPatIn" $ do + fold alg pat + fold alg typ + fold alg (L span (SigPatOut pat _typ)) = astMark alg (Just span) "SigPatOut" $ do + -- _typ is not located + fold alg pat + fold alg (L span (QuasiQuotePat qquote)) = astMark alg (Just span) "QuasiQuotePat" $ + fold alg (L span qquote) -- reuse span + fold alg (L span (SplicePat splice)) = astMark alg (Just span) "SplicePat" $ + fold alg splice + + -- During translation only + fold alg (L span (CoPat _ _ _)) = astMark alg (Just span) "CoPat" $ + return Nothing + +instance (Fold id arg, Fold id rec) => Fold id (HsConDetails arg rec) where + fold alg (PrefixCon args) = astMark alg Nothing "PrefixCon" $ + fold alg args + fold alg (RecCon rec) = astMark alg Nothing "RecCon" $ + fold alg rec + fold alg (InfixCon a b) = astMark alg Nothing "InfixCon" $ + fold alg [a, b] + +instance Fold id (LTyClDecl id) where + fold alg (L span _decl@(ForeignType {})) = astUnsupported alg (Just span) "ForeignType" + fold alg (L span (FamDecl tcdFam)) = astMark alg (Just span) "FamDecl" $ do + fold alg (L span tcdFam) + fold alg (L span (SynDecl tcdLName + tcdTyVars + tcdRhs + _tcdFVs)) = astMark alg (Just span) "SynDecl" $ do + astId alg DefSite tcdLName + fold alg tcdTyVars + fold alg tcdRhs + fold alg (L span (DataDecl tcdLName + tcdTyVars + tcdDataDefn + _tcdFVs)) = astMark alg (Just span) "DataDecl" $ do + astId alg DefSite tcdLName + fold alg tcdTyVars + fold alg tcdDataDefn + fold alg (L span decl@(ClassDecl {})) = astMark alg (Just span) "ClassDecl" $ do + fold alg (tcdCtxt decl) + astId alg DefSite (tcdLName decl) + fold alg (tcdTyVars decl) + -- Sadly, we don't get location info for the functional dependencies + fold alg (tcdSigs decl) + fold alg (tcdMeths decl) + fold alg (tcdATs decl) + fold alg (tcdATDefs decl) + fold alg (tcdDocs decl) + +instance Fold id (LConDecl id) where + fold alg (L span decl@(ConDecl {})) = astMark alg (Just span) "ConDecl" $ do + astId alg DefSite (con_name decl) + fold alg (con_qvars decl) + fold alg (con_cxt decl) + fold alg (con_details decl) + fold alg (con_res decl) + +instance Fold id ty => Fold id (ResType ty) where + fold alg ResTyH98 = astMark alg Nothing "ResTyH98" $ do + return Nothing -- Nothing to do + fold alg (ResTyGADT ty) = astMark alg Nothing "ResTyGADT" $ do + fold alg ty + +instance Fold id (ConDeclField id) where + fold alg (ConDeclField name typ _doc) = do + astId alg DefSite name + fold alg typ + +instance Fold id (LInstDecl id) where + fold alg (L span (ClsInstD cid_inst)) = astMark alg (Just span) "ClsInstD" $ + fold alg cid_inst + fold alg (L span (DataFamInstD dfid_inst)) = astMark alg (Just span) "DataFamInstD" $ + fold alg dfid_inst + fold alg (L span (TyFamInstD tfid_inst)) = astMark alg (Just span) "TyFamInstD" $ + fold alg tfid_inst + +instance Fold id (LDerivDecl id) where + fold alg (L span (DerivDecl deriv_type)) = astMark alg (Just span) "LDerivDecl" $ do + fold alg deriv_type + +instance Fold id (LFixitySig id) where + fold alg (L span (FixitySig name _fixity)) = astMark alg (Just span) "LFixitySig" $ do + astId alg SigSite name + +instance Fold id (LDefaultDecl id) where + fold alg (L span (DefaultDecl typs)) = astMark alg (Just span) "LDefaultDecl" $ do + fold alg typs + +instance Fold id (LForeignDecl id) where + fold alg (L span (ForeignImport name sig _coercion _import)) = astMark alg (Just span) "ForeignImport" $ do + astId alg DefSite name + fold alg sig + fold alg (L span (ForeignExport name sig _coercion _export)) = astMark alg (Just span) "ForeignExport" $ do + astId alg UseSite name + fold alg sig + +instance Fold id (LWarnDecl id) where + fold alg (L span (Warning name _txt)) = astMark alg (Just span) "Warning" $ do + -- We use the span of the entire warning because we don't get location info for name + astId alg UseSite (L span name) + +instance Fold id (LAnnDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LAnnDecl" + +instance Fold id (LRuleDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LRuleDecl" + +instance Fold id (LVectDecl id) where + fold alg (L span _) = astUnsupported alg (Just span) "LVectDecl" + +instance Fold id LDocDecl where + fold alg (L span _) = astMark alg (Just span) "LDocDec" $ + -- Nothing to do + return Nothing + +instance Fold id (Located (SpliceDecl id)) where + fold alg (L span (SpliceDecl splice _explicit)) = astMark alg (Just span) "SpliceDecl" $ do + fold alg (unLoc splice) + +-- LHsDecl is a wrapper around the various kinds of declarations; the wrapped +-- declarations don't have location information of themselves, so we reuse +-- the location info of the wrapper +instance Fold id (LHsDecl id) where + fold alg (L span (TyClD tyClD)) = astMark alg (Just span) "TyClD" $ + fold alg (L span tyClD) + fold alg (L span (InstD instD)) = astMark alg (Just span) "InstD" $ + fold alg (L span instD) + fold alg (L span (DerivD derivD)) = astMark alg (Just span) "DerivD" $ + fold alg (L span derivD) + fold alg (L span (ValD valD)) = astMark alg (Just span) "ValD" $ + fold alg (L span valD) + fold alg (L span (SigD sigD)) = astMark alg (Just span) "SigD" $ + fold alg (L span sigD) + fold alg (L span (DefD defD)) = astMark alg (Just span) "DefD" $ + fold alg (L span defD) + fold alg (L span (ForD forD)) = astMark alg (Just span) "ForD" $ + fold alg (L span forD) + fold alg (L span (WarningD warningD)) = astMark alg (Just span) "WarningD" $ + fold alg (L span warningD) + fold alg (L span (AnnD annD)) = astMark alg (Just span) "AnnD" $ + fold alg (L span annD) + fold alg (L span (RuleD ruleD)) = astMark alg (Just span) "RuleD" $ + fold alg (L span ruleD) + fold alg (L span (VectD vectD)) = astMark alg (Just span) "VectD" $ + fold alg (L span vectD) + fold alg (L span (SpliceD spliceD)) = astMark alg (Just span) "SpliceD" $ + fold alg (L span spliceD) + fold alg (L span (DocD docD)) = astMark alg (Just span) "DocD" $ + fold alg (L span docD) + fold alg (L span (QuasiQuoteD quasiQuoteD)) = astMark alg (Just span) "QuasiQuoteD" $ + fold alg (L span quasiQuoteD) + fold alg (L span (RoleAnnotD _roleAnnotDecl)) = astMark alg (Just span) "RoleAnnotD" $ + -- TODO: Do something with roleAnnotDecl + return Nothing + +instance Fold id (TyClGroup id) where + fold alg (TyClGroup decls _roles) = astMark alg Nothing "TyClGroup" $ + -- TODO: deal with roles + fold alg decls + +instance Fold id (LHsTyVarBndrs id) where + fold alg (HsQTvs _hsq_kvs hsq_tvs) = astMark alg Nothing "HsQTvs" $ do + -- TODO: sadly, we get no location information about the kind variables + fold alg hsq_tvs + +instance Fold id (LHsCmd id) where + -- TODO: support arrows + fold _ _ = return Nothing + +instance Fold id thing => Fold id (HsWithBndrs thing) where + fold alg (HsWB hswb_cts _hswb_kvs _hswb_tvs) = astMark alg Nothing "HsWB" $ do + -- TODO: sadly, we get no location information about the variables + fold alg hswb_cts + +instance Fold id (LFamilyDecl id) where + fold alg (L span (FamilyDecl fdInfo fdLName fdTyVars fdKindSig)) = astMark alg (Just span) "FamilyDecl" $ do + fold alg fdInfo + astId alg DefSite fdLName + fold alg fdTyVars + fold alg fdKindSig + +instance Fold id (FamilyInfo id) where + fold alg DataFamily = astMark alg Nothing "DataFamily" $ + return Nothing + fold alg OpenTypeFamily = astMark alg Nothing "OpenTypeFamily" $ + return Nothing + fold alg (ClosedTypeFamily instDecls) = astMark alg Nothing "ClosedTypeFamily" $ + fold alg instDecls + +instance Fold id (LTyFamInstDecl id) where + fold alg (L span (TyFamInstDecl tfid_eqn _tfid_fvs)) = astMark alg (Just span) "TyFamInstDecl" $ do + -- TODO: sadly, tfid_fvs is unlocated + fold alg tfid_eqn + +instance Fold id (ClsInstDecl id) where + fold alg (ClsInstDecl cid_poly_ty + cid_binds + cid_sigs + cid_tyfam_insts + cid_datafam_insts) = astMark alg Nothing "ClsInstDecl" $ do + fold alg cid_poly_ty + fold alg cid_binds + fold alg cid_sigs + fold alg cid_tyfam_insts + fold alg cid_datafam_insts + +instance Fold id (DataFamInstDecl id) where + fold alg (DataFamInstDecl dfid_tycon + dfid_pats + dfid_defn + _dfid_fvs) = astMark alg Nothing "DataFamInstDecl" $ do + -- TODO: _dfid_fvs is unlocated + astId alg UseSite dfid_tycon + fold alg dfid_pats + fold alg dfid_defn + +instance Fold id (TyFamInstDecl id) where + fold alg (TyFamInstDecl tfid_eqn _tfid_fvs) = astMark alg Nothing "TyFamInstDecl" $ do + -- TODO: tfid_fvs is not located + fold alg tfid_eqn + +instance Fold id (LTyFamInstEqn id) where + fold alg (L span (TyFamInstEqn tfie_tycon + tfie_pats + tfie_rhs)) = astMark alg (Just span) "TyFamInstEqn" $ do + astId alg UseSite tfie_tycon + fold alg tfie_pats + fold alg tfie_rhs + +instance Fold id (LDataFamInstDecl id) where + fold alg (L span (DataFamInstDecl dfid_tycon + dfid_pats + dfid_defn + _dfid_fvs)) = astMark alg (Just span) "DataFamInstDecl" $ do + -- TODO: dfid_fvs is not located + astId alg UseSite dfid_tycon + fold alg dfid_pats + fold alg dfid_defn + +instance Fold id (HsDataDefn id) where + fold alg (HsDataDefn _dd_ND + dd_ctxt + _dd_cType + dd_kindSig + dd_cons + dd_derivs) = astMark alg Nothing "HsDataDefn" $ do + fold alg dd_ctxt + fold alg dd_kindSig + fold alg dd_cons + fold alg dd_derivs + +{------------------------------------------------------------------------------ + Operations on types +------------------------------------------------------------------------------} + +applyWrapper :: HsWrapper -> Type -> Type +applyWrapper WpHole t = t -- identity +applyWrapper (WpTyApp t') t = applyTy t t' +applyWrapper (WpEvApp _) t = funRes1 t +applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t +applyWrapper (WpCast coercion) _ = let Pair _ t = tcCoercionKind coercion in t +applyWrapper (WpTyLam v) t = mkForAllTy v t +applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t +applyWrapper (WpLet _) t = t -- we don't care about evidence _terms_ + +-- | Given @a -> b@, return @b@ +funRes1 :: Type -> Type +funRes1 = snd . splitFunTy + +-- | Given @a1 -> a2 -> b@, return @b@ +funRes2 :: Type -> Type +funRes2 = funRes1 . funRes1 + +-- | Given @a1 -> a2 -> ... -> b@, return @b@ +funResN :: Type -> Type +funResN = snd . splitFunTys + +-- | Given @a -> b -> c@, return @(a, b, c)@ +splitFunTy2 :: Type -> (Type, Type, Type) +splitFunTy2 ty0 = let (arg1, ty1) = splitFunTy ty0 + (arg2, ty2) = splitFunTy ty1 + in (arg1, arg2, ty2) + +typeOfTyThing :: TyThing -> Maybe Type +typeOfTyThing (AConLike (RealDataCon dataCon)) = Just $ dataConRepType dataCon +typeOfTyThing _ = Nothing -- we probably don't want psOrigResTy from PatSynCon + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Parse an installed package ID as if it was a source package ID +-- +-- NOTE: This no longer works for ghc 7.10 and up. +installedToSourceId :: Cabal.InstalledPackageId -> Cabal.PackageId +installedToSourceId (Cabal.InstalledPackageId instId) = parseSourceId instId + +-- | Parse a source package ID +-- +-- Returns an empty package ID if the parse failed. +parseSourceId :: String -> Cabal.PackageId +parseSourceId = emptyOnParseFailure + . Maybe.mapMaybe successfulParse + . Cabal.readP_to_S Cabal.parse + where + successfulParse :: (a, String) -> Maybe a + successfulParse (a, unparsed) = if null unparsed then Just a else Nothing + + emptyOnParseFailure :: [Cabal.PackageId] -> Cabal.PackageId + emptyOnParseFailure (i:_) = i + emptyOnParseFailure [] = Cabal.PackageIdentifier { + pkgName = Cabal.PackageName "" + , pkgVersion = Version [] [] + } + +-- | Extract a version from an installed package ID +pkgName :: Cabal.PackageIdentifier -> String +pkgName pkgId = let Cabal.PackageName nm = Cabal.pkgName pkgId in nm diff --git a/Haddock.hs b/Haddock.hs new file mode 100644 --- /dev/null +++ b/Haddock.hs @@ -0,0 +1,176 @@ +module Haddock ( + -- Package dependencies + pkgDepsFromModSummary + -- Interfacing with Haddock + , haddockInterfaceFor + -- Link environment + , LinkEnv + , homeModuleFor + -- Link environment cache + , linkEnvForDeps + ) where + +-- Platform imports +import Prelude hiding (mod) +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (SomeException) +import Control.Applicative ((<$>)) +import qualified Control.Exception as Ex +import Data.Maybe (catMaybes) +import Data.Either (rights) +import qualified Data.Map as LazyMap + +-- GHC imports; unqualified where no confusion can arise +import GHC (DynFlags, unLoc, RdrName, ImportDecl(..), Located) +import MonadUtils (MonadIO(..)) -- ghc's MonadIO +import Outputable (defaultUserStyle) +import qualified GHC +import qualified Name as GHC +import qualified Packages as GHC + +-- Haddock imports +import qualified Documentation.Haddock as Hk + +-- ide-backend imports +import IdeSession.Types.Private +import IdeSession.Strict.Container +import IdeSession.Strict.IORef +import qualified IdeSession.Strict.Map as StrictMap +import qualified IdeSession.Strict.Maybe as StrictMaybe + +-- Our imports +import Conv +import GhcShim + +{------------------------------------------------------------------------------ + Package dependencies +------------------------------------------------------------------------------} + +pkgDepsFromModSummary :: DynFlags + -> GHC.ModSummary + -> [PackageKey] +pkgDepsFromModSummary dflags s = + catMaybes (map (uncurry (findExposedModule dflags)) impMods) + where + aux :: Located (ImportDecl RdrName) + -> (PackageQualifier, GHC.ModuleName) + aux lIdecl = let idecl = unLoc lIdecl + in (ideclPkgQual idecl, unLoc (ideclName idecl)) + + impMods :: [(PackageQualifier, GHC.ModuleName)] + impMods = map aux (GHC.ms_srcimps s) + ++ map aux (GHC.ms_textual_imps s) + +{------------------------------------------------------------------------------ + Interfacing with Haddock +------------------------------------------------------------------------------} + +haddockInterfaceFilePath :: DynFlags + -> PackageKey + -> Either String FilePath +haddockInterfaceFilePath dflags pkg = + let cfg = lookupPackage dflags pkg in + case () of + () | null (GHC.haddockInterfaces cfg) -> do + Left $ "No haddock interfaces found for package " + ++ pretty dflags defaultUserStyle pkg + () | length (GHC.haddockInterfaces cfg) > 1 -> do + Left $ "Too many haddock interfaces found for package " + ++ pretty dflags defaultUserStyle pkg + _otherwise -> + Right . head . GHC.haddockInterfaces $ cfg + +haddockInterfaceFor :: DynFlags + -> Hk.NameCacheAccessor IO + -> PackageKey + -> IO (Either String LinkEnv) +haddockInterfaceFor dflags cache pkg = do + case haddockInterfaceFilePath dflags pkg of + Left err -> return (Left err) + Right path -> do + iface <- try' $ Hk.readInterfaceFile cache path + return (mkLinkEnv . Hk.ifLinkEnv <$> iface) + where + try' :: MonadIO m => IO (Either String a) -> m (Either String a) + try' act = do + mr <- liftIO $ Ex.try act + case mr of + Left e -> do + return . Left $ show (e :: SomeException) + Right (Left e) -> do + return . Left $ e + Right (Right r) -> do + return . Right $ r + +{------------------------------------------------------------------------------ + Haddock's LinkEnv maps Names to Modules, but unfortunately those Names + have different Uniques than the Uniques that ghc uses and hence we cannot + use them for lookup. We create our own environment instead. +------------------------------------------------------------------------------} + +type LinkEnv = Strict (Map (GHC.Module, GHC.OccName)) GHC.Module + +mkLinkEnv :: Map GHC.Name GHC.Module -> LinkEnv +mkLinkEnv m = foldr (.) (\x -> x) (map aux (LazyMap.toList m)) StrictMap.empty + where + aux :: (GHC.Name, GHC.Module) -> LinkEnv -> LinkEnv + aux (n, home) = case GHC.nameModule_maybe n of + Just mod -> StrictMap.insert (mod, GHC.nameOccName n) home + Nothing -> \x -> x + +homeModuleFor :: DynFlags -> LinkEnv -> GHC.Name -> Strict Maybe ModuleId +homeModuleFor dflags linkEnv name = + case GHC.nameModule_maybe name of + Nothing -> do + StrictMaybe.nothing + Just mod -> do + case StrictMap.lookup (mod, GHC.nameOccName name) linkEnv of + Nothing -> do + StrictMaybe.nothing + Just m -> + StrictMaybe.just (importModuleId dflags m) + +{------------------------------------------------------------------------------ + Link environment cache + + We keep separate caches for the link env per package, and the link env per + set of package dependencies. This is important because the order of the + dependencies matters; for instance, there is an entry for 'True' in both + ghc-prim and base, but we want the entry in base so that we report Data.Bool + as the home module rather than GHC.Types. + + TODO: However, we might be able to be a bit smarter about memory usage here? +------------------------------------------------------------------------------} + +linkEnvPerPackageCache :: StrictIORef (Strict (Map PackageKey) (Either String LinkEnv)) +{-# NOINLINE linkEnvPerPackageCache #-} +linkEnvPerPackageCache = unsafePerformIO $ newIORef StrictMap.empty + +linkEnvForPackage :: DynFlags -> PackageKey -> IO (Either String LinkEnv) +linkEnvForPackage dynFlags pkgId = do + cache <- readIORef linkEnvPerPackageCache + case StrictMap.lookup pkgId cache of + Just linkEnv -> return linkEnv + Nothing -> do + linkEnv <- haddockInterfaceFor dynFlags Hk.freshNameCache pkgId + let cache' = StrictMap.insert pkgId linkEnv cache + writeIORef linkEnvPerPackageCache cache' + return linkEnv + +linkEnvPerDepsCache :: StrictIORef (Strict (Map [PackageKey]) LinkEnv) +{-# NOINLINE linkEnvPerDepsCache #-} +linkEnvPerDepsCache = unsafePerformIO $ newIORef StrictMap.empty + +linkEnvForDeps :: DynFlags -> [PackageKey] -> IO LinkEnv +linkEnvForDeps dynFlags deps = do + cache <- readIORef linkEnvPerDepsCache + case StrictMap.lookup deps cache of + Just linkEnv -> return linkEnv + Nothing -> do + linkEnvs <- mapM (linkEnvForPackage dynFlags) deps + -- See comment above about ordering of dependencies for a justification + -- of 'unions' (which is biased) + let linkEnv = StrictMap.unions (rights linkEnvs) + cache' = StrictMap.insert deps linkEnv cache + writeIORef linkEnvPerDepsCache cache' + return linkEnv diff --git a/HsWalk.hs b/HsWalk.hs new file mode 100644 --- /dev/null +++ b/HsWalk.hs @@ -0,0 +1,596 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell, + TypeSynonymInstances, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +-- | A few specialized walks over the Haskell AST. Heavily depends +-- on the GHC patches. +-- +-- Only @IdeSession.GHC.Run@ and @IdeSession.GHC.HsWalk@ should import +-- any modules from the ghc package and the modules should not be reexported +-- anywhere else, with the exception of @IdeSession.GHC.Server@. +module HsWalk + ( runHscQQ + , runHscPlugin + , runRnSplice + , extractSourceSpan + , idInfoForName + , constructExplicitSharingCache + , PluginResult(..) + , IsBinder(..) + , initExtractIdsSuspendedState + , ExtractIdsSuspendedState -- opaque + ) where + +#define DEBUG 0 + +import Control.Monad (liftM) +import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) + +#if DEBUG +import Control.Monad.Reader (local) +#endif + +import Prelude hiding (id, mod, span, writeFile) +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.State.Class (MonadState(..)) +import Data.Accessor (Accessor, accessor, (.>)) +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import Data.Maybe (fromMaybe, fromJust) +import Data.Text (Text) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Accessor.Monad.MTL.State as AccState +import qualified Data.ByteString.Char8 as BSSC +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Debug.Trace as Debug + +import IdeSession.Strict.Container +import IdeSession.Strict.IORef +import IdeSession.Strict.Pair +import IdeSession.Strict.StateT +import IdeSession.Types.Private as Private +import qualified IdeSession.Strict.IntMap as IntMap +import qualified IdeSession.Strict.Map as Map +import qualified IdeSession.Strict.Maybe as Maybe + +import DynFlags (HasDynFlags(..), getDynFlags) +import GHC hiding (idType, moduleName, ModuleName) +import HscMain (hscParse', tcRnModule', getHscEnv) +import HscTypes (Hsc, TypeEnv, HscEnv(hsc_dflags), mkPrintUnqualified) +import IOEnv (getEnv) +import MonadUtils (MonadIO (..)) +import NameEnv (nameEnvUniqueElts) +import OccName +import Outputable hiding (trace) +import TcRnTypes +import Unique (Unique, getUnique, getKey) +import Var hiding (idInfo) +import VarEnv (TidyEnv, emptyTidyEnv) +import qualified GHC +import qualified Module +import qualified Name +import qualified RdrName + +import Conv +import FilePathCaching +import GhcShim +import Haddock +import IdPropCaching +import TraceMonad + +{------------------------------------------------------------------------------ + Caching + + We use explicit sharing so that we can maintain sharing through the JSON + serialization. +------------------------------------------------------------------------------} + +-- | Construct the explicit sharing cache +-- +-- TODO: We should remove entries from the cache that are no longer necessary +-- (from modules in the home package that got unloaded, or from modules +-- in other packages that are no longer imported); moreover, we should avoid +-- sending the entire cache over on every call to compile. +constructExplicitSharingCache :: IO ExplicitSharingCache +constructExplicitSharingCache = do + -- TODO: keep two refs and wipe on that for local ids, to avoid blowup + -- for long-running sessions with many added and removed definitions. + idPropCache <- getIdPropCache + (filePathHash, _) <- toLazyPair `liftM` getFilePathCache + + let filePathCache = IntMap.fromList . map convert $ HashMap.toList filePathHash + return ExplicitSharingCache {..} + where + convert :: (FilePath, Int) -> (Int, ByteString) + convert (path, i) = (i, BSSC.pack path) + +{------------------------------------------------------------------------------ + Environment mapping source locations to info +------------------------------------------------------------------------------} + +fromGhcNameSpace :: Name.NameSpace -> IdNameSpace +fromGhcNameSpace ns + | ns == Name.varName = VarName + | ns == Name.dataName = DataName + | ns == Name.tvName = TvName + | ns == Name.tcName = TcClsName + | otherwise = error "fromGhcNameSpace" + +{------------------------------------------------------------------------------ + Extract an IdMap from information returned by the ghc type checker +------------------------------------------------------------------------------} + +data PluginResult = PluginResult { + -- TODO: Why aren't we using strict types for the first two fields? + pluginIdList :: !IdList + , pluginExpTypes :: ![(SourceSpan, Text)] + , pluginPkgDeps :: !(Strict [] Private.PackageId) + , pluginUseSites :: !UseSites + } + +runHscQQ :: StrictIORef ExtractIdsSuspendedState + -> HsQuasiQuote Name -> RnM (HsQuasiQuote Name) +runHscQQ stRef qq@(HsQuasiQuote quoter _span _str) = do + span <- (tcl_loc . env_lcl) `liftM` getEnv + extractIdsResumeTc stRef $ go span + return qq + where + go :: SrcSpan -> ExtractIdsM () + go span = do + ProperSpan span' <- extractSourceSpan span + dflags <- asks eIdsDynFlags + linkEnv <- asks eIdsLinkEnv + rdrEnv <- asks eIdsRdrEnv + current <- asks eIdsCurrent + (idProp, Just idScope) <- idInfoForName dflags + quoter + UseSite + (lookupRdrEnv rdrEnv quoter) + (Just current) + (homeModuleFor dflags linkEnv) + extendIdMap span' $ SpanQQ IdInfo{..} + +runRnSplice :: StrictIORef ExtractIdsSuspendedState + -> LHsExpr Name -> RnM (LHsExpr Name) +runRnSplice stRef expr = do + extractIdsResumeTc stRef $ extractPreIds SpanInSplice expr + return expr + +runHscPlugin :: StrictIORef (Strict (Map ModuleName) PluginResult) + -> StrictIORef ExtractIdsSuspendedState + -> ModSummary + -> Hsc TcGblEnv +runHscPlugin symbolRef stRef mod_summary = do + dynFlags <- getDynFlags + tcEnv <- hscFileFrontEnd mod_summary + eIdsEnv <- extractIdsEnvFromTc dynFlags tcEnv + + extractIdsResumeIO stRef eIdsEnv $ do + -- Information provided by the renamer + -- See http://www.haskell.org/pipermail/ghc-devs/2013-February/000540.html + -- It is important we do this *first*, because this creates the initial + -- cache with the IdInfo objects, which we can then update by processing + -- the typed AST and the global type environment. + extractPreIds SpanId (tcg_rn_decls tcEnv) + + -- Information provided by the type checker + extractPostIds (tcg_binds tcEnv) + + -- Type environment constructed for this module + extractTypesFromTypeEnv (tcg_type_env tcEnv) + + eIdsSt' <- liftIO $ extractIdsReset stRef + let processedModule = tcg_mod tcEnv + processedName = Text.pack $ moduleNameString $ GHC.moduleName processedModule + pkgDeps = imp_dep_pkgs (tcg_imports tcEnv) + pluginResult = PluginResult { + pluginIdList = _eIdsIdList eIdsSt' + , pluginExpTypes = _eIdsExpTypes eIdsSt' + , pluginPkgDeps = force $ map (importPackageId dynFlags) pkgDeps + , pluginUseSites = _eIdsUseSites eIdsSt' + } + + liftIO $ modifyIORef symbolRef (Map.insert processedName pluginResult) + return tcEnv + +extractTypesFromTypeEnv :: TypeEnv -> ExtractIdsM () +extractTypesFromTypeEnv = mapM_ go . nameEnvUniqueElts + where + go :: (Unique, TyThing) -> ExtractIdsM () + go (uniq, tyThing) = + maybe (return ()) (recordType uniq) (typeOfTyThing tyThing) + +{------------------------------------------------------------------------------ + Override hscFileFrontEnd so that we pass the renamer result through the + type checker +------------------------------------------------------------------------------} + +hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv +hscFileFrontEnd mod_summary = do + hpm <- hscParse' mod_summary + hsc_env <- getHscEnv + let passRenamerResult = True + tcg_env <- tcRnModule' hsc_env mod_summary passRenamerResult hpm + return tcg_env + +{------------------------------------------------------------------------------ + ExtractIdsT adds state and en environment to whatever monad that GHC + puts us in (this is why it needs to be a monad transformer). + + Note that MonadIO is GHC's MonadIO, not the standard one, and hence we need + our own instance. +------------------------------------------------------------------------------} + +data ExtractIdsEnv = ExtractIdsEnv { + eIdsDynFlags :: !DynFlags + , eIdsRdrEnv :: !RdrName.GlobalRdrEnv + , eIdsPprStyle :: !PprStyle + , eIdsCurrent :: !Module.Module + , eIdsLinkEnv :: !LinkEnv +#if DEBUG + , eIdsStackTrace :: [String] +#endif + } + +data ExtractIdsSuspendedState = ExtractIdsSuspendedState { + _eIdsTidyEnv :: !TidyEnv + , _eIdsIdList :: !IdList + , _eIdsExpTypes :: [(SourceSpan, Text)] -- TODO: explicit sharing? + , _eIdsUseSites :: !UseSites + } + +data ExtractIdsRunningState = ExtractIdsRunningState { + _eIdsSuspendedState :: !ExtractIdsSuspendedState + , eIdsFilePathCache :: !(StrictPair (HashMap FilePath Int) Int) + , eIdsIdPropCache :: !(Strict IntMap IdProp) + } + +eIdsTidyEnv' :: Accessor ExtractIdsSuspendedState TidyEnv +eIdsIdList' :: Accessor ExtractIdsSuspendedState IdList +eIdsExpTypes' :: Accessor ExtractIdsSuspendedState [(SourceSpan, Text)] +eIdsUseSites' :: Accessor ExtractIdsSuspendedState UseSites + +eIdsTidyEnv' = accessor _eIdsTidyEnv $ \x s -> s { _eIdsTidyEnv = x } +eIdsIdList' = accessor _eIdsIdList $ \x s -> s { _eIdsIdList = x } +eIdsExpTypes' = accessor _eIdsExpTypes $ \x s -> s { _eIdsExpTypes = x } +eIdsUseSites' = accessor _eIdsUseSites $ \x s -> s { _eIdsUseSites = x } + +eIdsSuspendedState :: Accessor ExtractIdsRunningState ExtractIdsSuspendedState +eIdsSuspendedState = accessor _eIdsSuspendedState $ \x s -> s { _eIdsSuspendedState = x } + +eIdsTidyEnv :: Accessor ExtractIdsRunningState TidyEnv +eIdsIdList :: Accessor ExtractIdsRunningState IdList +eIdsExpTypes :: Accessor ExtractIdsRunningState [(SourceSpan, Text)] +eIdsUseSites :: Accessor ExtractIdsRunningState UseSites + +eIdsTidyEnv = eIdsSuspendedState .> eIdsTidyEnv' +eIdsIdList = eIdsSuspendedState .> eIdsIdList' +eIdsExpTypes = eIdsSuspendedState .> eIdsExpTypes' +eIdsUseSites = eIdsSuspendedState .> eIdsUseSites' + +newtype ExtractIdsM a = ExtractIdsM ( + ReaderT ExtractIdsEnv (StrictState ExtractIdsRunningState) a + ) + deriving ( + Functor + , Applicative + , Monad + , MonadState ExtractIdsRunningState + , MonadReader ExtractIdsEnv + ) + +instance MonadFilePathCaching ExtractIdsM where + getFilePathCache = eIdsFilePathCache <$> get + putFilePathCache = \cache -> modify $ \st -> st { eIdsFilePathCache = cache } + +instance MonadIdPropCaching ExtractIdsM where + getIdPropCache = eIdsIdPropCache <$> get + putIdPropCache = \cache -> modify $ \st -> st { eIdsIdPropCache = cache } + +instance TraceMonad ExtractIdsM where + trace str = do + -- We are using a strict-state monad (as opposed to a strict state-monad) + -- so we can use the state to make sure the event gets evaluated + st <- get + put $ Debug.traceEvent str st + +instance HasDynFlags ExtractIdsM where + getDynFlags = asks eIdsDynFlags + +extractIdsResumeIO :: MonadIO m + => StrictIORef ExtractIdsSuspendedState + -> ExtractIdsEnv + -> ExtractIdsM a + -> m a +extractIdsResumeIO stRef env (ExtractIdsM act) = do + filePathCache <- liftIO $ getFilePathCache + idPropCache <- liftIO $ getIdPropCache + st <- liftIO $ readIORef stRef + + let (a, st') = runState (runReaderT act env) ExtractIdsRunningState { + _eIdsSuspendedState = st + , eIdsFilePathCache = filePathCache + , eIdsIdPropCache = idPropCache + } + + liftIO $ do + writeIORef stRef (_eIdsSuspendedState st') + putFilePathCache ( eIdsFilePathCache st') + putIdPropCache ( eIdsIdPropCache st') + + return a + +extractIdsResumeTc :: StrictIORef ExtractIdsSuspendedState + -> ExtractIdsM a + -> TcRn a +extractIdsResumeTc stRef act = do + tcEnv <- getEnv + eIdsEnv <- extractIdsEnvFromTc (hsc_dflags (env_top tcEnv)) (env_gbl tcEnv) + liftIO $ extractIdsResumeIO stRef eIdsEnv act + +extractIdsEnvFromTc :: MonadIO m => DynFlags -> TcGblEnv -> m ExtractIdsEnv +extractIdsEnvFromTc eIdsDynFlags env = liftIO $ do + eIdsLinkEnv <- linkEnvForDeps eIdsDynFlags pkgDeps + return ExtractIdsEnv{..} + where + eIdsRdrEnv = tcg_rdr_env env + eIdsCurrent = tcg_mod env + pkgDeps = imp_dep_pkgs (tcg_imports env) + qual = mkPrintUnqualified eIdsDynFlags eIdsRdrEnv + eIdsPprStyle = mkUserStyle qual AllTheWay +#if DEBUG + eIdsStackTrace = [] +#endif + +extractIdsReset :: StrictIORef ExtractIdsSuspendedState -> IO ExtractIdsSuspendedState +extractIdsReset stRef = do + oldState <- readIORef stRef + writeIORef stRef initExtractIdsSuspendedState + return oldState + +initExtractIdsSuspendedState :: ExtractIdsSuspendedState +initExtractIdsSuspendedState = + ExtractIdsSuspendedState { + _eIdsTidyEnv = emptyTidyEnv + , _eIdsIdList = [] + , _eIdsExpTypes = [] + , _eIdsUseSites = Map.empty + } + +_debugLog :: FilePath -> String -> ExtractIdsM () +_debugLog path str = do + st <- get + put $ go st + where + go :: a -> a + go x = unsafePerformIO $ do + appendFile path (str ++ "\n") + return x + +extendIdMap :: SourceSpan -> SpanInfo -> ExtractIdsM () +extendIdMap span info = + AccState.modify eIdsIdList ((span, info) :) + +recordUseSite :: IdPropPtr -> SourceSpan -> ExtractIdsM () +recordUseSite ptr span = + AccState.modify eIdsUseSites (Map.alter insertSpan ptr) + where + insertSpan Nothing = Just [span] + insertSpan (Just ss) = Just (span : ss) + +tidyType :: Type -> ExtractIdsM Type +tidyType typ = do + tidyEnv <- AccState.get eIdsTidyEnv + let (tidyEnv', typ') = tidyOpenType tidyEnv typ + AccState.set eIdsTidyEnv tidyEnv' + return typ' + +lookupRdrEnv :: RdrName.GlobalRdrEnv -> Name -> Maybe RdrName.GlobalRdrElt +lookupRdrEnv rdrEnv name = + case lookupOccEnv rdrEnv (Name.nameOccName name) of + Nothing -> Nothing + Just elts -> case filter ((== name) . RdrName.gre_name) elts of + [] -> Nothing + [elt] -> Just elt + _ -> error "ghc invariant violated" + +recordExpType :: SrcSpan -> Maybe Type -> ExtractIdsM (Maybe Type) +recordExpType span (Just typ) = do + eitherSpan <- extractSourceSpan span + case eitherSpan of + ProperSpan properSpan -> do + prettyTyp <- tidyType typ >>= showTypeForUser + AccState.modify eIdsExpTypes ((properSpan, prettyTyp) :) + TextSpan _ -> + return () -- Ignore + return (Just typ) +recordExpType _ Nothing = return Nothing + +-- We mark every node in the AST with 'ast'. This is necessary so that we can +-- restore the TidyEnv at every node, so that we can reuse type variables. For +-- instance +-- +-- > foo (x, y) = x +-- > bar (x, y) = y +-- +-- In this case, we can assign (t, t1) -> t and (t, t1) -> t1 as types, reusing +-- 't' and 't1', but we can only do this because they are not nested. +-- +-- For debugging purposes, we also take in two arguments describing the AST. +-- +-- TODO: This assumes that the structure of the AST follows Haskell scoping +-- rules. If this is not the case, this will break. +ast :: Maybe SrcSpan -> String -> ExtractIdsM a -> ExtractIdsM a +ast _mspan _info cont = do +#if DEBUG + local (\env -> env { eIdsStackTrace = _info : eIdsStackTrace env }) $ do +#endif + -- Restore the tideEnv after cont + tidyEnv <- AccState.get eIdsTidyEnv + result <- cont + AccState.set eIdsTidyEnv tidyEnv + return result + +unsupported :: Maybe SrcSpan -> String -> ExtractIdsM (Maybe Type) +#if DEBUG +unsupported mspan c = ast mspan c $ do + prettySpan <- prettyM defaultUserStyle mspan + fail $ "extractIds: unsupported " ++ c ++ " at " ++ prettySpan ++ "\n" +#else +unsupported _ _ = return Nothing +#endif + +-- | Construct an IdInfo for a 'Name'. We assume the @GlobalRdrElt@ is +-- uniquely determined by the @Name@ and the @DynFlags@ do not change +-- in a bad way. +idInfoForName + :: forall m. (MonadFilePathCaching m, MonadIdPropCaching m) + => DynFlags -- ^ The usual dynflags + -> Name -- ^ The name in question + -> IsBinder -- ^ Is this a binding occurrence? + -> Maybe RdrName.GlobalRdrElt -- ^ GlobalRdrElt for imported names + -> Maybe Module.Module -- ^ Current module for local names + -> (Name -> Strict Maybe ModuleId) -- ^ Home modules + -> m (IdPropPtr, Maybe IdScope) -- ^ Nothing if imported but no GlobalRdrElt +idInfoForName dflags name idIsBinder mElt mCurrent home = do + scope <- constructScope + idDefSpan <- extractSourceSpan (Name.nameSrcSpan name) + + let mod = if isLocal scope + then fromJust mCurrent + else fromMaybe missingModule $ + Name.nameModule_maybe name + idPropPtr = IdPropPtr . getKey . getUnique $ name + idDefinedIn = importModuleId dflags mod + idHomeModule = home name + + extendIdPropCache idPropPtr IdProp{..} + return (idPropPtr, scope) + where + occ = Name.nameOccName name + idName = Text.pack $ Name.occNameString occ + idSpace = fromGhcNameSpace $ Name.occNameSpace occ + idType = Maybe.nothing -- after renamer but before typechecker + + constructScope :: m (Maybe IdScope) + constructScope + | DefSite <- idIsBinder = return $ Just Binder + | Name.isWiredInName name = return $ Just WiredIn + | Name.isInternalName name = return $ Just Local + | otherwise = case mElt of + Just gre -> do scope <- scopeFromProv (RdrName.gre_prov gre) + return (Just scope) + Nothing -> return Nothing + + -- We need to guess the PackageId here, because this is not stored as + -- part of the ImpDeclSpec (listed as a TODO in the ghc sources). + -- For now we pass 'Nothing' as the PackageQualifier. It *might* be + -- possible to recover the package qualifier using 'impSpan'. + scopeFromProv :: RdrName.Provenance -> m IdScope + scopeFromProv RdrName.LocalDef = do + return Local + scopeFromProv (RdrName.Imported spec) = do + (impMod, impSpan, impQual) <- extractImportInfo spec + return Imported { + idImportedFrom = importModuleId' dflags Nothing impMod + , idImportSpan = impSpan + , idImportQual = Text.pack $ impQual + } + + extractImportInfo :: [RdrName.ImportSpec] -> m (GHC.ModuleName, EitherSpan, String) + extractImportInfo (RdrName.ImpSpec decl item:_) = do + span <- case item of + RdrName.ImpAll -> extractSourceSpan (RdrName.is_dloc decl) + RdrName.ImpSome _explicit loc -> extractSourceSpan loc + return + ( RdrName.is_mod decl + , span + , if RdrName.is_qual decl + then moduleNameString (RdrName.is_as decl) ++ "." + else "" + ) + extractImportInfo _ = fail "ghc invariant violated" + + isLocal :: Maybe IdScope -> Bool + isLocal (Just Local) = True + isLocal (Just Binder) = True + isLocal _ = False + + missingModule :: a + missingModule = error $ "No module for " + ++ pretty dflags defaultUserStyle name + +recordType :: Unique -> Type -> ExtractIdsM () +recordType uniq typ = do + typStr <- tidyType typ >>= showTypeForUser + recordIdPropType (IdPropPtr $ getKey uniq) typStr + +showTypeForUser :: Type -> ExtractIdsM Text +showTypeForUser typ = do + pprStyle <- asks eIdsPprStyle + prettyTyp <- prettyTypeM pprStyle showForalls typ + return $ Text.pack prettyTyp + where + showForalls = False + +extractPreIds :: Fold Name a => (IdInfo -> SpanInfo) -> a -> ExtractIdsM (Maybe Type) +extractPreIds mkSpanInfo = fold AstAlg { + astMark = ast + , astUnsupported = unsupported + , astExpType = recordExpType + , astId = recordName mkSpanInfo + , astPhase = FoldPreTc + } + +extractPostIds :: Fold Var a => a -> ExtractIdsM (Maybe Type) +extractPostIds = fold AstAlg { + astMark = ast + , astUnsupported = unsupported + , astExpType = recordExpType + , astId = recordId + , astPhase = FoldPostTc + } + +recordId :: IsBinder -> Located Id -> ExtractIdsM (Maybe Type) +recordId _idIsBinder (L span id) = do + recordType (getUnique id) typ + recordExpType span (Just typ) + where + typ = Var.varType id + +recordName :: (IdInfo -> SpanInfo) + -> IsBinder -> Located Name + -> ExtractIdsM (Maybe Type) +recordName mkSpanInfo idIsBinder (L span name) = do + span' <- extractSourceSpan span + case span' of + ProperSpan sourceSpan -> do + dflags <- getDynFlags + rdrEnv <- asks eIdsRdrEnv + current <- asks eIdsCurrent + linkEnv <- asks eIdsLinkEnv + + -- The lookup into the rdr env will only be used for imported names. + info <- idInfoForName dflags + name + idIsBinder + (lookupRdrEnv rdrEnv name) + (Just current) + (homeModuleFor dflags linkEnv) + + case info of + (idProp, Just idScope) -> do + extendIdMap sourceSpan $ mkSpanInfo IdInfo{..} + case idIsBinder of + UseSite -> recordUseSite idProp sourceSpan + _ -> return () + _ -> + -- This only happens for some special cases ('assert' being + -- the prime example; it gets reported as 'assertError' from + -- 'GHC.IO.Exception' but there is no corresponding entry in the + -- GlobalRdrEnv. + return () + TextSpan _ -> + return () -- Name without source span + return Nothing diff --git a/IdPropCaching.hs b/IdPropCaching.hs new file mode 100644 --- /dev/null +++ b/IdPropCaching.hs @@ -0,0 +1,58 @@ +module IdPropCaching ( + MonadIdPropCaching(..) + , modifyIdPropCache + , extendIdPropCache + , recordIdPropType + ) where + +import Control.Applicative ((<|>)) +import System.IO.Unsafe (unsafePerformIO) + +import IdeSession.Types.Private (IdPropPtr(..), IdProp(..)) +import IdeSession.Types.Public (Type) +import IdeSession.Strict.IORef +import IdeSession.Strict.Container +import qualified IdeSession.Strict.IntMap as IntMap +import qualified IdeSession.Strict.Maybe as Maybe + +import GHC (Ghc) +import MonadUtils + +class Monad m => MonadIdPropCaching m where + getIdPropCache :: m (Strict IntMap IdProp) + putIdPropCache :: Strict IntMap IdProp -> m () + +idPropCacheRef :: StrictIORef (Strict IntMap IdProp) +{-# NOINLINE idPropCacheRef #-} +idPropCacheRef = unsafePerformIO $ newIORef IntMap.empty + +instance MonadIdPropCaching IO where + getIdPropCache = readIORef idPropCacheRef + putIdPropCache = writeIORef idPropCacheRef + +instance MonadIdPropCaching Ghc where + getIdPropCache = liftIO $ getIdPropCache + putIdPropCache = liftIO . putIdPropCache + +modifyIdPropCache :: MonadIdPropCaching m => IdPropPtr -> (IdProp -> IdProp) -> m () +modifyIdPropCache ptr f = do + cache <- getIdPropCache + putIdPropCache $ IntMap.adjust f (idPropPtr ptr) cache + +extendIdPropCache :: MonadIdPropCaching m => IdPropPtr -> IdProp -> m () +extendIdPropCache ptr prop = do + cache <- getIdPropCache + putIdPropCache $ IntMap.insertWith update (idPropPtr ptr) prop cache + where + -- We need to make sure not to lose information that we learned earlier + update :: IdProp -> IdProp -> IdProp + update new old + = new { idType = idType new <|> idType old + , idHomeModule = idHomeModule new <|> idHomeModule old + } + +recordIdPropType :: MonadIdPropCaching m => IdPropPtr -> Type -> m () +recordIdPropType ptr tp = + modifyIdPropCache ptr $ \idInfo -> idInfo { + idType = Maybe.just tp + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015 FP Complete + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Run.hs b/Run.hs new file mode 100644 --- /dev/null +++ b/Run.hs @@ -0,0 +1,609 @@ +{-# LANGUAGE CPP, TemplateHaskell, RecordWildCards, ScopedTypeVariables #-} +-- Copyright : (c) JP Moresmau 2011, +-- Well-Typed 2012 +-- (JP Moresmau's buildwrapper package used as template for GHC API use) +-- +-- | Implementation details of the calls to GHC that compute information +-- based on source files, provides progress information while doing so +-- and optionally compiles, links and executes code. +-- +-- Only @IdeSession.GHC.Run@ and @IdeSession.GHC.HsWalk@ should import +-- any modules from the ghc package and the modules should not be reexported +-- anywhere else, with the exception of @IdeSession.GHC.Server@. +module Run + ( -- * Re-expored GHC API + Ghc + , runFromGhc + , liftIO + , GhcException + , ghandle + , ghandleJust + , getModuleGraph + , moduleNameString + , ms_mod_name, ms_hs_date + -- * Processing source files (including compilation) + , compileInGhc + , collectSrcError + , DynamicOpts + , submitStaticOpts + , optsToDynFlags + , DynFlags(hooks) + , defaultDynFlags + , getSessionDynFlags + , setSessionDynFlags + , parseDynamicFlags + , hsExtensions + , importList + , autocompletion + -- * Executing snippets + , runInGhc + , RunCmd(..) + , RunResult(..) + , RunBufferMode(..) + , breakFromSpan + , printVars + ) where + +#define DEBUG 0 + +import Prelude hiding (id, mod, span) +import qualified Control.Exception as Ex +import Control.Monad (filterM, liftM, void, when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Applicative ((<$>)) +import Data.List ((\\)) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Data.Array (Array) +import qualified Data.Array as Array +import qualified Data.Text as Text +import System.FilePath.Find (find, always, extension) +import System.Process +import System.IO.Unsafe (unsafePerformIO) + +#if defined(GHC_761) +-- http://hackage.haskell.org/trac/ghc/ticket/7548 +-- is not fixed in this version. Compilation should fail, +-- because the problem is not minor and not easy to spot otherwise. +#error "GHC 7.6.1 is broken (#7548) and not supported" +#endif + +import Bag (bagToList) +import DynFlags (defaultDynFlags) +import Exception (ghandle) +import ErrUtils (ErrMsg) +import FastString ( unpackFS ) +import GHC hiding ( + ModuleName + , RunResult(..) + , BreakInfo(..) + , getBreak + ) +import GhcMonad (liftIO) +import OccName (occEnvElts) +import Outputable (PprStyle, mkUserStyle) +import RdrName (GlobalRdrEnv, GlobalRdrElt, gre_name) +import RnNames (rnImports) +import TcRnMonad (initTc) +import TcRnTypes (RnM) +import RtClosureInspect (Term) +import qualified HscTypes +import qualified GHC as GHC +import qualified Config as GHC +import qualified Outputable as GHC +import qualified ByteCodeInstr as GHC +import qualified Id as GHC + +#if __GLASGOW_HASKELL__ >= 706 +import ErrUtils ( MsgDoc ) +#else +import ErrUtils ( Message ) +#endif + +import IdeSession.GHC.API +import IdeSession.Types.Public (RunBufferMode(..), Targets(..)) +import IdeSession.Types.Private +import qualified IdeSession.Types.Public as Public +import IdeSession.Util +import IdeSession.Strict.Container +import IdeSession.Strict.IORef +import qualified IdeSession.Strict.List as StrictList +import qualified IdeSession.Strict.Map as StrictMap + +import HsWalk (idInfoForName) +import Haddock +import Debug +import Conv +import FilePathCaching +import Break +import GhcShim + +type DynamicOpts = [Located String] + +-- | Set static flags at server startup and return dynamic flags. +submitStaticOpts :: [String] -> IO DynamicOpts +submitStaticOpts opts = do + (dynFlags, _) <- parseStaticFlags (map noLoc opts) + return dynFlags + +-- | Create dynamic flags from their command-line names. +optsToDynFlags :: [String] -> DynamicOpts +optsToDynFlags = map noLoc + +getGhcLibdir :: IO FilePath +getGhcLibdir = do + let ghcbinary = "ghc-" ++ GHC.cProjectVersion + out <- readProcess ghcbinary ["--print-libdir"] "" + case lines out of + [libdir] -> return libdir + _ -> fail "cannot parse output of ghc --print-libdir" + +runFromGhc :: Ghc a -> IO a +runFromGhc a = do + libdir <- getGhcLibdir + runGhc (Just libdir) a + +-- | Version of handleJust for use in the GHC monad +ghandleJust :: Ex.Exception e => (e -> Maybe b) -> (b -> Ghc a) -> Ghc a -> Ghc a +ghandleJust p handler a = ghandle handler' a + where + handler' e = case p e of + Nothing -> liftIO $ Ex.throwIO e + Just b -> handler b + +-- | Compile a set of targets +-- +-- Returns the errors, loaded modules, and mapping from filenames to modules +compileInGhc :: FilePath -- ^ target directory + -> Bool -- ^ should we generate code + -> Targets -- ^ targets + -> StrictIORef (Strict [] SourceError) -- ^ the IORef where GHC stores errors + -> Ghc ( Strict [] SourceError + , [ModuleName] + , Strict (Map FilePath) ModuleId + ) +compileInGhc configSourcesDir generateCode mTargets errsRef = do + -- Reset errors storage. + liftIO $ writeIORef errsRef StrictList.nil + -- Compute new GHC flags. + flags1 <- getSessionDynFlags + -- Let GHC API print "compiling M ... done." for each module. + let verbosityNew :: Int + verbosityNew = 1 + (hscTargetNew, ghcLinkNew) + | generateCode = (HscInterpreted, LinkInMemory) + | otherwise = (HscNothing, NoLink) + flagsNeedChange = hscTargetNew /= hscTarget flags1 + || ghcLinkNew /= ghcLink flags1 + || verbosityNew /= verbosity flags1 + flags = flags1 { + hscTarget = hscTargetNew, + ghcLink = ghcLinkNew, + verbosity = verbosityNew + } + handleErrors flags $ do + defaultCleanupHandler flags $ do + -- Set up the GHC flags. + when flagsNeedChange $ void $ setSessionDynFlags flags + setTargets =<< computeTargets + void $ load LoadAllTargets + + -- Collect info + errs <- liftIO $ readIORef errsRef + loaded <- getLoaded + fileMap <- getFileMap + return ( StrictList.reverse errs + , loaded + , StrictMap.fromList $ fileMap + ) + where + getLoaded :: Ghc [ModuleName] + getLoaded = do + graph <- getModuleGraph + names <- filterM isLoaded $ map ms_mod_name graph + return $ map (Text.pack . moduleNameString) names + + getFileMap :: Ghc [(FilePath, ModuleId)] + getFileMap = do + dflags <- getSessionDynFlags + let aux :: ModSummary -> Maybe (FilePath, ModuleId) + aux summary = do + hs <- ml_hs_file $ ms_location summary + return (hs, importModuleId dflags (ms_mod summary)) + graph <- getModuleGraph + return $ catMaybes $ map aux graph + + computeTargets :: Ghc [Target] + computeTargets = do + targetIds <- case mTargets of + TargetsInclude include -> return (map targetIdFromFile include) + TargetsExclude exclude -> liftIO $ do + allPaths <- find always ((`elem` hsExtensions) `liftM` extension) + configSourcesDir + let paths = allPaths \\ exclude + return (map targetIdFromFile paths) + return (map targetWithId targetIds) + + targetWithId :: TargetId -> Target + targetWithId targetId = Target { + targetId = targetId + , targetAllowObjCode = True + , targetContents = Nothing + } + + targetIdFromFile :: FilePath -> TargetId + targetIdFromFile path = TargetFile path Nothing + + sourceErrorHandler :: DynFlags -> HscTypes.SourceError -> Ghc () + sourceErrorHandler _flags e = liftIO $ do + debug dVerbosity $ "handleSourceError: " ++ show e + errs <- readIORef errsRef + e' <- fromHscSourceError e + writeIORef errsRef (force e' StrictList.++ errs) + + -- A workaround for http://hackage.haskell.org/trac/ghc/ticket/7430. + -- Some errors are reported as exceptions instead. + ghcExceptionHandler :: DynFlags -> GhcException -> Ghc () + ghcExceptionHandler _flags e = liftIO $ do + let eText = Text.pack $ show e -- no SrcSpan as a field in GhcException + fromEx = Text.pack $ "" + exError = SourceError KindError (TextSpan fromEx) eText + -- though it may be embedded in string + debug dVerbosity $ "handleOtherErrors: " ++ Text.unpack eText + errs <- readIORef errsRef + writeIORef errsRef (exError `StrictList.cons` errs) + + handleErrors :: DynFlags -> Ghc () -> Ghc () + handleErrors flags = ghandle (ghcExceptionHandler flags) + . handleSourceError (sourceErrorHandler flags) + +importList :: ModSummary -> Ghc (Strict [] Import) +importList summary = do + dflags <- getSessionDynFlags + + -- TODO: This is lossy. We might want a more accurate data type. + let unLIE :: LIE RdrName -> Text + unLIE (L _ name) = Text.pack $ pretty dflags GHC.defaultUserStyle name + +#if __GLASGOW_HASKELL__ >= 710 + let unLocNames :: Located [LIE name] -> [LIE name] + unLocNames (L _ names) = names +#else + let unLocNames :: [LIE name] -> [LIE name] + unLocNames names = names +#endif + +#if __GLASGOW_HASKELL__ >= 710 + let mkImportEntities :: Maybe (Bool, Located [LIE RdrName]) -> ImportEntities +#else + let mkImportEntities :: Maybe (Bool, [LIE RdrName]) -> ImportEntities +#endif + mkImportEntities Nothing = ImportAll + mkImportEntities (Just (True, names)) = ImportHiding (force $ map unLIE (unLocNames names)) + mkImportEntities (Just (False, names)) = ImportOnly (force $ map unLIE (unLocNames names)) + + let goImp :: Located (ImportDecl RdrName) -> Import + goImp (L _ decl) = Import { + importModule = importModuleId' dflags (ideclPkgQual decl) (unLoc (ideclName decl)) + , importPackage = force $ ((Text.pack . unpackFS) <$> ideclPkgQual decl) + , importQualified = ideclQualified decl + , importImplicit = ideclImplicit decl + , importAs = force $ ((Text.pack . moduleNameString) <$> ideclAs decl) + , importEntities = mkImportEntities (ideclHiding decl) + } + + return . force $ map goImp (ms_srcimps summary) + ++ map goImp (ms_textual_imps summary) + +autocompletion :: ModSummary -> Ghc (Strict [] IdInfo) +autocompletion summary = do + dflags <- getSessionDynFlags + session <- getSession + + let pkgDeps = pkgDepsFromModSummary dflags summary + linkEnv <- liftIO $ linkEnvForDeps dflags pkgDeps + + let eltsToAutocompleteMap :: GlobalRdrElt -> Ghc IdInfo + eltsToAutocompleteMap elt = do + let name = gre_name elt + currentModule = Nothing -- Must be imported (TH stage restriction) + (idProp, Just idScope) <- idInfoForName dflags + name + UseSite + (Just elt) + currentModule + (homeModuleFor dflags linkEnv) + return IdInfo{..} + + autoEnvs :: ModSummary -> IO [GlobalRdrElt] + autoEnvs ModSummary{ ms_mod + , ms_hsc_src + , ms_srcimps + , ms_textual_imps + } = do + let go :: RnM (a, GlobalRdrEnv, b, c) -> IO [GlobalRdrElt] + go op = do + ((_warns, _errs), res) <- initTc session ms_hsc_src False ms_mod op + case res of + Nothing -> do + -- TODO: deal with import errors +#if DEBUG + appendFile "/tmp/ghc.importerrors" $ show + . map GHC.showSDoc + $ ErrUtils.pprErrMsgBag _errs +#endif + return [] + Just (_, elts, _, _) -> + return . concat $ occEnvElts elts + env1 <- go $ rnImports ms_srcimps + env2 <- go $ rnImports ms_textual_imps + return $ env1 ++ env2 + + envs <- liftIO $ autoEnvs summary + idIs <- mapM eltsToAutocompleteMap envs + return $ force idIs + +-- | Run a snippet. +runInGhc :: RunCmd -> Ghc RunResult +runInGhc cmd = do + flags <- getSessionDynFlags + defaultCleanupHandler flags . handleErrors $ do + runRes <- runCmd cmd + case runRes of + GHC.RunOk _ -> + return RunOk + GHC.RunException ex -> + return $ RunProgException (showExWithClass ex) + GHC.RunBreak _tid names mBreakInfo -> do + Just info <- importBreakInfo mBreakInfo names + return $ RunBreak info + where + handleError :: Show a => a -> Ghc RunResult + handleError = return . RunGhcException . show + + -- "such-and-such not in scope" is reported as a source error + -- not sure when GhcExceptions are thrown (if at all) + handleErrors :: Ghc RunResult -> Ghc RunResult + handleErrors = handleSourceError handleError + . ghandle (handleError :: GhcException -> Ghc RunResult) + +-- | Auxiliary to 'runInGhc' +runCmd :: RunCmd -> Ghc GHC.RunResult +runCmd (RunStmt {..}) = do + setContext $ [ IIDecl $ simpleImportDecl $ mkModuleName runCmdModule + , IIDecl $ simpleImportDecl $ mkModuleName "IdeBackendRTS" + ] + runStmt expr RunToCompletion + where + expr :: String + expr = fqn "run " + ++ "(" ++ fqBMode runCmdStdout ++ ")" + ++ "(" ++ fqBMode runCmdStderr ++ ")" + ++ "(" ++ runCmdModule ++ "." ++ runCmdFunction ++ ")" + + fqn :: String -> String + fqn = (++) "IdeBackendRTS." + + fqBMode :: RunBufferMode -> String + fqBMode RunNoBuffering = + fqn "RunNoBuffering" + fqBMode (RunLineBuffering t) = + fqn "RunLineBuffering (" ++ fqMInt t ++ ")" + fqBMode (RunBlockBuffering sz t) = + fqn "RunBlockBuffering (" ++ fqMInt sz ++ ") (" ++ fqMInt t ++ ")" + + fqMInt :: Maybe Int -> String + fqMInt Nothing = fqn "Nothing" + fqMInt (Just n) = fqn "Just " ++ show n +runCmd Resume = + resume (const True) RunToCompletion + +{------------------------------------------------------------------------------ + Dealing with breakpoints +------------------------------------------------------------------------------} + +-- | We store a print context whenever we hit a breakpoint so that we have +-- sufficient context for subsequent requests for pretty-printing types +printContext :: StrictIORef PprStyle +{-# NOINLINE printContext #-} +printContext = unsafePerformIO $ + newIORef (mkUserStyle alwaysQualify GHC.AllTheWay) + +getPrintContext :: Ghc PprStyle +getPrintContext = liftIO $ readIORef printContext + +setPrintContext :: PprStyle -> Ghc () +setPrintContext ctxt = liftIO $ writeIORef printContext ctxt + +breakFromSpan :: ModuleName -- ^ Module containing the breakpoint + -> Public.SourceSpan -- ^ Location of the breakpoint + -> Bool -- ^ New value for the breakpoint + -> Ghc (Maybe Bool) -- ^ Old valeu of the breakpoint (if valid) +breakFromSpan modName span newValue = runMaybeT $ do + modInfo <- MaybeT $ getModuleInfo mod + let ModBreaks{..} = modInfoModBreaks modInfo + + breakIndex <- MaybeT $ return $ findBreakIndex modBreaks_locs + oldValue <- MaybeT $ getBreak modBreaks_flags breakIndex + + lift $ setBreak modBreaks_flags breakIndex newValue + return oldValue + where + findBreakIndex :: Array BreakIndex SrcSpan -> Maybe BreakIndex + findBreakIndex breaks = listToMaybe + . catMaybes + . map matchesSpan + . Array.assocs + $ breaks + + matchesSpan :: (BreakIndex, SrcSpan) -> Maybe BreakIndex + matchesSpan (_, UnhelpfulSpan _) = Nothing + matchesSpan (i, RealSrcSpan span') = + if srcSpanStartLine span' == Public.spanFromLine span + && srcSpanStartCol span' == Public.spanFromColumn span + && srcSpanEndLine span' == Public.spanToLine span + && srcSpanEndCol span' == Public.spanToColumn span + then Just i + else Nothing + + mod :: Module + mod = mkModule mainPackageKey (mkModuleName . Text.unpack $ modName) + +importBreakInfo :: Maybe GHC.BreakInfo + -> [Name] + -> Ghc (Maybe BreakInfo) +importBreakInfo (Just GHC.BreakInfo{..}) names = runMaybeT $ do + modInfo <- MaybeT $ getModuleInfo breakInfo_module + printUnqualified <- MaybeT $ mkPrintUnqualifiedForModule modInfo + + let ModBreaks{..} = modInfoModBreaks modInfo + srcSpan = modBreaks_locs Array.! breakInfo_number + pprStyle = mkUserStyle printUnqualified GHC.AllTheWay + + lift $ do + setPrintContext pprStyle + + localVars <- mkTerms >>= mapM (exportVar pprStyle) + ProperSpan srcSpan' <- liftIO $ extractSourceSpan srcSpan + prettyResTy <- prettyM pprStyle breakInfo_resty + + return BreakInfo { + breakInfoModule = mod + , breakInfoSpan = srcSpan' + , breakInfoResultType = Text.pack prettyResTy + , breakInfoVariableEnv = localVars + } + where + mkTerms :: Ghc [(Id, Term)] + mkTerms = resolveNames names >>= evaluateIds False False + + -- we ignore the package (because it's always the home package) + mod = Text.pack . moduleNameString . GHC.moduleName $ breakInfo_module +importBreakInfo Nothing _names = error "importBreakInfo: missing case" + +printVars :: String -> Bool -> Bool -> Ghc Public.VariableEnv +printVars vars bind forceEval = + getPrintContext >>= \unqual -> + parseNames vars >>= + resolveNames >>= + evaluateIds bind forceEval >>= + mapM (exportVar unqual) + +exportVar :: PprStyle -> (Id, Term) -> Ghc (Public.Name, Public.Type, Public.Value) +exportVar pprStyle (var, term) = do + nameStr <- prettyM pprStyle (GHC.idName var) + typeStr <- prettyTypeM pprStyle showForalls (GHC.idType var) + termStr <- prettyM pprStyle term + return (Text.pack nameStr, Text.pack typeStr, Text.pack termStr) + where + showForalls = False + +----------------------- +-- Source error conversion and collection +-- + +collectSrcError :: StrictIORef (Strict [] SourceError) + -> (String -> IO ()) + -> (String -> IO ()) + -> DynFlags + -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +collectSrcError errsRef handlerOutput handlerRemaining flags + severity srcspan style msg = do + -- Prepare debug prints. + debug dVerbosity + $ "Severity: " ++ show severity + ++ " SrcSpan: " ++ show srcspan +-- ++ " PprStyle: " ++ show style + ++ " MsgDoc: " + ++ showSDocForUser flags (queryQual style) msg + ++ "\n" + -- Actually collect errors. + collectSrcError' + errsRef handlerOutput handlerRemaining flags severity srcspan style msg + +collectSrcError' :: StrictIORef (Strict [] SourceError) + -> (String -> IO ()) + -> (String -> IO ()) + -> DynFlags + -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +collectSrcError' errsRef _ _ flags severity srcspan style msg + | Just errKind <- case severity of + SevWarning -> Just KindWarning + SevError -> Just KindError + SevFatal -> Just KindError + _ -> Nothing + = do let msgstr = showSDocForUser flags (queryQual style) msg + sp <- extractSourceSpan srcspan + modifyIORef errsRef (StrictList.cons $ SourceError errKind sp (Text.pack msgstr)) + +collectSrcError' _errsRef handlerOutput _ flags SevOutput _srcspan style msg + = let msgstr = showSDocForUser flags (queryQual style) msg + in handlerOutput msgstr + +collectSrcError' _errsRef _ handlerRemaining flags _severity _srcspan style msg + = let msgstr = showSDocForUser flags (queryQual style) msg + in handlerRemaining msgstr + +-- TODO: perhaps make a honest SrcError from the first span from the first +-- error message and put the rest into the message string? That probably +-- entains string-search-and-replace inside the message string not to +-- duplicate the first span, because the types involved are abstract. +-- And even then, all the file paths but the first would be out of +-- our control (and so, e.g., not relative to the project root). +-- But at least the IDE could point somewhere in the code. +-- | Convert GHC's SourceError type into ours. +fromHscSourceError :: forall m. MonadFilePathCaching m => HscTypes.SourceError -> m [SourceError] +fromHscSourceError = mapM aux . bagToList . HscTypes.srcErrorMessages + where + aux :: ErrMsg -> m SourceError + aux e = do + let err = Text.pack (show e) + noloc = Text.pack "" + + case sourceErrorSpan e of + Just real -> do + xSpan <- extractSourceSpan real + return $ SourceError KindError xSpan err + Nothing -> + return $ SourceError KindError (TextSpan noloc) err + +----------------------- +-- GHC version compat +-- + +#if __GLASGOW_HASKELL__ < 706 +type MsgDoc = Message +#endif + +showSDocForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> String +#if __GLASGOW_HASKELL__ >= 706 +showSDocForUser flags uqual msg = GHC.showSDocForUser flags uqual msg +#else +showSDocForUser _flags uqual msg = GHC.showSDocForUser uqual msg +#endif + +showSDocDebug :: DynFlags -> MsgDoc -> String +#if __GLASGOW_HASKELL__ >= 706 +showSDocDebug flags msg = GHC.showSDocDebug flags msg +#else +showSDocDebug _flags msg = GHC.showSDocDebug msg +#endif + +queryQual :: PprStyle -> PrintUnqualified +#if __GLASGOW_HASKELL__ >= 710 +queryQual = GHC.queryQual +#else +queryQual style = (GHC.qualName style, GHC.qualModule style) +#endif + + +----------------------- +-- Debug +-- + +_debugPpContext :: DynFlags -> String -> Ghc () +_debugPpContext flags msg = do + context <- getContext + liftIO $ debug dVerbosity + $ msg ++ ": " ++ showSDocDebug flags (GHC.ppr context) diff --git a/Server.hs b/Server.hs new file mode 100644 --- /dev/null +++ b/Server.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, CPP #-} +-- | Implementation of the server that controls the long-running GHC instance. +-- This interacts with the ide-backend library through serialized data only. +module Server (ghcServer) where + +import Prelude hiding (mod, span) +import Control.Concurrent (ThreadId, throwTo, forkIO, myThreadId, threadDelay) +import Control.Concurrent.Async (async) +import Control.Concurrent.MVar (MVar, newEmptyMVar) +import Control.Monad (void, unless, when) +import Control.Monad.State (StateT, runStateT) +import Control.Monad.Trans.Class (lift) +import Data.Accessor (accessor, (.>)) +import Data.Accessor.Monad.MTL.State (set) +import Data.Function (on) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.C.Types (CFile) +import System.Environment (withArgs, getEnvironment) +import System.FilePath (()) +import System.IO (Handle, hFlush, hClose) +import System.IO.Temp (createTempDirectory, openTempFile) +import System.Mem (performGC) +import System.Posix (Fd) +import System.Posix.IO +import System.Posix.Files (createNamedPipe) +import System.Posix.Process (forkProcess, getProcessStatus) +import System.Posix.Types (ProcessID) +import qualified Control.Exception as Ex +import qualified Data.ByteString as BSS (hGetSome, hPut, null) +import qualified Data.List as List +import qualified Data.Text as Text +import qualified System.Directory as Dir + +import IdeSession.GHC.API +import IdeSession.RPC.Server +import IdeSession.Strict.Container +import IdeSession.Strict.IORef +import IdeSession.Types.Private +import IdeSession.Types.Progress +import IdeSession.Util +import IdeSession.Util.BlockingOps +import qualified IdeSession.Strict.List as StrictList +import qualified IdeSession.Strict.Map as StrictMap +import qualified IdeSession.Types.Public as Public + +import qualified GHC +import GhcMonad(Ghc(..)) +import qualified ObjLink as ObjLink +import qualified Linker as Linker +import Hooks + +import Run +import HsWalk +import Debug +import GhcShim + +foreign import ccall "fflush" fflush :: Ptr CFile -> IO () + +-------------------------------------------------------------------------------- +-- Server-side operations -- +-------------------------------------------------------------------------------- + +-- | Start the RPC server. Used from within the server executable. +ghcServer :: [String] -> IO () +ghcServer = rpcServer ghcServerEngine + +-- | The GHC server engine proper. +-- +-- This function runs in end endless loop inside the @Ghc@ monad, making +-- incremental compilation possible. +ghcServerEngine :: FilePath -> RpcConversation -> IO () +ghcServerEngine errorLog conv@RpcConversation{..} = do + -- The initial handshake with the client + (configGenerateModInfo, initOpts, sessionDir) <- handleInit conv + let distDir = ideSessionDistDir sessionDir + sourceDir = ideSessionSourceDir sessionDir + + -- Submit static opts and get back leftover dynamic opts. + dOpts <- submitStaticOpts initOpts + + -- Set up references for the current session of Ghc monad computations. + pluginRef <- newIORef StrictMap.empty + importsRef <- newIORef StrictMap.empty + stRef <- newIORef initExtractIdsSuspendedState + errsRef <- liftIO $ newIORef StrictList.nil + + -- Get environment on server startup so that we can restore it + initEnv <- getEnvironment + + -- Start handling requests. From this point on we don't leave the GHC monad. + runFromGhc $ do + -- Register startup options and perhaps our plugin in dynamic flags. + initSession distDir configGenerateModInfo dOpts errsRef stRef pluginRef progressCallback + + -- We store the DynFlags _after_ setting the "static" options, so that + -- we restore to this state before every call to updateDynamicOpts + -- Note that this happens _after_ we have called setSessionDynFlags + -- and hence after the package DB has been initialized. + storeDynFlags + + -- Make sure that the dynamic linker has been initialized. This is done + -- implicitly deep in the bowels of GhcMake.load, but if we attempt to load + -- C object files before calling GhcMake.load (i.e., before attempting to + -- compile any Haskell code) then loading the object files will fail if + -- they rely on linker flags such as @-lz@ (#214). + do dflags <- getSessionDynFlags + liftIO $ Linker.initDynLinker dflags + + -- Start handling RPC calls + let go args = do + req <- liftIO get + args' <- case req of + ReqCompile genCode targets -> do + ghcHandleCompile + conv pluginRef importsRef errsRef sourceDir + genCode targets configGenerateModInfo + return args + ReqRun runCmd -> do + (pid, stdin, stdout, errorLog') <- startConcurrentConversation sessionDir $ \_errorLog' conv' -> do + ghcWithArgs args $ ghcHandleRun conv' runCmd + liftIO $ put (pid, stdin, stdout, errorLog') + return args + ReqSetEnv env -> do + ghcHandleSetEnv conv initEnv env + return args + ReqSetArgs args' -> do + liftIO $ put () + return args' + ReqBreakpoint mod span value -> do + ghcHandleBreak conv mod span value + return args + ReqPrint vars bind forceEval -> do + ghcHandlePrint conv vars bind forceEval + return args + ReqLoad objects -> do + ghcHandleLoad errorLog conv objects + return args + ReqUnload objects -> do + ghcHandleUnload conv objects + return args + ReqSetGhcOpts opts -> do + ghcHandleSetOpts conv opts + return args + ReqCrash delay -> do + ghcHandleCrash delay + return args + go args' + + go [] + + where + progressCallback :: String -> IO () + progressCallback ghcMsg = do + let ghcMsg' = Text.pack ghcMsg + case parseProgressMessage ghcMsg' of + Right (step, numSteps, msg) -> + put $ GhcCompileProgress $ Progress { + progressStep = step + , progressNumSteps = numSteps + , progressParsedMsg = Just msg + , progressOrigMsg = Just ghcMsg' + } + _ -> + -- Ignore messages we cannot parse + return () + +-- Register startup options and perhaps our plugin in dynamic flags. +-- +-- This is the only place where the @packageDbArgs@ options are used +-- and indeed, as the first invocation of @setSessionDynFlags@, +-- this is the only place they could take any effect. +-- This also implies that any options specifying package DBs +-- passed via @updateGhcOptions@ won't have any effect in GHC API +initSession :: FilePath + -> Bool + -> DynamicOpts + -> StrictIORef (Strict [] SourceError) + -> StrictIORef ExtractIdsSuspendedState + -> StrictIORef (Strict (Map ModuleName) PluginResult) + -> (String -> IO ()) + -> Ghc () +initSession distDir modInfo dOpts errsRef stRef pluginRef callback = do + flags <- getSessionDynFlags + (flags', _, _) <- parseDynamicFlags flags $ dOpts ++ dynOpts + + let flags'' = (if modInfo then installHooks else id) + . installErrorLoggers + $ flags' + + void $ setSessionDynFlags flags'' + where + dynOpts :: DynamicOpts + dynOpts = optsToDynFlags [ + -- Just in case the user specified -hide-all-packages. + "-package ide-backend-rts" + + -- Include cabal_macros.h + , "-optP-include" + , "-optP" ++ cabalMacrosLocation distDir + ] + + installHooks :: DynFlags -> DynFlags + installHooks dflags = dflags { + hooks = (hooks dflags) { + hscFrontendHook = Just $ runHscPlugin pluginRef stRef + , runQuasiQuoteHook = Just $ runHscQQ stRef + , runRnSpliceHook = Just $ runRnSplice stRef + } + } + + installErrorLoggers :: DynFlags -> DynFlags + installErrorLoggers dflags = dflags { +#if __GLASGOW_HASKELL__ >= 706 + GHC.log_action = collectSrcError errsRef callback (\_ -> return ()) -- TODO: log? +#else + GHC.log_action = collectSrcError errsRef callback (\_ -> return ()) dflags +#endif + } + +startConcurrentConversation :: FilePath -> (FilePath -> RpcConversation -> Ghc ()) -> Ghc (ProcessID, FilePath, FilePath, FilePath) +startConcurrentConversation sessionDir server = do + -- Ideally, we'd have the child process create the temp directory and + -- communicate the name back to us, so that the child process can remove the + -- directories again when it's done with it. However, this means we need some + -- interprocess communication, which is awkward. So we create the temp + -- directory here; I suppose we could still delegate the responsibility of + -- deleting the directory to the child, but instead we'll just remove the + -- directory along with the rest of the session temp dirs on session exit. + (stdin, stdout, errorLog) <- liftIO $ do + tempDir <- createTempDirectory sessionDir "rpc." + let stdin = tempDir "stdin" + stdout = tempDir "stdout" + + createNamedPipe stdin 0o600 + createNamedPipe stdout 0o600 + + tmpDir <- Dir.getTemporaryDirectory + (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc-snippet-.log" + hClose errorLogHandle + + return (stdin, stdout, errorLogPath) + + -- Start the concurrent conversion. We use forkGhcProcess rather than forkGhc + -- because we need to change global state in the child process; in particular, + -- we need to redirect stdin, stdout, and stderr (as well as some other global + -- state, including withArgs). + liftIO $ performGC + processId <- forkGhcProcess $ ghcConcurrentConversation stdin stdout errorLog server + + -- We wait for the process to finish in a separate thread so that we do not + -- accumulate zombies + liftIO $ void $ forkIO $ + void $ getProcessStatus True False processId + + return (processId, stdin, stdout, errorLog) + +-- | We cache our own "module summaries" in between compile requests +data ModSummary = ModSummary { + -- | We cache the import lists so that we can check if the import + -- list for this module has changed, and hence whether we need to recompute + -- autocompletion info + modImports :: !(Strict [] Import) + -- | We cache the file stamp to see if the file has changed at all, and + -- hence whether we need to recompute the import list + , modTimestamp :: !GhcTime + -- | We cache whether this module was reported as "loaded" before so that + -- we can see which modules got unloaded + , modIsLoaded :: !Bool + } + +-- | Client handshake +handleInit :: RpcConversation -> IO (Bool, [String], FilePath) +handleInit RpcConversation{..} = do + GhcInitRequest{..} <- get + + -- Check API versions + unless (ghcInitClientApiVersion == ideBackendApiVersion) $ + Ex.throwIO . userError $ "API version mismatch between ide-backend " + ++ "(" ++ show ghcInitClientApiVersion ++ ") " + ++ "and ide-backend-server " + ++ "(" ++ show ideBackendApiVersion ++ ")" + + -- Return initialization result to the client + put GhcInitResponse { + ghcInitVersion = ghcGetVersion + } + + -- Setup parameters for the server + return ( ghcInitGenerateModInfo + , ghcInitOpts ++ + packageDBFlags ghcInitUserPackageDB ghcInitSpecificPackageDBs + , ghcInitSessionDir + ) + +-- | Handle a compile or type check request +ghcHandleCompile + :: RpcConversation + -> StrictIORef (Strict (Map ModuleName) PluginResult) + -- ^ ref where the ExtractIdsT plugin stores its data + -- (We clear this at the end of each call) + -> StrictIORef (Strict (Map ModuleName) ModSummary) + -- ^ see doc for 'ModSummary' + -> StrictIORef (Strict [] SourceError) + -- ^ the IORef where GHC stores errors + -> FilePath -- ^ source directory + -> Bool -- ^ should we generate code + -> Public.Targets -- ^ targets + -> Bool -- ^ should we generate per-module info + -> Ghc () +ghcHandleCompile RpcConversation{..} + pluginRef modsRef errsRef configSourcesDir + ideGenerateCode targets configGenerateModInfo = do + -- | Half of a workaround for + -- http://hackage.haskell.org/trac/ghc/ticket/7456. We suppress stdout + -- during compilation to avoid stray messages, e.g. from the linker. + -- + -- TODO: Should we log the suppressed messages? + (_suppressed, (errs, loadedModules, fileMap)) <- + captureGhcOutput $ compileInGhc configSourcesDir + ideGenerateCode + targets + errsRef + + let initialResponse = GhcCompileResult { + ghcCompileErrors = errs + , ghcCompileLoaded = force $ loadedModules + , ghcCompileFileMap = fileMap + , ghcCompileCache = error "ghcCompileCache set last" + -- We construct the diffs incrementally + , ghcCompileImports = StrictMap.empty + , ghcCompileAuto = StrictMap.empty + , ghcCompilePkgDeps = StrictMap.empty + , ghcCompileSpanInfo = StrictMap.empty + , ghcCompileExpTypes = StrictMap.empty + , ghcCompileUseSites = StrictMap.empty + } + + response <- if not configGenerateModInfo + then return initialResponse + else do + pluginIdMaps <- liftIO $ do + idMaps <- readIORef pluginRef + writeIORef pluginRef StrictMap.empty + return idMaps + + let recompiledModules :: [ModuleName] + recompiledModules = StrictMap.keys pluginIdMaps + + -- Strictly speaking, this check is not entirely accurate, because + -- we ignore the package of the imported module. However, I don't + -- think this can lead to actual problems, because if modules + -- between packages overlap this will cause trouble elsewhere. + gotRecompiled :: Import -> Bool + gotRecompiled imp = + moduleName (importModule imp) `elem` recompiledModules + + removeOldModule :: ModuleName -> StateT GhcCompileResult Ghc () + removeOldModule m = do + set (importsFor m) Remove + set (autoFor m) Remove + set (spanInfoFor m) Remove + set (expTypesFor m) Remove + set (useSitesFor m) Remove + set (pkgDepsFor m) Remove + + addNewModule :: (ModuleName, GHC.ModSummary) + -> StateT GhcCompileResult Ghc (ModuleName, ModSummary) + addNewModule (m, ghcSummary) = do + imports <- lift $ importList ghcSummary + auto <- lift $ autocompletion ghcSummary + set (importsFor m) (Insert imports) + set (autoFor m) (Insert auto) + -- Information computed by the plugin set separately + + let newSummary = ModSummary { + modTimestamp = ms_hs_date ghcSummary + , modImports = imports + , modIsLoaded = m `elem` loadedModules + } + + return (m, newSummary) + + updateSourceFile :: ModuleName -> ModSummary -> GHC.ModSummary + -> StateT GhcCompileResult Ghc (ModuleName, ModSummary) + updateSourceFile m oldSummary ghcSummary = do + (imports, importsChanged) <- + -- We recompute imports when the file changed, rather than when + -- it got (successfully) recompiled because we provide the + -- imports even for modules with type errors + if modTimestamp oldSummary == ms_hs_date ghcSummary + then return (modImports oldSummary, False) + else do imports <- lift $ importList ghcSummary + set (importsFor m) (Insert imports) + return (imports, imports /= modImports oldSummary) + + -- We recompute autocompletion info if the imported modules have + -- been recompiled. TODO: We might be able to optimize this by + -- checking one of ghc's various hashes to avoid recomputing + -- autocompletion info even if an imported module got recompiled, + -- but it's interface did not change (`mi_iface_hash` perhaps?) + -- TODO: We might also be able to make this check more fine + -- grained and recompute autocompletion info for some imports, + -- but not for others. + when (importsChanged || StrictList.any gotRecompiled imports) $ do + auto <- lift $ autocompletion ghcSummary + set (autoFor m) (Insert auto) + + let newSummary = ModSummary { + modTimestamp = ms_hs_date ghcSummary + , modImports = imports + , modIsLoaded = m `elem` loadedModules + } + + when (not (modIsLoaded newSummary)) $ do + set (spanInfoFor m) Remove + set (pkgDepsFor m) Remove + set (expTypesFor m) Remove + set (useSitesFor m) Remove + + return (m, newSummary) + + let go :: [(ModuleName, ModSummary)] + -> [(ModuleName, GHC.ModSummary)] + -> StateT GhcCompileResult Ghc [(ModuleName, ModSummary)] + go ((m, oldSummary) : old) ((m', ghcSummary) : new) = do + case compare m m' of + LT -> do removeOldModule m + go old ((m', ghcSummary) : new) + GT -> do newSummary <- addNewModule (m', ghcSummary) + newSummaries <- go ((m, oldSummary) : old) new + return $ newSummary : newSummaries + EQ -> do newSummary <- updateSourceFile m oldSummary ghcSummary + newSummaries <- go old new + return $ newSummary : newSummaries + go old new = do + mapM_ removeOldModule (map fst old) + mapM addNewModule new + + let sendPluginResult :: [(ModuleName, PluginResult)] + -> StateT GhcCompileResult Ghc () + sendPluginResult = mapM_ $ \(m, PluginResult{..}) -> do + set (spanInfoFor m) (Insert pluginIdList) + set (pkgDepsFor m) (Insert pluginPkgDeps) + set (expTypesFor m) (Insert pluginExpTypes) + set (useSitesFor m) (Insert pluginUseSites) + + (newSummaries, finalResponse) <- flip runStateT initialResponse $ do + sendPluginResult (StrictMap.toList pluginIdMaps) + + graph <- lift $ getModuleGraph + let name s = Text.pack (moduleNameString (ms_mod_name s)) + namedGraph = map (\s -> (name s, s)) graph + sortedGraph = List.sortBy (compare `on` fst) namedGraph + oldSummaries <- lift . liftIO $ readIORef modsRef + go (StrictMap.toList oldSummaries) sortedGraph + + liftIO $ writeIORef modsRef (StrictMap.fromList newSummaries) + return finalResponse + + cache <- liftIO $ constructExplicitSharingCache + let fullResponse = response { ghcCompileCache = cache } + + -- TODO: Should we clear the link env caches here? + liftIO $ put (GhcCompileDone fullResponse) + where + -- Various accessors + allImports = accessor ghcCompileImports (\is st -> st { ghcCompileImports = is }) + allAuto = accessor ghcCompileAuto (\as st -> st { ghcCompileAuto = as }) + allSpanInfo = accessor ghcCompileSpanInfo (\ss st -> st { ghcCompileSpanInfo = ss }) + allPkgDeps = accessor ghcCompilePkgDeps (\ds st -> st { ghcCompilePkgDeps = ds }) + allExpTypes = accessor ghcCompileExpTypes (\ts st -> st { ghcCompileExpTypes = ts }) + allUseSites = accessor ghcCompileUseSites (\us st -> st { ghcCompileUseSites = us }) + + importsFor m = allImports .> StrictMap.accessorDefault Keep m + autoFor m = allAuto .> StrictMap.accessorDefault Keep m + spanInfoFor m = allSpanInfo .> StrictMap.accessorDefault Keep m + pkgDepsFor m = allPkgDeps .> StrictMap.accessorDefault Keep m + expTypesFor m = allExpTypes .> StrictMap.accessorDefault Keep m + useSitesFor m = allUseSites .> StrictMap.accessorDefault Keep m + +-- | Handle a break request +ghcHandleBreak :: RpcConversation -> ModuleName -> Public.SourceSpan -> Bool -> Ghc () +ghcHandleBreak RpcConversation{..} modName span value = do + oldValue <- breakFromSpan modName span value + liftIO $ put oldValue + +-- | Handle a print request +ghcHandlePrint :: RpcConversation -> Public.Name -> Bool -> Bool -> Ghc () +ghcHandlePrint RpcConversation{..} var bind forceEval = do + vals <- printVars (Text.unpack var) bind forceEval + liftIO $ put vals + +-- | Handle a load object request +ghcHandleLoad :: FilePath -> RpcConversation -> [FilePath] -> Ghc () +ghcHandleLoad errorLog RpcConversation{..} objects = + liftIO $ do + -- If loadObj fails, it fails with a hard crash (not an exception) and + -- hence we cannot capture the output. Instead, we redirect it to the + -- error log so that if the crash does happen, the RPC infastructure + -- will read this log file and use its constents to report an error. + redirectStderr errorLog $ mapM_ ObjLink.loadObj objects + + -- Although resolveObjs does _not_ fail quite so spectacularly, it still + -- writes its error messages to stdout. + (suppressed, success) <- captureOutput $ ObjLink.resolveObjs + let response :: Maybe String + response = + case success of + GHC.Failed -> Just suppressed + GHC.Succeeded -> Nothing + put response + +-- | Handle an unload object request +ghcHandleUnload :: RpcConversation -> [FilePath] -> Ghc () +ghcHandleUnload RpcConversation{..} objects = liftIO $ do + mapM_ ObjLink.unloadObj objects + put () + +-- | Handle a run request +ghcHandleRun :: RpcConversation -> RunCmd -> Ghc () +ghcHandleRun RpcConversation{..} runCmd = do + (stdOutputRd, stdOutputBackup, stdErrorBackup) <- redirectStdout + (stdInputWr, stdInputBackup) <- redirectStdin + + -- We don't need to keep a reference to the reqThread: when the snippet + -- terminates, the whole server process terminates with it and hence + -- so does the reqThread. If we wanted to reuse this server process we + -- would need to have some sort of handshake so make sure that the client + -- and the server both agree that further requests are no longer accepted + -- (we used to do that when we ran snippets inside the main server process). + ghcThread <- liftIO newEmptyMVar :: Ghc (MVar (Maybe ThreadId)) + _reqThread <- liftIO . async $ readRunRequests ghcThread stdInputWr + stdoutThread <- liftIO . async $ readStdout stdOutputRd + + -- This is a little tricky. We only want to deliver the UserInterrupt + -- exceptions when we are running 'runInGhc'. If the UserInterrupt arrives + -- before we even get a chance to call 'runInGhc' the exception should not + -- be delivered until we are in a position to catch it; after 'runInGhc' + -- completes we should just ignore any further 'GhcRunInterrupt' requests. + -- + -- We achieve this by + -- + -- 1. The thread ID is stored in an MVar ('ghcThread'). Initially this + -- MVar is empty, so if a 'GhcRunInterrupt' arrives before we are ready + -- to deal with it the 'reqThread' will block + -- 2. We install an exception handler before putting the thread ID into + -- the MVar + -- 3. We override the MVar with Nothing before leaving the exception handler + -- 4. In the 'reqThread' we ignore GhcRunInterrupts once the 'MVar' is + -- 'Nothing' + + runOutcome <- ghandle ghcException . ghandleJust isUserInterrupt return $ + GHC.gbracket + (liftIO (myThreadId >>= $putMVar ghcThread . Just)) + (\() -> liftIO $ $modifyMVar_ ghcThread (\_ -> return Nothing)) + (\() -> runInGhc runCmd) + + liftIO $ do + -- Make sure the C buffers are also flushed before swapping the handles + fflush nullPtr + + -- Restore stdin and stdout + dupTo stdOutputBackup stdOutput >> closeFd stdOutputBackup + dupTo stdErrorBackup stdError >> closeFd stdErrorBackup + dupTo stdInputBackup stdInput >> closeFd stdInputBackup + + -- Closing the write end of the stdout pipe will cause the stdout + -- thread to terminate after it processed all remaining output; + -- wait for this to happen + $wait stdoutThread + + -- Report the final result + liftIO $ debug dVerbosity $ "returned from ghcHandleRun with " + ++ show runOutcome + put $ GhcRunDone runOutcome + where + -- Wait for and execute run requests from the client + readRunRequests :: MVar (Maybe ThreadId) -> Handle -> IO () + readRunRequests ghcThread stdInputWr = + let go = do request <- get + case request of + GhcRunInterrupt -> do + $withMVar ghcThread $ \mTid -> do + case mTid of + Just tid -> throwTo tid Ex.UserInterrupt + Nothing -> return () -- See above + go + GhcRunInput bs -> do + BSS.hPut stdInputWr bs + hFlush stdInputWr + go + in go + + -- Wait for the process to output something or terminate + readStdout :: Handle -> IO () + readStdout stdOutputRd = + let go = do bs <- BSS.hGetSome stdOutputRd blockSize + unless (BSS.null bs) $ put (GhcRunOutp bs) >> go + in go + + -- Turn an asynchronous exception into a RunResult + isUserInterrupt :: Ex.AsyncException -> Maybe RunResult + isUserInterrupt ex@Ex.UserInterrupt = + Just . RunProgException . showExWithClass . Ex.toException $ ex + isUserInterrupt _ = + Nothing + + -- Turn a GHC exception into a RunResult + ghcException :: GhcException -> Ghc RunResult + ghcException = return . RunGhcException . show + + -- TODO: What is a good value here? + blockSize :: Int + blockSize = 4096 + + -- Setup loopback pipe so we can capture runStmt's stdout/stderr + redirectStdout :: Ghc (Handle, Fd, Fd) + redirectStdout = liftIO $ do + -- Create pipe + (stdOutputRd, stdOutputWr) <- liftIO createPipe + + -- Backup stdout, then replace stdout and stderr with the pipe's write end + stdOutputBackup <- liftIO $ dup stdOutput + stdErrorBackup <- liftIO $ dup stdError + _ <- dupTo stdOutputWr stdOutput + _ <- dupTo stdOutputWr stdError + closeFd stdOutputWr + + -- Convert to the read end to a handle and return + stdOutputRd' <- fdToHandle stdOutputRd + return (stdOutputRd', stdOutputBackup, stdErrorBackup) + + -- Setup loopback pipe so we can write to runStmt's stdin + redirectStdin :: Ghc (Handle, Fd) + redirectStdin = liftIO $ do + -- Create pipe + (stdInputRd, stdInputWr) <- liftIO createPipe + + -- Swizzle stdin + stdInputBackup <- liftIO $ dup stdInput + _ <- dupTo stdInputRd stdInput + closeFd stdInputRd + + -- Convert the write end to a handle and return + stdInputWr' <- fdToHandle stdInputWr + return (stdInputWr', stdInputBackup) + +-- | Handle a set-environment request +ghcHandleSetEnv :: RpcConversation -> [(String, String)] -> [(String, Maybe String)] -> Ghc () +ghcHandleSetEnv RpcConversation{put} initEnv overrides = liftIO $ do + setupEnv initEnv overrides + put () + +-- | Set ghc options +ghcHandleSetOpts :: RpcConversation -> [String] -> Ghc () +ghcHandleSetOpts RpcConversation{put} opts = do + (leftover, warnings) <- setGhcOptions opts + liftIO $ put (leftover, warnings) + +-- | Handle a crash request (debugging) +ghcHandleCrash :: Maybe Int -> Ghc () +ghcHandleCrash delay = liftIO $ do + case delay of + Nothing -> Ex.throwIO crash + Just i -> do tid <- myThreadId + void . forkIO $ threadDelay i >> throwTo tid crash + where + crash = userError "Intentional crash" + +-------------------------------------------------------------------------------- +-- Auxiliary -- +-------------------------------------------------------------------------------- + +-- | Generalization of captureOutput +captureGhcOutput :: Ghc a -> Ghc (String, a) +captureGhcOutput = unsafeLiftIO captureOutput + +-- | Lift operations on `IO` to the `Ghc` monad. This is unsafe as it makes +-- operations possible in the `Ghc` monad that weren't possible before +-- (for instance, @unsafeLiftIO forkIO@ is probably a bad idea!). +unsafeLiftIO :: (IO a -> IO b) -> Ghc a -> Ghc b +unsafeLiftIO f (Ghc ghc) = Ghc $ \session -> f (ghc session) + +-- | Generalization of 'unsafeLiftIO' +_unsafeLiftIO1 :: ((c -> IO a) -> IO b) -> (c -> Ghc a) -> Ghc b +_unsafeLiftIO1 f g = Ghc $ \session -> + f $ \c -> case g c of Ghc ghc -> ghc session + +-- | Generalization of 'unsafeLiftIO' +-- +-- TODO: Is there a more obvious way to define this progression? +unsafeLiftIO2 :: ((c -> d -> IO a) -> IO b) -> (c -> d -> Ghc a) -> Ghc b +unsafeLiftIO2 f g = Ghc $ \session -> + f $ \c d -> case g c d of Ghc ghc -> ghc session + +-- | Lift `withArgs` to the `Ghc` monad. Relies on `unsafeLiftIO`. +ghcWithArgs :: [String] -> Ghc a -> Ghc a +ghcWithArgs = unsafeLiftIO . withArgs + +-- | Fork within the `Ghc` monad. Use with caution. +_forkGhc :: Ghc () -> Ghc ThreadId +_forkGhc = unsafeLiftIO forkIO + +-- | forkProcess within the `Ghc` monad. Use with extreme caution. +forkGhcProcess :: Ghc () -> Ghc ProcessID +forkGhcProcess = unsafeLiftIO forkProcess + +-- | Lifted version of concurrentConversation +ghcConcurrentConversation :: FilePath + -> FilePath + -> FilePath + -> (FilePath -> RpcConversation -> Ghc ()) + -> Ghc () +ghcConcurrentConversation requestR responseW errorLog = + unsafeLiftIO2 (concurrentConversation requestR responseW errorLog) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TraceMonad.hs b/TraceMonad.hs new file mode 100644 --- /dev/null +++ b/TraceMonad.hs @@ -0,0 +1,37 @@ +module TraceMonad where + +import qualified Debug.Trace + +import GHC +import MonadUtils + +class Monad m => TraceMonad m where + trace :: String -> m () + +traceBlock :: TraceMonad m => String -> m a -> m a +traceBlock str act = do + trace $ "BKB " ++ str + result <- act + trace $ "BKA " ++ str + return result + +traceBlock' :: TraceMonad m => String -> ((m a -> m a) -> m a) -> m a +traceBlock' str act = traceBlock str $ act (traceBlock "-") + +instance TraceMonad IO where + trace = Debug.Trace.traceEventIO + +instance TraceMonad Ghc where + trace = liftIO . trace + +-- | We cannot declare that every monad that implements MonadIO also +-- implements MonadTrace, so we provide a special function for this case +-- *mumbles hackhackhackhack..* +traceBlockIO :: MonadIO m => String -> m a -> m a +traceBlockIO str act = do + liftIO $ trace $ "BKB " ++ str + result <- act + liftIO $ trace $ "BKA " ++ str + return result + + diff --git a/ide-backend-server.cabal b/ide-backend-server.cabal new file mode 100644 --- /dev/null +++ b/ide-backend-server.cabal @@ -0,0 +1,91 @@ +name: ide-backend-server +version: 0.9.0 +synopsis: An IDE backend server +description: Server executable used internally by the ide-backend library. +license: MIT +license-file: LICENSE +author: Duncan Coutts, Mikolaj Konarski, Edsko de Vries +maintainer: Duncan Coutts +copyright: (c) 2015 FP Complete +category: Development +build-type: Simple +cabal-version: >=1.10 + +executable ide-backend-server + main-is: ide-backend-server.hs + other-modules: IdPropCaching + Server + Debug + HsWalk + Break + FilePathCaching + Run + Conv + TraceMonad + Haddock + GhcShim.GhcShim742 + GhcShim.API + GhcShim.GhcShim78 + GhcShim.GhcShim710 + GhcShim + build-depends: base < 10, + ghc == 7.4.* || == 7.8.* || == 7.10.*, + containers >= 0.4.1 && < 1, + bytestring >= 0.9.2 && < 1, + data-accessor >= 0.2 && < 0.3, + data-accessor-mtl >= 0.2 && < 0.3, + async >= 2.0 && < 2.1, + unix >= 2.5 && < 2.8, + text >= 0.11 && < 1.3, + directory >= 1.1 && < 1.3, + filepath >= 1.3 && < 1.5, + process >= 1.1 && < 1.3, + transformers >= 0.3 && < 0.5, + -- mtl 2.2 is broken + mtl == 2.1.* || (>= 2.2.1 && < 2.3), + unordered-containers >= 0.2.3 && < 0.3, + filemanip >= 0.3.6.2 && < 0.4, + array >= 0.4 && < 0.6, + temporary >= 1.1.2.4 && < 1.3, + ide-backend-common >= 0.9 && < 0.10 + + -- The standard macros don't give us 7.6.x granularity + -- We _could_ add support for 7.6, 7.6.1 specifically is broken (#7548) + if impl(ghc == 7.6.1) + cpp-options: -DGHC_761 + + if impl(ghc == 7.4.2.*) + build-depends: old-time >= 1.1 && < 1.2, + haddock >= 2.11 && < 2.12, + -- use whatever version came with ghc + Cabal + cpp-options: -DGHC_742 + if impl(ghc == 7.8.*) + build-depends: time == 1.4.*, + haddock-api == 2.15.*, + -- use whatever version came with ghc + Cabal + cpp-options: -DGHC_78 + ghc-options: -dynamic + if impl(ghc == 7.10.*) + build-depends: time == 1.5.*, + haddock-api == 2.16.*, + -- although from 7.10 basic datatypes are defined in + -- bin-package-db rather than Cabal, we still need Cabal for + -- parsing functionality; use whatever version came with ghc + Cabal + cpp-options: -DGHC_710 + ghc-options: -dynamic + + default-language: Haskell2010 + default-extensions: MonoLocalBinds, + BangPatterns, RecordWildCards, NamedFieldPuns + other-extensions: TemplateHaskell + + ghc-options: -Wall + -threaded + -rtsopts + -- use the compacting GC: + -with-rtsopts=-c + -- disable idle GC + -with-rtsopts=-I0 diff --git a/ide-backend-server.hs b/ide-backend-server.hs new file mode 100644 --- /dev/null +++ b/ide-backend-server.hs @@ -0,0 +1,7 @@ +module Main where + +import System.Environment (getArgs) +import Server (ghcServer) + +main :: IO () +main = getArgs >>= ghcServer