content: {-# 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
  