{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, StandaloneDeriving, MultiParamTypeClasses, GADTs #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-} module GhcShim.GhcShim78 ( -- * Pretty-printing showSDoc , pretty , prettyM , prettyType , prettyTypeM -- * Errors , sourceErrorSpan -- * Breakpoints , getBreak , setBreak -- * Time , GhcTime -- * Setup , ghcGetVersion , packageDBFlags , setGhcOptions , storeDynFlags -- * Package keys (see GhcShim.hs). , PackageKey , PackageQualifier , lookupPackage , mainPackageKey , modulePackageKey , packageKeyString , stringToPackageKey , packageKeyToSourceId , findExposedModule -- * Folding , AstAlg(..) , fold -- * Operations on types , typeOfTyThing -- * Re-exports , tidyOpenType ) where import Prelude hiding (id, span) import Control.Monad (void, forM_, liftM) import Data.IORef import Data.Time (UTCTime) import Data.Version import System.IO.Unsafe (unsafePerformIO) import qualified Data.Maybe as Maybe import Bag import BasicTypes hiding (Version) import ConLike (ConLike(RealDataCon)) import DataCon (dataConRepType) import DynFlags import ErrUtils import FastString import GHC hiding (getBreak) import Linker import Module import MonadUtils import Outputable hiding (showSDoc) import PackageConfig (PackageConfig) import Pair import PprTyThing import Pretty import SrcLoc import TcEvidence import TcHsSyn import TcType import Type import TysWiredIn import qualified BreakArray import qualified Packages import qualified Distribution.Package as Cabal import qualified Distribution.InstalledPackageInfo as Cabal import qualified Distribution.Text as Cabal import qualified Distribution.Compat.ReadP as Cabal import GhcShim.API import IdeSession.GHC.API (GhcVersion(..)) {------------------------------------------------------------------------------ Pretty-printing ------------------------------------------------------------------------------} showSDoc :: DynFlags -> PprStyle -> SDoc -> String showSDoc dflags pprStyle doc = showDoc OneLineMode 100 $ runSDoc doc $ initSDocContext dflags pprStyle pretty :: Outputable a => DynFlags -> PprStyle -> a -> String pretty dynFlags pprStyle = showSDoc dynFlags pprStyle . ppr prettyType :: DynFlags -> PprStyle -> Bool -> Type -> String prettyType dynFlags pprStyle showForalls typ = showSDoc dynFlags' pprStyle (pprTypeForUser typ) where dynFlags' :: DynFlags dynFlags' | showForalls = dynFlags `gopt_set` Opt_PrintExplicitForalls | otherwise = dynFlags `gopt_unset` Opt_PrintExplicitForalls prettyM :: (Outputable a, Monad m, HasDynFlags m) => PprStyle -> a -> m String prettyM pprStyle x = do dynFlags <- getDynFlags return (pretty dynFlags pprStyle x) prettyTypeM :: (Monad m, HasDynFlags m) => PprStyle -> Bool -> Type -> m String prettyTypeM pprStyle showForalls typ = do dynFlags <- getDynFlags return $ prettyType dynFlags pprStyle showForalls typ {------------------------------------------------------------------------------ Show instances ------------------------------------------------------------------------------} deriving instance Show Severity {------------------------------------------------------------------------------ Source errors ------------------------------------------------------------------------------} sourceErrorSpan :: ErrMsg -> Maybe SrcSpan sourceErrorSpan errMsg = case errMsgSpan errMsg of real@RealSrcSpan{} -> Just real _ -> Nothing {------------------------------------------------------------------------------ Breakpoints ------------------------------------------------------------------------------} getBreak :: BreakArray -> Int -> Ghc (Maybe Bool) getBreak array index = do dflags <- getDynFlags val <- liftIO $ BreakArray.getBreak dflags array index return ((== 1) `liftM` val) setBreak :: BreakArray -> Int -> Bool -> Ghc () setBreak array index value = do dflags <- getDynFlags void . liftIO $ if value then BreakArray.setBreakOn dflags array index else BreakArray.setBreakOff dflags array index {------------------------------------------------------------------------------ Time ------------------------------------------------------------------------------} type GhcTime = UTCTime {------------------------------------------------------------------------------ Setup ------------------------------------------------------------------------------} ghcGetVersion :: GhcVersion ghcGetVersion = GHC_7_8 packageDBFlags :: Bool -> [String] -> [String] packageDBFlags userDB specificDBs = ["-no-user-package-db" | not userDB] ++ concat [["-package-db", db] | db <- specificDBs] -- | Set GHC options -- -- This is meant to be stateless. It is important to call storeDynFlags at least -- once before calling setGhcOptions so that we know what state to restore to -- before setting the options. -- -- Returns unrecognized options and warnings setGhcOptions :: [String] -> Ghc ([String], [String]) setGhcOptions opts = do dflags <- restoreDynFlags (dflags', leftover, warnings) <- parseDynamicFlags dflags (map noLoc opts) setupLinkerState =<< setSessionDynFlags dflags' return (map unLoc leftover, map unLoc warnings) -- | Setup linker state to deal with changed package flags -- -- This follows newDynFlags in ghci, except that in 7.8 there is also the -- notion of "interactive dynflags", which we are ignoring completely. -- I'm not sure if that's ok or not. setupLinkerState :: [PackageId] -> Ghc () setupLinkerState newPackages = do dflags <- getSessionDynFlags setTargets [] load LoadAllTargets liftIO $ linkPackages dflags newPackages {------------------------------------------------------------------------------ Backup DynFlags Sadly, this hardcodes quite a bit of version-specific information about ghc's inner workings. Unfortunately, there is no easy way to know which parts of DynFlags should and should not be restored to restore flags. The flag specification is given by (see packageDynamicFlags in compiler/main/GHC.hs) > package_flags ++ dynamic_flags both of which are defined in DynFlags.hs. They are not exported, but this would not be particularly useful anyway, as the action associated with a flag is given by a shallow embedding, so we cannot walk over them and extract the necessary info about DynFlags. At least, we cannot do that in code -- we can do it manually, and that is precisely what I've done to obtain the list below. Of course, this means it's somewhat error prone. In order so that this code can be audited and cross-checked against the actual ghc version, and so that it can be modified for future ghc versions, we don't just list the end result if this manual traversal, but document the process. Each of the command line options are defined in terms of a auxiliary functions that specify their effect on DynFlags. These auxiliary functions are listed below, along with which parts of DynFlags they modify: > FUNCTION MODIFIES FIELD(s) OF DYNFLAGS > ---------------------------------------------------------------------------- > addCmdlineFramework cmdlineFrameworks > addCmdlineHCInclude cmdlineHcIncludes > addDepExcludeMod depExcludeMods > addDepSuffix depSuffixes > addFrameworkPath frameworkPaths > addGhciScript ghciScripts > addHaddockOpts haddockOptions > addImportPath importPaths > addIncludePath includePaths > addLdInputs ldInputs > addLibraryPath libraryPaths > addOptP settings > addOptc settings > addOptl settings > addPkgConfRef extraPkgConfs > addPluginModuleName pluginModNames > addPluginModuleNameOption pluginModNameOpts > addWay ways, packageFlags, extensions, extensionFlags, generalFlags > alterSettings settings > clearPkgConf extraPkgConfs > disableGlasgowExts generalFlags, extensions, extensionFlags > distrustPackage packageFlags > enableGlasgowExts generalFlags, extensions, extensionFlags > exposePackage packageFlags > exposePackageId packageFlags > forceRecompile generalFlags > hidePackage packageFlags > ignorePackage packageFlags > parseDynLibLoaderMode dynLibLoader > removeGlobalPkgConf extraPkgConfs > removeUserPkgConf extraPkgConfs > removeWayDyn ways > setDPHOpt optLevel, generalFlags, maxSimplIterations, simplPhases > setDepIncludePkgDeps depIncludePkgDeps > setDepMakefile depMakefile > setDumpDir dumpDir > setDumpFlag dumpFlags, generalFlags > setDumpFlag' dumpFlags, generalFlags > setDumpPrefixForce dumpPrefixForce > setDumpSimplPhases generalFlags, shouldDumpSimplPhase > setDylibInstallName dylibInstallName > setDynHiSuf dynHiSuf > setDynObjectSuf dynObjectSuf > setDynOutputFile dynOutputFile > setExtensionFlag extensions, extensionFlags > setGeneralFlag generalFlags > setHcSuf hcSuf > setHiDir hiDir > setHiSuf hiSuf > setInteractivePrint interactivePrint > setLanguage language, extensionFlags > setMainIs mainFunIs, mainModIs > setObjTarget hscTarget > setObjectDir objectDir > setObjectSuf objectSuf > setOptHpcDir hpcDir > setOptLevel optLevel, generalFlags > setOutputDir objectDir, hiDir, stubDir, dumpDir > setOutputFile outputFile > setOutputHi outputHi > setPackageName thisPackage > setPackageTrust generalFlags, pkgTrustOnLoc > setPgmP settings > setRtsOpts rtsOpts > setRtsOptsEnabled rtsOptsEnabled > setSafeHaskell safeHaskell > setStubDir stubDir > setTarget hscTarget > setTargetWithPlatform hscTarget > setTmpDir settings > setVerboseCore2Core dumpFlags, generalFlags, shouldDumpSimplPhase > setVerbosity verbosity > setWarningFlag warningFlags > trustPackage packageFlags > unSetExtensionFlag extensions, extensionFlags > unSetGeneralFlag generalFlags > unSetWarningFlag warningFlags Below is a list of the dynamic_flags in alphabetical order along with the auxiliary function that they use. A handful of these flags define their effect on DynFlags directly; these are marked (**). > FLAG DEFINED IN TERMS OF > ---------------------------------------------------------------------------- > "#include" addCmdlineHCInclude > "D" addOptP > "F" setGeneralFlag > "H" ** sets ghcHeapSize > "I" addIncludePath > "L" addLibraryPath > "O" setOptLevel > "O" setOptLevel > "Odph" setDPHOpt > "Onot" setOptLevel > "Rghc-timing" ** sets enableTimeStats > "U" addOptP > "W" setWarningFlag > "Wall" setWarningFlag > "Werror" setGeneralFlag > "Wnot" ** sets warningFlags > "Wwarn" unSetGeneralFlag > "auto" ** sets profAuto > "auto-all" ** sets profAuto > "caf-all" setGeneralFlag > "cpp" setExtensionFlag > "dasm-lint" setGeneralFlag > "dcmm-lint" setGeneralFlag > "dcore-lint" setGeneralFlag > "ddump-asm" setDumpFlag > "ddump-asm-conflicts" setDumpFlag > "ddump-asm-expanded" setDumpFlag > "ddump-asm-liveness" setDumpFlag > "ddump-asm-native" setDumpFlag > "ddump-asm-regalloc" setDumpFlag > "ddump-asm-regalloc-stages" setDumpFlag > "ddump-asm-stats" setDumpFlag > "ddump-bcos" setDumpFlag > "ddump-cmm" setDumpFlag > "ddump-cmm-cbe" setDumpFlag > "ddump-cmm-cfg" setDumpFlag > "ddump-cmm-cps" setDumpFlag > "ddump-cmm-info" setDumpFlag > "ddump-cmm-proc" setDumpFlag > "ddump-cmm-procmap" setDumpFlag > "ddump-cmm-raw" setDumpFlag > "ddump-cmm-sink" setDumpFlag > "ddump-cmm-sp" setDumpFlag > "ddump-cmm-split" setDumpFlag > "ddump-core-pipeline" setDumpFlag > "ddump-core-stats" setDumpFlag > "ddump-cs-trace" setDumpFlag > "ddump-cse" setDumpFlag > "ddump-deriv" setDumpFlag > "ddump-ds" setDumpFlag > "ddump-file-prefix" setDumpPrefixForce > "ddump-foreign" setDumpFlag > "ddump-hi" setDumpFlag > "ddump-hi-diffs" setDumpFlag > "ddump-hpc" setDumpFlag > "ddump-if-trace" setDumpFlag > "ddump-inlinings" setDumpFlag > "ddump-llvm" setObjTarget, setDumpFlag' > "ddump-minimal-imports" setGeneralFlag > "ddump-mod-cycles" setDumpFlag > "ddump-occur-anal" setDumpFlag > "ddump-opt-cmm" setDumpFlag > "ddump-parsed" setDumpFlag > "ddump-prep" setDumpFlag > "ddump-rn" setDumpFlag > "ddump-rn-stats" setDumpFlag > "ddump-rn-trace" setDumpFlag > "ddump-rtti" setDumpFlag > "ddump-rule-firings" setDumpFlag > "ddump-rule-rewrites" setDumpFlag > "ddump-rules" setDumpFlag > "ddump-simpl" setDumpFlag > "ddump-simpl-iterations" setDumpFlag > "ddump-simpl-phases" setDumpSimplPhases > "ddump-simpl-stats" setDumpFlag > "ddump-simpl-trace" setDumpFlag > "ddump-spec" setDumpFlag > "ddump-splices" setDumpFlag > "ddump-stg" setDumpFlag > "ddump-stranal" setDumpFlag > "ddump-strsigs" setDumpFlag > "ddump-tc" setDumpFlag > "ddump-tc-trace" setDumpFlag' > "ddump-ticked" setDumpFlag > "ddump-to-file" setGeneralFlag > "ddump-types" setDumpFlag > "ddump-vect" setDumpFlag > "ddump-view-pattern-commoning" setDumpFlag > "ddump-vt-trace" setDumpFlag > "ddump-worker-wrapper" setDumpFlag > "debug" addWay > "dep-makefile" setDepMakefile > "dep-suffix" addDepSuffix > "dfaststring-stats" setGeneralFlag > "dll-split" ** sets dllSplitFile, dllSplit > "dno-llvm-mangler" setGeneralFlag > "dppr-cols" ** sets pprCols > "dppr-user-length" ** sets pprUserLength > "dshow-passes" forceRecompile, setVerbosity > "dsource-stats" setDumpFlag > "dstg-lint" setGeneralFlag > "dstg-stats" setGeneralFlag > "dsuppress-all" setGeneralFlag > "dtrace-level" ** sets traceLevel > "dumpdir" setDumpDir > "dverbose-core2core" setVerbosity, setVerboseCore2Core > "dverbose-stg2stg" setDumpFlag > "dylib-install-name" setDylibInstallName > "dynamic" addWay > "dynamic-too" setGeneralFlag > "dynhisuf" setDynHiSuf > "dynload" parseDynLibLoaderMode > "dyno" setDynOutputFile > "dynosuf" setDynObjectSuf > "eventlog" addWay > "exclude-module" addDepExcludeMod > "fPIC" setGeneralFlag > "fasm" setObjTarget > "fbyte-code" setTarget > "fcontext-stack" ** sets ctxtStkDepth > "ffloat-all-lams" ** sets floatLamArgs > "ffloat-lam-args" ** sets floatLamArgs > "fghci-hist-size" ** sets ghciHistSize > "fglasgow-exts" enableGlasgowExts > "fhistory-size" ** sets historySize > "fliberate-case-threshold" ** sets liberateCaseThreshold > "fllvm" setObjTarget > "fmax-relevant-binds" ** sets maxRelevantBinds > "fmax-simplifier-iterations" ** sets maxSimplIterations > "fmax-worker-args" ** sets maxWorkerArgs > "fno-PIC" unSetGeneralFlag > "fno-code" setTarget, ** sets ghcLink > "fno-glasgow-exts" disableGlasgowExts > "fno-liberate-case-threshold" ** sets liberateCaseThreshold > "fno-max-relevant-binds" ** sets maxRelevantBinds > "fno-prof-auto" ** sets profAuto > "fno-safe-infer" setSafeHaskell > "fno-spec-constr-count" ** sets specConstrCount > "fno-spec-constr-threshold" ** sets specConstrThreshold > "fobject-code" setTargetWithPlatform > "fpackage-trust" setPackageTrust > "fplugin" addPluginModuleName > "fplugin-opt" addPluginModuleNameOption > "fprof-auto" ** sets profAuto > "fprof-auto-calls" ** sets profAuto > "fprof-auto-exported" ** sets profAuto > "fprof-auto-top" ** sets profAuto > "framework" addCmdlineFramework > "framework-path" addFrameworkPath > "frule-check" ** sets ruleCheck > "fsimpl-tick-factor" ** sets simplTickFactor > "fsimplifier-phases" ** sets simplPhases > "fspec-constr-count" ** sets specConstrCount > "fspec-constr-recursive" ** sets specConstrRecursive > "fspec-constr-threshold" ** sets specConstrThreshold > "fstrictness-before" ** sets strictnessBefore > "ftype-function-depth" ** sets tyFunStkDepth > "funfolding-creation-threshold" ** sets ufCreationThreshold > "funfolding-dict-discount" ** sets ufDictDiscount > "funfolding-fun-discount" ** sets ufFunAppDiscount > "funfolding-keeness-factor" ** sets ufKeenessFactor > "funfolding-use-threshold" ** sets ufUseThreshold > "fvia-C" <> > "fvia-c" <> > "ghci-script" addGhciScript > "gransim" addWay > "haddock" setGeneralFlag > "haddock-opts" addHaddockOpts > "hcsuf" setHcSuf > "hidir" setHiDir > "hisuf" setHiSuf > "hpcdir" setOptHpcDir > "i" addImportPath > "include-pkg-deps" setDepIncludePkgDeps > "interactive-print" setInteractivePrint > "j" ** sets parMakeCount > "keep-hc-file" setGeneralFlag > "keep-hc-files" setGeneralFlag > "keep-llvm-file" setObjTarget, setGeneralFlag > "keep-llvm-files" setObjTarget, setGeneralFlag > "keep-raw-s-file" <> > "keep-raw-s-files" <> > "keep-s-file" setGeneralFlag > "keep-s-files" setGeneralFlag > "keep-tmp-files" setGeneralFlag > "l" addLdInputs > "main-is" setMainIs > "mavx" ** sets avx > "mavx2" ** sets avx2 > "mavx512cd" ** sets avx512cd > "mavx512er" ** sets avx512er > "mavx512f" ** sets avx512f > "mavx512pf" ** sets avx512pf > "monly-2-regs" <> > "monly-3-regs" <> > "monly-4-regs" <> > "msse" ** sets sseVersion > "n" <> > "ndp" addWay > "no-auto" ** sets profAuto > "no-auto-all" ** sets profAuto > "no-auto-link-packages" unSetGeneralFlag > "no-caf-all" unSetGeneralFlag > "no-hs-main" setGeneralFlag > "no-link" ** sets ghcLink > "no-recomp" setGeneralFlag > "no-rtsopts" setRtsOptsEnabled > "o" setOutputFile > "odir" setObjectDir > "ohi" setOutputHi > "optF" alterSettings > "optL" alterSettings > "optP" addOptP > "opta" alterSettings > "optc" addOptc > "optdep--exclude-module" addDepExcludeMod > "optdep--include-pkg-deps" setDepIncludePkgDeps > "optdep--include-prelude" setDepIncludePkgDeps > "optdep-f" setDepMakefile > "optdep-s" addDepSuffix > "optdep-w" <> > "optdep-x" addDepExcludeMod > "optl" addOptl > "optlc" alterSettings > "optlo" alterSettings > "optm" <> > "optwindres" alterSettings > "osuf" setObjectSuf > "outputdir" setOutputDir > "parallel" addWay > "pgmF" alterSettings > "pgmL" alterSettings > "pgmP" setPgmP > "pgma" alterSettings > "pgmc" alterSettings > "pgmdll" alterSettings > "pgml" alterSettings > "pgmlc" alterSettings > "pgmlibtool" alterSettings > "pgmlo" alterSettings > "pgmm" <> > "pgms" alterSettings > "pgmwindres" alterSettings > "prof" addWay > "rdynamic" <> > "recomp" unSetGeneralFlag > "relative-dynlib-paths" setGeneralFlag > "rtsopts" setRtsOptsEnabled > "rtsopts=all" setRtsOptsEnabled > "rtsopts=none" setRtsOptsEnabled > "rtsopts=some" setRtsOptsEnabled > "shared" ** sets ghcLink > "smp" addWay > "split-objs" setGeneralFlag > "static" removeWayDyn > "staticlib" ** sets ghcLink > "stubdir" setStubDir > "threaded" addWay > "ticky" setGeneralFlag > "ticky-LNE" setGeneralFlag > "ticky-allocd" setGeneralFlag > "ticky-dyn-thunk" setGeneralFlag > "tmpdir" setTmpDir > "v" setVerbosity > "w" ** sets warningFlags > "with-rtsopts" setRtsOpts Finally, there is a bunch of flags defined in terms of setGeneralFlag, unSetGeneralFlag, setWarningFlag, unSetWarningFlag, setExtensionFlag, unSetExtensionFlag, setLanguage, and setSafeHaskell. The same list for package_flags: > FLAG DEFINED IN TERMS OF > ---------------------------------------------------------------------------- > "clear-package-db" clearPkgConf > "distrust" distrustPackage > "distrust-all-packages" setGeneralFlag > "global-package-db" addPkgConfRef > "hide-all-packages" setGeneralFlag > "hide-package" hidePackage > "ignore-package" ignorePackage > "no-global-package-db" removeGlobalPkgConf > "no-user-package-conf" removeUserPkgConf > "no-user-package-db" removeUserPkgConf > "package" exposePackage > "package-conf" addPkgConfRef > "package-db" addPkgConfRef > "package-id" exposePackageId > "package-name" setPackageName > "syslib" exposePackage > "trust" trustPackage > "user-package-db" addPkgConfRef In addition to the above, we also reset one more field: pkgDatabase. The pkgDatabase is initialized on the first call to initPackages (and hence the first call to setSessionDynFlags), which happens at server startup. After that, subsequent calls to setSessionDynFlags take the _existing_ pkgDatabase, but applies the "batch package flags" to it (hide-all-packages, distrust-all-packages). However, it doesn't "unapply" these batch flags. By restoring the pkgDatabase to the value it gets at server startup, we effectively restore these batch flags whenever we apply user settings. ------------------------------------------------------------------------------} dynFlagsRef :: IORef DynFlags {-# NOINLINE dynFlagsRef #-} dynFlagsRef = unsafePerformIO $ newIORef (error "No DynFlags stored yet") storeDynFlags :: Ghc () storeDynFlags = do dynFlags <- getSessionDynFlags liftIO $ writeIORef dynFlagsRef dynFlags restoreDynFlags :: Ghc DynFlags restoreDynFlags = do storedDynFlags <- liftIO $ readIORef dynFlagsRef currentDynFlags <- getSessionDynFlags return (currentDynFlags `restoreDynFlagsFrom` storedDynFlags) -- | Copy over all fields of DynFlags that are affected by dynamic_flags -- and package_flags (and only those) -- -- See detailed description above. restoreDynFlagsFrom :: DynFlags -> DynFlags -> DynFlags restoreDynFlagsFrom new old = new { avx = avx old , avx2 = avx2 old , avx512cd = avx512cd old , avx512er = avx512er old , avx512f = avx512f old , avx512pf = avx512pf old , cmdlineFrameworks = cmdlineFrameworks old , cmdlineHcIncludes = cmdlineHcIncludes old , ctxtStkDepth = ctxtStkDepth old , depExcludeMods = depExcludeMods old , depIncludePkgDeps = depIncludePkgDeps old , depMakefile = depMakefile old , depSuffixes = depSuffixes old , dllSplit = dllSplit old , dllSplitFile = dllSplitFile old , dumpDir = dumpDir old , dumpFlags = dumpFlags old , dumpPrefixForce = dumpPrefixForce old , dylibInstallName = dylibInstallName old , dynHiSuf = dynHiSuf old , dynLibLoader = dynLibLoader old , dynObjectSuf = dynObjectSuf old , dynOutputFile = dynOutputFile old , enableTimeStats = enableTimeStats old , extensionFlags = extensionFlags old , extensions = extensions old , extraPkgConfs = extraPkgConfs old , floatLamArgs = floatLamArgs old , frameworkPaths = frameworkPaths old , generalFlags = generalFlags old , ghcHeapSize = ghcHeapSize old , ghcLink = ghcLink old , ghciHistSize = ghciHistSize old , ghciScripts = ghciScripts old , haddockOptions = haddockOptions old , hcSuf = hcSuf old , hiDir = hiDir old , hiSuf = hiSuf old , historySize = historySize old , hpcDir = hpcDir old , hscTarget = hscTarget old , importPaths = importPaths old , includePaths = includePaths old , interactivePrint = interactivePrint old , language = language old , ldInputs = ldInputs old , liberateCaseThreshold = liberateCaseThreshold old , libraryPaths = libraryPaths old , mainFunIs = mainFunIs old , mainModIs = mainModIs old , maxRelevantBinds = maxRelevantBinds old , maxSimplIterations = maxSimplIterations old , maxWorkerArgs = maxWorkerArgs old , objectDir = objectDir old , objectSuf = objectSuf old , optLevel = optLevel old , outputFile = outputFile old , outputHi = outputHi old , packageFlags = packageFlags old , parMakeCount = parMakeCount old , pkgDatabase = pkgDatabase old , pkgTrustOnLoc = pkgTrustOnLoc old , pluginModNameOpts = pluginModNameOpts old , pluginModNames = pluginModNames old , pprCols = pprCols old , pprUserLength = pprUserLength old , profAuto = profAuto old , rtsOpts = rtsOpts old , rtsOptsEnabled = rtsOptsEnabled old , ruleCheck = ruleCheck old , safeHaskell = safeHaskell old , settings = settings old , shouldDumpSimplPhase = shouldDumpSimplPhase old , simplPhases = simplPhases old , simplTickFactor = simplTickFactor old , specConstrCount = specConstrCount old , specConstrRecursive = specConstrRecursive old , specConstrThreshold = specConstrThreshold old , sseVersion = sseVersion old , strictnessBefore = strictnessBefore old , stubDir = stubDir old , thisPackage = thisPackage old , traceLevel = traceLevel old , tyFunStkDepth = tyFunStkDepth old , ufCreationThreshold = ufCreationThreshold old , ufDictDiscount = ufDictDiscount old , ufFunAppDiscount = ufFunAppDiscount old , ufKeenessFactor = ufKeenessFactor old , ufUseThreshold = ufUseThreshold old , verbosity = verbosity old , warningFlags = warningFlags old , ways = ways old } {------------------------------------------------------------------------------- Package keys -------------------------------------------------------------------------------} type PackageKey = GHC.PackageId type PackageQualifier = Maybe FastString packageKeyString :: PackageKey -> String packageKeyString = packageIdString stringToPackageKey :: String -> PackageKey stringToPackageKey = stringToPackageId mainPackageKey :: PackageKey mainPackageKey = mainPackageId lookupPackage :: DynFlags -> PackageKey -> PackageConfig lookupPackage dflags pkey = Maybe.fromMaybe (error $ "lookupPackage: invalid key " ++ packageKeyString pkey) (Packages.lookupPackage (Packages.pkgIdMap (pkgState dflags)) pkey) modulePackageKey :: Module -> PackageKey modulePackageKey = modulePackageId -- | Translate a package key to a source ID (name and version) -- -- NOTE: The version of wired-in packages is completely wiped out, but we use a -- leak in the form of a Cabal package id for the same package, which still -- contains a version. See -- packageKeyToSourceId :: DynFlags -> PackageKey -> (String, String) packageKeyToSourceId dflags p = let pkgCfg = lookupPackage dflags p srcId = Cabal.sourcePackageId pkgCfg instId = installedToSourceId $ Cabal.installedPackageId pkgCfg name = pkgName srcId version = Cabal.pkgVersion srcId `orIfZero` Cabal.pkgVersion instId in (name, showVersion (stripInPlace version)) where orIfZero :: Version -> Version -> Version orIfZero v a = case v of Version [] [] -> a ; _otherwise -> v stripInPlace :: Version -> Version stripInPlace (Version bs ts) = Version bs (filter (/= "inplace") ts) -- | Find an exposed module in an exposed package findExposedModule :: DynFlags -> PackageQualifier -> ModuleName -> Maybe PackageKey findExposedModule dflags pkgQual impMod = Maybe.listToMaybe pkgIds where pkgAll = Packages.lookupModuleInAllPackages dflags impMod pkgExposed = map fst $ filter isExposed pkgAll pkgMatching = filter (matchesQual pkgQual) pkgExposed pkgIds = map Packages.packageConfigId pkgMatching matchesQual :: PackageQualifier -> PackageConfig -> Bool matchesQual Nothing _ = True matchesQual (Just fs) p = unpackFS fs == pkgName (Cabal.sourcePackageId p) isExposed :: (PackageConfig, Bool) -> Bool isExposed (pkgCfg, moduleExposed) = Cabal.exposed pkgCfg && moduleExposed {------------------------------------------------------------------------------ Traversing the AST ------------------------------------------------------------------------------} ifPostTc :: AstAlg m id -> a -> Maybe a ifPostTc alg a = case astPhase alg of FoldPreTc -> Nothing FoldPostTc -> Just a instance Fold id (HsGroup id) where fold alg HsGroup { hs_valds , hs_tyclds , hs_instds , hs_derivds , hs_fixds , hs_defds , hs_fords , hs_warnds , hs_annds , hs_ruleds , hs_vects , hs_docs } = astMark alg Nothing "HsGroup" $ do fold alg hs_valds fold alg hs_tyclds fold alg hs_instds fold alg hs_derivds fold alg hs_fixds fold alg hs_defds fold alg hs_fords fold alg hs_warnds fold alg hs_annds fold alg hs_ruleds fold alg hs_vects fold alg hs_docs instance Fold id (HsValBinds id) where fold _alg (ValBindsIn {}) = fail "fold alg: Unexpected ValBindsIn" fold alg (ValBindsOut binds sigs) = astMark alg Nothing "ValBindsOut" $ do fold alg (map snd binds) -- ValBindsOut specifically stores Names, independent of the phase. -- Traverse only in the right mode (types force this) case astPhase alg of FoldPreTc -> fold alg sigs FoldPostTc -> return Nothing instance Fold id (LSig id) where fold alg (L span (TypeSig names tp)) = astMark alg (Just span) "TypeSig" $ do forM_ names $ astId alg SigSite fold alg tp fold alg (L span (PatSynSig name _{-TODO?: (HsPatSynDetails (LHsType name))-} tp _{-TODO?: (LHsContext name)-} _{-TODO?: (LHsContext name)-}) ) = astMark alg (Just span) "PatSynSig" $ do astId alg SigSite name fold alg tp fold alg (L span (GenericSig names tp)) = astMark alg (Just span) "GenericSig" $ do forM_ names $ astId alg SigSite fold alg tp -- Only in generated code fold alg (L span (IdSig _)) = astMark alg (Just span) "IdSig" $ return Nothing -- Annotations fold alg (L span (FixSig _)) = astMark alg (Just span) "FixSig" $ return Nothing fold alg (L span (InlineSig _ _)) = astMark alg (Just span) "InlineSig" $ return Nothing fold alg (L span (SpecSig _ _ _)) = astMark alg (Just span) "SpecSig" $ return Nothing fold alg (L span (SpecInstSig _)) = astMark alg (Just span) "SpecInstSig" $ return Nothing fold alg (L span (MinimalSig _)) = astMark alg (Just span) "MinimalSig" $ return Nothing instance Fold id (LHsType id) where fold alg (L span (HsFunTy arg res)) = astMark alg (Just span) "HsFunTy" $ fold alg [arg, res] fold alg (L span (HsTyVar name)) = astMark alg (Just span) "HsTyVar" $ astId alg UseSite (L span name) fold alg (L span (HsForAllTy explicitFlag tyVars ctxt body)) = astMark alg (Just span) "hsForAllTy" $ do case explicitFlag of Explicit -> fold alg tyVars Implicit -> return Nothing fold alg ctxt fold alg body fold alg (L span (HsAppTy fun arg)) = astMark alg (Just span) "HsAppTy" $ fold alg [fun, arg] fold alg (L span (HsTupleTy _tupleSort typs)) = astMark alg (Just span) "HsTupleTy" $ -- tupleSort is unboxed/boxed/etc. fold alg typs fold alg (L span (HsListTy typ)) = astMark alg (Just span) "HsListTy" $ fold alg typ fold alg (L span (HsPArrTy typ)) = astMark alg (Just span) "HsPArrTy" $ fold alg typ fold alg (L span (HsParTy typ)) = astMark alg (Just span) "HsParTy" $ fold alg typ fold alg (L span (HsEqTy a b)) = astMark alg (Just span) "HsEqTy" $ fold alg [a, b] fold alg (L span (HsDocTy typ _doc)) = astMark alg (Just span) "HsDocTy" $ -- I don't think HsDocTy actually makes it through the renamer fold alg typ fold alg (L span (HsWrapTy _wrapper _typ)) = astMark alg (Just span) "HsWrapTy" $ -- This is returned only by the type checker, and _typ is not located return Nothing fold alg (L span (HsRecTy fields)) = astMark alg (Just span) "HsRecTy" $ fold alg fields fold alg (L span (HsKindSig typ kind)) = astMark alg (Just span) "HsKindSig" $ fold alg [typ, kind] fold alg (L span (HsBangTy _bang typ)) = astMark alg (Just span) "HsBangTy" $ fold alg typ fold alg (L span (HsOpTy left (_wrapper, op) right)) = astMark alg (Just span) "HsOpTy" $ do fold alg [left, right] astId alg UseSite op fold alg (L span (HsIParamTy _var typ)) = astMark alg (Just span) "HsIParamTy" $ -- _var is not located fold alg typ fold alg (L span (HsSpliceTy splice _postTcKind)) = astMark alg (Just span) "HsSpliceTy" $ fold alg splice fold alg (L span (HsCoreTy _)) = astMark alg (Just span) "HsCoreTy" $ -- Not important: doesn't arise until later in the compiler pipeline return Nothing fold alg (L span (HsQuasiQuoteTy qquote)) = astMark alg (Just span) "HsQuasiQuoteTy" $ fold alg (L span qquote) -- reuse location info fold alg (L span (HsExplicitListTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitListTy" $ fold alg typs fold alg (L span (HsExplicitTupleTy _postTcKind typs)) = astMark alg (Just span) "HsExplicitTupleTy" $ fold alg typs fold alg (L span (HsTyLit _hsTyLit)) = astMark alg (Just span) "HsTyLit" $ return Nothing instance Fold id (HsSplice id) where fold alg (HsSplice _id expr) = astMark alg Nothing "HsSplice" $ do fold alg expr instance Fold id (Located (HsQuasiQuote id)) where fold alg (L span (HsQuasiQuote _id _srcSpan _enclosed)) = astMark alg (Just span) "HsQuasiQuote" $ -- Unfortunately, no location information is stored within HsQuasiQuote at all return Nothing instance Fold id (LHsTyVarBndr id) where fold alg (L span (UserTyVar name)) = astMark alg (Just span) "UserTyVar" $ do astId alg DefSite (L span name) fold alg (L span (KindedTyVar name kind)) = astMark alg (Just span) "KindedTyVar" $ do astId alg DefSite (L span name) fold alg kind instance Fold id (LHsContext id) where fold alg (L span typs) = astMark alg (Just span) "LHsContext" $ fold alg typs instance Fold id (LHsBinds id) where fold alg = fold alg . bagToList instance Fold id (LHsBind id) where fold alg (L span bind@(FunBind {})) = astMark alg (Just span) "FunBind" $ do astId alg DefSite (fun_id bind) fold alg (fun_matches bind) fold alg (L span bind@(PatBind {})) = astMark alg (Just span) "PatBind" $ do fold alg (pat_lhs bind) fold alg (pat_rhs bind) fold alg (L span _bind@(VarBind {})) = astMark alg (Just span) "VarBind" $ -- These are only introduced by the type checker, and don't involve user -- written code. The ghc comments says "located 'only for consistency'" return Nothing fold alg (L span bind@(AbsBinds {})) = astMark alg (Just span) "AbsBinds" $ do forM_ (abs_exports bind) $ \abs_export -> astId alg DefSite (L typecheckOnly (abe_poly abs_export)) fold alg (abs_binds bind) fold alg (L span bind@(PatSynBind {})) = astMark alg (Just span) "PatSynBind" $ do astId alg DefSite (patsyn_id bind) fold alg (patsyn_def bind) -- TODO?: patsyn_args :: HsPatSynDetails (Located idR) -- patsyn_dir :: HsPatSynDir idR typecheckOnly :: SrcSpan typecheckOnly = mkGeneralSrcSpan (fsLit "") instance Fold id body => Fold id (MatchGroup id body) where -- We ignore the postTcType, as it doesn't have location information -- TODO: _mg_origin distinguishes between FromSource and Generated. -- May be useful to take that into account? (Here and elsewhere) fold alg (MG mg_alts _mg_arg_tys _mg_res_ty _mg_origin) = astMark alg Nothing "MG" $ fold alg mg_alts instance Fold id body => Fold id (LMatch id body) where fold alg (L span (Match pats _type rhss)) = astMark alg (Just span) "Match" $ do fold alg pats fold alg rhss instance Fold id body => Fold id (GRHSs id body) where fold alg (GRHSs rhss binds) = astMark alg Nothing "GRHSs" $ do fold alg rhss fold alg binds instance Fold id body => Fold id (LGRHS id body) where fold alg (L span (GRHS _guards rhs)) = astMark alg (Just span) "GRHS" $ fold alg rhs instance Fold id (HsLocalBinds id) where fold _alg EmptyLocalBinds = return Nothing fold _alg (HsValBinds (ValBindsIn _ _)) = fail "fold alg: Unexpected ValBindsIn (after renamer these should not exist)" fold alg (HsValBinds binds) = astMark alg Nothing "HsValBinds" $ do fold alg binds fold alg (HsIPBinds binds) = fold alg binds instance Fold id (HsIPBinds id) where fold alg (IPBinds binds _evidence) = fold alg binds instance Fold id (LIPBind id) where fold alg (L span (IPBind _name expr)) = astMark alg (Just span) "IPBind" $ do -- Name is not located :( fold alg expr instance Fold id (LHsExpr id) where fold alg (L span (HsPar expr)) = astMark alg (Just span) "HsPar" $ fold alg expr fold alg (L span (ExprWithTySig expr _type)) = astMark alg (Just span) "ExprWithTySig" $ fold alg expr fold alg (L span (ExprWithTySigOut expr _type)) = astMark alg (Just span) "ExprWithTySigOut" $ fold alg expr fold alg (L span (HsOverLit (OverLit{ol_type}))) = astMark alg (Just span) "HsOverLit" $ do astExpType alg span (ifPostTc alg ol_type) fold alg (L span (OpApp left op _fix right)) = astMark alg (Just span) "OpApp" $ do _leftTy <- fold alg left opTy <- fold alg op _rightTy <- fold alg right astExpType alg span (funRes2 <$> opTy) fold alg (L span (HsVar id)) = astMark alg (Just span) "HsVar" $ do astId alg UseSite (L span id) fold alg (L span (HsWrap wrapper expr)) = astMark alg (Just span) "HsWrap" $ do ty <- fold alg (L span expr) astExpType alg span (applyWrapper wrapper <$> ty) fold alg (L span (HsLet binds expr)) = astMark alg (Just span) "HsLet" $ do fold alg binds ty <- fold alg expr astExpType alg span ty -- Re-astId alg this with the span of the whole let fold alg (L span (HsApp fun arg)) = astMark alg (Just span) "HsApp" $ do funTy <- fold alg fun _argTy <- fold alg arg astExpType alg span (funRes1 <$> funTy) fold alg (L span (HsLit lit)) = -- Intentional omission of the "astMark alg" debugging call here. -- The syntax "assert" is replaced by GHC by "assertError ", where -- both "assertError" and the "" are assigned the source span of -- the original "assert". This means that the (represented as an -- HsLit) might override "assertError" in the IdMap. astExpType alg span (ifPostTc alg (hsLitType lit)) fold alg (L span (HsLam matches@(MG _ mg_arg_tys mg_res_ty _ms_origin))) = astMark alg (Just span) "HsLam" $ do fold alg matches let lamTy = do arg_tys <- sequence $ map (ifPostTc alg) mg_arg_tys res_ty <- ifPostTc alg mg_res_ty return (mkFunTys arg_tys res_ty) astExpType alg span lamTy fold alg (L span (HsDo _ctxt stmts postTcType)) = astMark alg (Just span) "HsDo" $ do -- ctxt indicates what kind of statement it is; AFAICT there is no -- useful information in it for us fold alg stmts astExpType alg span (ifPostTc alg postTcType) fold alg (L span (ExplicitList postTcType _mSyntaxExpr exprs)) = astMark alg (Just span) "ExplicitList" $ do fold alg exprs astExpType alg span (mkListTy <$> ifPostTc alg postTcType) fold alg (L span (RecordCon con postTcExpr recordBinds)) = astMark alg (Just span) "RecordCon" $ do fold alg recordBinds -- Only traverse the postTcExpr in the right phase (types force us! yay! :) case astPhase alg of FoldPreTc -> do astId alg UseSite con return Nothing FoldPostTc -> do conTy <- fold alg (L (getLoc con) postTcExpr) astExpType alg span (funResN <$> conTy) fold alg (L span (HsCase expr matches@(MG _ _mg_arg_tys mg_res_ty _mg_origin))) = astMark alg (Just span) "HsCase" $ do fold alg expr fold alg matches astExpType alg span (ifPostTc alg mg_res_ty) fold alg (L span (ExplicitTuple args boxity)) = astMark alg (Just span) "ExplicitTuple" $ do argTys <- mapM (fold alg) args astExpType alg span (mkTupleTy (boxityNormalTupleSort boxity) <$> sequence argTys) fold alg (L span (HsIf _rebind cond true false)) = astMark alg (Just span) "HsIf" $ do _condTy <- fold alg cond _trueTy <- fold alg true falseTy <- fold alg false astExpType alg span falseTy fold alg (L span (SectionL arg op)) = astMark alg (Just span) "SectionL" $ do _argTy <- fold alg arg opTy <- fold alg op astExpType alg span (mkSectionLTy <$> opTy) where mkSectionLTy ty = let (_arg1, arg2, res) = splitFunTy2 ty in mkFunTy arg2 res fold alg (L span (SectionR op arg)) = astMark alg (Just span) "SectionR" $ do opTy <- fold alg op _argTy <- fold alg arg astExpType alg span (mkSectionRTy <$> opTy) where mkSectionRTy ty = let (arg1, _arg2, res) = splitFunTy2 ty in mkFunTy arg1 res fold alg (L span (HsIPVar _name)) = astMark alg (Just span) "HsIPVar" $ -- _name is not located :( return Nothing fold alg (L span (NegApp expr _rebind)) = astMark alg (Just span) "NegApp" $ do ty <- fold alg expr astExpType alg span ty fold alg (L span (HsBracket th)) = astMark alg (Just span) "HsBracket" $ fold alg th fold alg (L span (HsRnBracketOut th pendingSplices)) = astMark alg (Just span) "HsRnBracketOut" $ do -- HsRnBracketOut is used pre type checking (contains Names only) case astPhase alg of FoldPreTc -> do fold alg pendingSplices fold alg th return Nothing FoldPostTc -> return Nothing fold alg (L span (HsTcBracketOut _th pendingSplices)) = astMark alg (Just span) "HsTcBracketOut" $ do -- Given something like -- -- > \x xs -> [| x : xs |] -- -- @pendingSplices@ contains -- -- > [ "x", "Language.Haskell.TH.Syntax.lift x" -- > , "xs", "Language.Haskell.TH.Syntax.lift xs" -- > ] -- -- Sadly, however, ghc attaches to these splices. -- Moreover, we don't get any type information about the whole bracket -- expression either :( case astPhase alg of FoldPreTc -> return Nothing -- already traversed in HsRnBracketOut FoldPostTc -> do forM_ pendingSplices $ \(_name, splice) -> fold alg splice return Nothing fold alg (L span (RecordUpd expr binds _dataCons _postTcTypeInp _postTcTypeOutp)) = astMark alg (Just span) "RecordUpd" $ do recordTy <- fold alg expr fold alg binds astExpType alg span recordTy -- The type doesn't change fold alg (L span (HsProc pat body)) = astMark alg (Just span) "HsProc" $ do fold alg pat fold alg body fold alg (L span (HsArrApp arr inp _postTcType _arrType _orient)) = astMark alg (Just span) "HsArrApp" $ do fold alg [arr, inp] fold alg (L span (HsArrForm expr _fixity cmds)) = astMark alg (Just span) "HsArrForm" $ do fold alg expr fold alg cmds fold alg (L span (HsTick _tickish expr)) = astMark alg (Just span) "HsTick" $ do fold alg expr fold alg (L span (HsBinTick _trueTick _falseTick expr)) = astMark alg (Just span) "HsBinTick" $ do fold alg expr fold alg (L span (HsTickPragma _span expr)) = astMark alg (Just span) "HsTickPragma" $ do fold alg expr fold alg (L span (HsSCC _string expr)) = astMark alg (Just span) "HsSCC" $ do fold alg expr fold alg (L span (HsCoreAnn _string expr)) = astMark alg (Just span) "HsCoreAnn" $ do fold alg expr fold alg (L span (HsSpliceE _isTyped splice)) = astMark alg (Just span) "HsSpliceE" $ do fold alg splice fold alg (L span (HsQuasiQuoteE qquote)) = astMark alg (Just span) "HsQuasiQuoteE" $ do fold alg (L span qquote) -- reuse span fold alg (L span (ExplicitPArr _postTcType exprs)) = astMark alg (Just span) "ExplicitPArr" $ do fold alg exprs fold alg (L span (PArrSeq _postTcType seqInfo)) = astMark alg (Just span) "PArrSeq" $ do fold alg seqInfo -- According to the comments in HsExpr.lhs, -- "These constructors only appear temporarily in the parser. -- The renamer translates them into the Right Thing." fold alg (L span EWildPat) = astMark alg (Just span) "EWildPat" $ return Nothing fold alg (L span (EAsPat _ _)) = astMark alg (Just span) "EAsPat" $ return Nothing fold alg (L span (EViewPat _ _)) = astMark alg (Just span) "EViewPat" $ return Nothing fold alg (L span (ELazyPat _)) = astMark alg (Just span) "ELazyPat" $ return Nothing fold alg (L span (HsType _ )) = astMark alg (Just span) "HsType" $ return Nothing fold alg (L span (ArithSeq postTcExpr _mSyntaxExpr seqInfo)) = astMark alg (Just span) "ArithSeq" $ do fold alg seqInfo case astPhase alg of FoldPreTc -> return Nothing FoldPostTc -> fold alg (L span postTcExpr) -- New expressions fold _ (L _ (HsLamCase _ _)) = return Nothing -- FIXME fold _ (L _ (HsMultiIf _ _)) = return Nothing -- FIXME -- Unbound variables are errors? fold _alg (L _span (HsUnboundVar _rdrName)) = return Nothing instance Fold id (ArithSeqInfo id) where fold alg (From expr) = astMark alg Nothing "From" $ fold alg expr fold alg (FromThen frm thn) = astMark alg Nothing "FromThen" $ fold alg [frm, thn] fold alg (FromTo frm to) = astMark alg Nothing "FromTo" $ fold alg [frm, to] fold alg (FromThenTo frm thn to) = astMark alg Nothing "FromThenTo" $ fold alg [frm, thn, to] instance Fold id (LHsCmdTop id) where fold alg (L span (HsCmdTop cmd _postTcTypeInp _postTcTypeRet _syntaxTable)) = astMark alg (Just span) "HsCmdTop" $ fold alg cmd instance Fold id (HsBracket id) where fold alg (ExpBr expr) = astMark alg Nothing "ExpBr" $ fold alg expr fold alg (PatBr pat) = astMark alg Nothing "PatBr" $ fold alg pat fold alg (DecBrG group) = astMark alg Nothing "DecBrG" $ fold alg group fold alg (TypBr typ) = astMark alg Nothing "TypBr" $ fold alg typ fold alg (VarBr _namespace _id) = astMark alg Nothing "VarBr" $ -- No location information, sadly return Nothing fold alg (DecBrL decls) = astMark alg Nothing "DecBrL" $ fold alg decls fold alg (TExpBr expr) = astMark alg Nothing "TExpBr" $ fold alg expr instance Fold Name PendingRnSplice where fold alg (PendingRnExpSplice splice) = astMark alg Nothing "PendingRnExpSplice" $ fold alg splice fold alg (PendingRnPatSplice splice) = astMark alg Nothing "PendingRnPatSplice" $ fold alg splice fold alg (PendingRnTypeSplice splice) = astMark alg Nothing "PendingRnTypeSplice" $ fold alg splice fold alg (PendingRnDeclSplice splice) = astMark alg Nothing "PendingRnDeclSplice" $ fold alg splice fold alg (PendingRnCrossStageSplice _) = astMark alg Nothing "PendingRnCrossStageSplice" $ -- No location info return Nothing instance Fold id (HsTupArg id) where fold alg (Present arg) = fold alg arg fold _alg (Missing _postTcType) = return Nothing instance Fold id a => Fold id (HsRecFields id a) where fold alg (HsRecFields rec_flds _rec_dotdot) = astMark alg Nothing "HsRecFields" $ fold alg rec_flds instance Fold id a => Fold id (HsRecField id a) where fold alg (HsRecField id arg _pun) = astMark alg Nothing "HsRecField" $ do astId alg UseSite id fold alg arg -- The meaning of the constructors of LStmt isn't so obvious; see various -- notes in ghc/compiler/hsSyn/HsExpr.lhs instance Fold id body => Fold id (LStmt id body) where fold alg (L span (LastStmt body _syntaxExpr)) = astMark alg (Just span) "LastStmt" $ do fold alg body fold alg (L span (BindStmt pat expr _bind _fail)) = astMark alg (Just span) "BindStmt" $ do -- Neither _bind or _fail are located fold alg pat fold alg expr fold alg (L span (BodyStmt body _seq _guard _postTcType)) = astMark alg (Just span) "BodyStmt" $ do -- TODO: should we do something with _postTcType? -- (Comment in HsExpr.lhs says it's for arrows) fold alg body fold alg (L span (LetStmt binds)) = astMark alg (Just span) "LetStmt" $ fold alg binds fold alg (L span stmt@(RecStmt {})) = astMark alg (Just span) "RecStmt" $ do fold alg (recS_stmts stmt) fold alg (L span (TransStmt {})) = astUnsupported alg (Just span) "TransStmt" fold alg (L span (ParStmt _ _ _)) = astUnsupported alg (Just span) "ParStmt" instance Fold id (LPat id) where fold alg (L span (WildPat postTcType)) = astMark alg (Just span) "WildPat" $ astExpType alg span (ifPostTc alg postTcType) fold alg (L span (VarPat id)) = astMark alg (Just span) "VarPat" $ astId alg DefSite (L span id) fold alg (L span (LazyPat pat)) = astMark alg (Just span) "LazyPat" $ fold alg pat fold alg (L span (AsPat id pat)) = astMark alg (Just span) "AsPat" $ do astId alg DefSite id fold alg pat fold alg (L span (ParPat pat)) = astMark alg (Just span) "ParPat" $ fold alg pat fold alg (L span (BangPat pat)) = astMark alg (Just span) "BangPat" $ fold alg pat fold alg (L span (ListPat pats _postTcType _mSyntaxExpr)) = astMark alg (Just span) "ListPat" $ fold alg pats fold alg (L span (TuplePat pats _boxity _postTcType)) = astMark alg (Just span) "TuplePat" $ fold alg pats fold alg (L span (PArrPat pats _postTcType)) = astMark alg (Just span) "PArrPat" $ fold alg pats fold alg (L span (ConPatIn con details)) = astMark alg (Just span) "ConPatIn" $ do -- Unlike ValBindsIn and HsValBindsIn, we *do* get ConPatIn astId alg UseSite con -- the constructor name is non-binding fold alg details fold alg (L span (ConPatOut {pat_con, pat_args})) = astMark alg (Just span) "ConPatOut" $ do () <- case astPhase alg of FoldPreTc -> do astId alg UseSite (L (getLoc pat_con) (getName (unLoc pat_con))) return () FoldPostTc -> return () fold alg pat_args fold alg (L span (LitPat _)) = astMark alg (Just span) "LitPat" $ return Nothing fold alg (L span (NPat _ _ _)) = astMark alg (Just span) "NPat" $ return Nothing fold alg (L span (NPlusKPat id _lit _rebind1 _rebind2)) = astMark alg (Just span) "NPlusKPat" $ do astId alg DefSite id fold alg (L span (ViewPat expr pat _postTcType)) = astMark alg (Just span) "ViewPat" $ do fold alg expr fold alg pat fold alg (L span (SigPatIn pat typ)) = astMark alg (Just span) "SigPatIn" $ do fold alg pat fold alg typ fold alg (L span (SigPatOut pat _typ)) = astMark alg (Just span) "SigPatOut" $ do -- _typ is not located fold alg pat fold alg (L span (QuasiQuotePat qquote)) = astMark alg (Just span) "QuasiQuotePat" $ fold alg (L span qquote) -- reuse span fold alg (L span (SplicePat splice)) = astMark alg (Just span) "SplicePat" $ fold alg splice -- During translation only fold alg (L span (CoPat _ _ _)) = astMark alg (Just span) "CoPat" $ return Nothing instance (Fold id arg, Fold id rec) => Fold id (HsConDetails arg rec) where fold alg (PrefixCon args) = astMark alg Nothing "PrefixCon" $ fold alg args fold alg (RecCon rec) = astMark alg Nothing "RecCon" $ fold alg rec fold alg (InfixCon a b) = astMark alg Nothing "InfixCon" $ fold alg [a, b] instance Fold id (LTyClDecl id) where fold alg (L span _decl@(ForeignType {})) = astUnsupported alg (Just span) "ForeignType" fold alg (L span (FamDecl tcdFam)) = astMark alg (Just span) "FamDecl" $ do fold alg (L span tcdFam) fold alg (L span (SynDecl tcdLName tcdTyVars tcdRhs _tcdFVs)) = astMark alg (Just span) "SynDecl" $ do astId alg DefSite tcdLName fold alg tcdTyVars fold alg tcdRhs fold alg (L span (DataDecl tcdLName tcdTyVars tcdDataDefn _tcdFVs)) = astMark alg (Just span) "DataDecl" $ do astId alg DefSite tcdLName fold alg tcdTyVars fold alg tcdDataDefn fold alg (L span decl@(ClassDecl {})) = astMark alg (Just span) "ClassDecl" $ do fold alg (tcdCtxt decl) astId alg DefSite (tcdLName decl) fold alg (tcdTyVars decl) -- Sadly, we don't get location info for the functional dependencies fold alg (tcdSigs decl) fold alg (tcdMeths decl) fold alg (tcdATs decl) fold alg (tcdATDefs decl) fold alg (tcdDocs decl) instance Fold id (LConDecl id) where fold alg (L span decl@(ConDecl {})) = astMark alg (Just span) "ConDecl" $ do astId alg DefSite (con_name decl) fold alg (con_qvars decl) fold alg (con_cxt decl) fold alg (con_details decl) fold alg (con_res decl) instance Fold id ty => Fold id (ResType ty) where fold alg ResTyH98 = astMark alg Nothing "ResTyH98" $ do return Nothing -- Nothing to do fold alg (ResTyGADT ty) = astMark alg Nothing "ResTyGADT" $ do fold alg ty instance Fold id (ConDeclField id) where fold alg (ConDeclField name typ _doc) = do astId alg DefSite name fold alg typ instance Fold id (LInstDecl id) where fold alg (L span (ClsInstD cid_inst)) = astMark alg (Just span) "ClsInstD" $ fold alg cid_inst fold alg (L span (DataFamInstD dfid_inst)) = astMark alg (Just span) "DataFamInstD" $ fold alg dfid_inst fold alg (L span (TyFamInstD tfid_inst)) = astMark alg (Just span) "TyFamInstD" $ fold alg tfid_inst instance Fold id (LDerivDecl id) where fold alg (L span (DerivDecl deriv_type)) = astMark alg (Just span) "LDerivDecl" $ do fold alg deriv_type instance Fold id (LFixitySig id) where fold alg (L span (FixitySig name _fixity)) = astMark alg (Just span) "LFixitySig" $ do astId alg SigSite name instance Fold id (LDefaultDecl id) where fold alg (L span (DefaultDecl typs)) = astMark alg (Just span) "LDefaultDecl" $ do fold alg typs instance Fold id (LForeignDecl id) where fold alg (L span (ForeignImport name sig _coercion _import)) = astMark alg (Just span) "ForeignImport" $ do astId alg DefSite name fold alg sig fold alg (L span (ForeignExport name sig _coercion _export)) = astMark alg (Just span) "ForeignExport" $ do astId alg UseSite name fold alg sig instance Fold id (LWarnDecl id) where fold alg (L span (Warning name _txt)) = astMark alg (Just span) "Warning" $ do -- We use the span of the entire warning because we don't get location info for name astId alg UseSite (L span name) instance Fold id (LAnnDecl id) where fold alg (L span _) = astUnsupported alg (Just span) "LAnnDecl" instance Fold id (LRuleDecl id) where fold alg (L span _) = astUnsupported alg (Just span) "LRuleDecl" instance Fold id (LVectDecl id) where fold alg (L span _) = astUnsupported alg (Just span) "LVectDecl" instance Fold id LDocDecl where fold alg (L span _) = astMark alg (Just span) "LDocDec" $ -- Nothing to do return Nothing instance Fold id (Located (SpliceDecl id)) where fold alg (L span (SpliceDecl splice _explicit)) = astMark alg (Just span) "SpliceDecl" $ do fold alg (unLoc splice) -- LHsDecl is a wrapper around the various kinds of declarations; the wrapped -- declarations don't have location information of themselves, so we reuse -- the location info of the wrapper instance Fold id (LHsDecl id) where fold alg (L span (TyClD tyClD)) = astMark alg (Just span) "TyClD" $ fold alg (L span tyClD) fold alg (L span (InstD instD)) = astMark alg (Just span) "InstD" $ fold alg (L span instD) fold alg (L span (DerivD derivD)) = astMark alg (Just span) "DerivD" $ fold alg (L span derivD) fold alg (L span (ValD valD)) = astMark alg (Just span) "ValD" $ fold alg (L span valD) fold alg (L span (SigD sigD)) = astMark alg (Just span) "SigD" $ fold alg (L span sigD) fold alg (L span (DefD defD)) = astMark alg (Just span) "DefD" $ fold alg (L span defD) fold alg (L span (ForD forD)) = astMark alg (Just span) "ForD" $ fold alg (L span forD) fold alg (L span (WarningD warningD)) = astMark alg (Just span) "WarningD" $ fold alg (L span warningD) fold alg (L span (AnnD annD)) = astMark alg (Just span) "AnnD" $ fold alg (L span annD) fold alg (L span (RuleD ruleD)) = astMark alg (Just span) "RuleD" $ fold alg (L span ruleD) fold alg (L span (VectD vectD)) = astMark alg (Just span) "VectD" $ fold alg (L span vectD) fold alg (L span (SpliceD spliceD)) = astMark alg (Just span) "SpliceD" $ fold alg (L span spliceD) fold alg (L span (DocD docD)) = astMark alg (Just span) "DocD" $ fold alg (L span docD) fold alg (L span (QuasiQuoteD quasiQuoteD)) = astMark alg (Just span) "QuasiQuoteD" $ fold alg (L span quasiQuoteD) fold alg (L span (RoleAnnotD _roleAnnotDecl)) = astMark alg (Just span) "RoleAnnotD" $ -- TODO: Do something with roleAnnotDecl return Nothing instance Fold id (TyClGroup id) where fold alg (TyClGroup decls _roles) = astMark alg Nothing "TyClGroup" $ -- TODO: deal with roles fold alg decls instance Fold id (LHsTyVarBndrs id) where fold alg (HsQTvs _hsq_kvs hsq_tvs) = astMark alg Nothing "HsQTvs" $ do -- TODO: sadly, we get no location information about the kind variables fold alg hsq_tvs instance Fold id (LHsCmd id) where -- TODO: support arrows fold _ _ = return Nothing instance Fold id thing => Fold id (HsWithBndrs thing) where fold alg (HsWB hswb_cts _hswb_kvs _hswb_tvs) = astMark alg Nothing "HsWB" $ do -- TODO: sadly, we get no location information about the variables fold alg hswb_cts instance Fold id (LFamilyDecl id) where fold alg (L span (FamilyDecl fdInfo fdLName fdTyVars fdKindSig)) = astMark alg (Just span) "FamilyDecl" $ do fold alg fdInfo astId alg DefSite fdLName fold alg fdTyVars fold alg fdKindSig instance Fold id (FamilyInfo id) where fold alg DataFamily = astMark alg Nothing "DataFamily" $ return Nothing fold alg OpenTypeFamily = astMark alg Nothing "OpenTypeFamily" $ return Nothing fold alg (ClosedTypeFamily instDecls) = astMark alg Nothing "ClosedTypeFamily" $ fold alg instDecls instance Fold id (LTyFamInstDecl id) where fold alg (L span (TyFamInstDecl tfid_eqn _tfid_fvs)) = astMark alg (Just span) "TyFamInstDecl" $ do -- TODO: sadly, tfid_fvs is unlocated fold alg tfid_eqn instance Fold id (ClsInstDecl id) where fold alg (ClsInstDecl cid_poly_ty cid_binds cid_sigs cid_tyfam_insts cid_datafam_insts) = astMark alg Nothing "ClsInstDecl" $ do fold alg cid_poly_ty fold alg cid_binds fold alg cid_sigs fold alg cid_tyfam_insts fold alg cid_datafam_insts instance Fold id (DataFamInstDecl id) where fold alg (DataFamInstDecl dfid_tycon dfid_pats dfid_defn _dfid_fvs) = astMark alg Nothing "DataFamInstDecl" $ do -- TODO: _dfid_fvs is unlocated astId alg UseSite dfid_tycon fold alg dfid_pats fold alg dfid_defn instance Fold id (TyFamInstDecl id) where fold alg (TyFamInstDecl tfid_eqn _tfid_fvs) = astMark alg Nothing "TyFamInstDecl" $ do -- TODO: tfid_fvs is not located fold alg tfid_eqn instance Fold id (LTyFamInstEqn id) where fold alg (L span (TyFamInstEqn tfie_tycon tfie_pats tfie_rhs)) = astMark alg (Just span) "TyFamInstEqn" $ do astId alg UseSite tfie_tycon fold alg tfie_pats fold alg tfie_rhs instance Fold id (LDataFamInstDecl id) where fold alg (L span (DataFamInstDecl dfid_tycon dfid_pats dfid_defn _dfid_fvs)) = astMark alg (Just span) "DataFamInstDecl" $ do -- TODO: dfid_fvs is not located astId alg UseSite dfid_tycon fold alg dfid_pats fold alg dfid_defn instance Fold id (HsDataDefn id) where fold alg (HsDataDefn _dd_ND dd_ctxt _dd_cType dd_kindSig dd_cons dd_derivs) = astMark alg Nothing "HsDataDefn" $ do fold alg dd_ctxt fold alg dd_kindSig fold alg dd_cons fold alg dd_derivs {------------------------------------------------------------------------------ Operations on types ------------------------------------------------------------------------------} applyWrapper :: HsWrapper -> Type -> Type applyWrapper WpHole t = t -- identity applyWrapper (WpTyApp t') t = applyTy t t' applyWrapper (WpEvApp _) t = funRes1 t applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t applyWrapper (WpCast coercion) _ = let Pair _ t = tcCoercionKind coercion in t applyWrapper (WpTyLam v) t = mkForAllTy v t applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t applyWrapper (WpLet _) t = t -- we don't care about evidence _terms_ -- | Given @a -> b@, return @b@ funRes1 :: Type -> Type funRes1 = snd . splitFunTy -- | Given @a1 -> a2 -> b@, return @b@ funRes2 :: Type -> Type funRes2 = funRes1 . funRes1 -- | Given @a1 -> a2 -> ... -> b@, return @b@ funResN :: Type -> Type funResN = snd . splitFunTys -- | Given @a -> b -> c@, return @(a, b, c)@ splitFunTy2 :: Type -> (Type, Type, Type) splitFunTy2 ty0 = let (arg1, ty1) = splitFunTy ty0 (arg2, ty2) = splitFunTy ty1 in (arg1, arg2, ty2) typeOfTyThing :: TyThing -> Maybe Type typeOfTyThing (AConLike (RealDataCon dataCon)) = Just $ dataConRepType dataCon typeOfTyThing _ = Nothing -- we probably don't want psOrigResTy from PatSynCon {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -- | Parse an installed package ID as if it was a source package ID -- -- NOTE: This no longer works for ghc 7.10 and up. installedToSourceId :: Cabal.InstalledPackageId -> Cabal.PackageId installedToSourceId (Cabal.InstalledPackageId instId) = parseSourceId instId -- | Parse a source package ID -- -- Returns an empty package ID if the parse failed. parseSourceId :: String -> Cabal.PackageId parseSourceId = emptyOnParseFailure . Maybe.mapMaybe successfulParse . Cabal.readP_to_S Cabal.parse where successfulParse :: (a, String) -> Maybe a successfulParse (a, unparsed) = if null unparsed then Just a else Nothing emptyOnParseFailure :: [Cabal.PackageId] -> Cabal.PackageId emptyOnParseFailure (i:_) = i emptyOnParseFailure [] = Cabal.PackageIdentifier { pkgName = Cabal.PackageName "" , pkgVersion = Version [] [] } -- | Extract a version from an installed package ID pkgName :: Cabal.PackageIdentifier -> String pkgName pkgId = let Cabal.PackageName nm = Cabal.pkgName pkgId in nm