ide-backend-server (empty) → 0.9.0
raw patch · 19 files changed
+7373/−0 lines, 19 filesdep +Cabaldep +arraydep +asyncsetup-changed
Dependencies added: Cabal, array, async, base, bytestring, containers, data-accessor, data-accessor-mtl, directory, filemanip, filepath, ghc, haddock, haddock-api, ide-backend-common, mtl, old-time, process, temporary, text, time, transformers, unix, unordered-containers
Files
- Break.hs +164/−0
- Conv.hs +72/−0
- Debug.hs +24/−0
- FilePathCaching.hs +60/−0
- GhcShim.hs +56/−0
- GhcShim/API.hs +51/−0
- GhcShim/GhcShim710.hs +1654/−0
- GhcShim/GhcShim742.hs +1359/−0
- GhcShim/GhcShim78.hs +1621/−0
- Haddock.hs +176/−0
- HsWalk.hs +596/−0
- IdPropCaching.hs +58/−0
- LICENSE +21/−0
- Run.hs +609/−0
- Server.hs +715/−0
- Setup.hs +2/−0
- TraceMonad.hs +37/−0
- ide-backend-server.cabal +91/−0
- ide-backend-server.hs +7/−0
+ Break.hs view
@@ -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)+
+ Conv.hs view
@@ -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)
+ Debug.hs view
@@ -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
+ FilePathCaching.hs view
@@ -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
+ GhcShim.hs view
@@ -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
+ GhcShim/API.hs view
@@ -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
+ GhcShim/GhcShim710.hs view
@@ -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" <<warning only>>+ > "fvia-c" <<warning only>>+ > "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" <<warning only>>+ > "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 "<typecheck only>")++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 <span>", where+ -- both "assertError" and the "<span>" are assigned the source span of+ -- the original "assert". This means that the <span> (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 <no location info> 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
+ GhcShim/GhcShim742.hs view
@@ -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" <<warning only>>+ > "fvia-c" <<warning only>>+ > "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" <<warning only>>+ > "keep-raw-s-files" <<warning only>>+ > "keep-s-file" setDynFlag+ > "keep-s-files" setDynFlag+ > "keep-tmp-files" setDynFlag+ > "l" addOptl+ > "main-is" setMainIs+ > "monly-2-regs" <<warning only>>+ > "monly-3-regs" <<warning only>>+ > "monly-4-regs" <<warning only>>+ > "msse2" setDynFlag+ > "msse4.2" setDynFlag+ > "n" <<warning only>>+ > "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" <<warning only>>+ > "optdep-x" addDepExcludeMod+ > "optl" addOptl+ > "optlc" alterSettings+ > "optlo" alterSettings+ > "optm" <<warning only>>+ > "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" <<warning only>>+ > "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+-- <http://www.haskell.org/ghc/docs/7.4.2/html/libraries/ghc/Module.html#g:3>+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 "<typecheck only>")++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 <span>", where+ -- both "assertError" and the "<span>" are assigned the source span of+ -- the original "assert". This means that the <span> (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 <no location info> 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
+ GhcShim/GhcShim78.hs view
@@ -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" <<warning only>>+ > "fvia-c" <<warning only>>+ > "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" <<warning only>>+ > "keep-raw-s-files" <<warning only>>+ > "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" <<warning only>>+ > "monly-3-regs" <<warning only>>+ > "monly-4-regs" <<warning only>>+ > "msse" ** sets sseVersion+ > "n" <<warning only>>+ > "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" <<warning only>>+ > "optdep-x" addDepExcludeMod+ > "optl" addOptl+ > "optlc" alterSettings+ > "optlo" alterSettings+ > "optm" <<warning only>>+ > "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" <<warning only>>+ > "pgms" alterSettings+ > "pgmwindres" alterSettings+ > "prof" addWay+ > "rdynamic" <<does nothing>>+ > "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+-- <http://www.haskell.org/ghc/docs/7.8.3/html/libraries/ghc/Module.html#g:3>+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 "<typecheck only>")++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 <span>", where+ -- both "assertError" and the "<span>" are assigned the source span of+ -- the original "assert". This means that the <span> (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 <no location info> 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
+ Haddock.hs view
@@ -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
+ HsWalk.hs view
@@ -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
+ IdPropCaching.hs view
@@ -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+ }
+ LICENSE view
@@ -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.
+ Run.hs view
@@ -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 $ "<from GhcException>"+ 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 "<no location info>"++ 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)
+ Server.hs view
@@ -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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TraceMonad.hs view
@@ -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++
+ ide-backend-server.cabal view
@@ -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 <duncan@well-typed.com>+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
+ ide-backend-server.hs view
@@ -0,0 +1,7 @@+module Main where++import System.Environment (getArgs)+import Server (ghcServer)++main :: IO ()+main = getArgs >>= ghcServer