-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2015-2019  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-# LANGUAGE RecordWildCards, FlexibleContexts, ConstraintKinds,
  GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor,
  StandaloneDeriving, NamedFieldPuns, OverloadedStrings, ViewPatterns,
  TupleSections, TypeFamilies, DataKinds, GADTs, ScopedTypeVariables,
  ImplicitParams, RankNTypes, MultiWayIf #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

{-|
Module      : Distribution.Helper
License     : Apache-2.0
Maintainer  : cabal-helper@dxld.at
Portability : POSIX
-}

module Distribution.Helper (
  -- * Type Variable Naming Conventions
  -- $type-conventions

  -- * Running Queries
    Query
  , runQuery

  -- * Queries against Cabal\'s on disk state

  -- ** Project queries
  , compilerVersion
  , projectPackages

  -- ** 'Package' queries
  , Package -- abstract
  , pPackageName
  , pSourceDir
  , pUnits

  -- ** 'Unit' queries
  , Unit -- abstract
  , uComponentName
  , UnitId -- abstract
  , UnitInfo(..)
  , unitInfo

  -- ** Convenience Queries
  , allUnits

  -- * Query environment
  , QueryEnv
  , QueryEnvI -- abstract
  , mkQueryEnv
  , qeReadProcess
  , qeCallProcess
  , qePrograms
  , qeProjLoc
  , qeDistDir

  -- * GADTs
  , ProjType(..)
  , CabalProjType(..)
  , ProjLoc(..)
  , DistDir(..)
  , SProjType(..)
  , demoteSProjType
  , projTypeOfDistDir
  , projTypeOfProjLoc
  , SCabalProjType(..)
  , Ex(..)

  -- * Programs
  , Programs(..)
  , defaultPrograms
  , EnvOverride(..)

  -- * Query result types
  , ChComponentInfo(..)
  , ChComponentName(..)
  , ChLibraryName(..)
  , ChModuleName(..)
  , ChPkgDb(..)
  , ChEntrypoint(..)

  -- * General information
  , Distribution.Helper.buildPlatform

  -- * Legacy v1-build helpers
  , Distribution.Helper.getSandboxPkgDb

  -- * Build actions
  , prepare
  , writeAutogenFiles
  , buildProject
  , buildUnits
  ) where

import Cabal.Plan hiding (Unit, UnitId, uDistDir)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Control.Exception as E
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.UTF8 as BSU
import Data.IORef
import Data.List hiding (filter)
import Data.String
import qualified Data.Text as Text
import Data.Maybe
import Data.Either
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Traversable as T
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Version
import Data.Function
import System.Clock as Clock
import System.IO
import System.Environment
import System.FilePath
import System.Directory
import System.Process
import System.Posix.Types
import System.PosixCompat.Files
import Text.Printf
import Text.Read
import Prelude

import CabalHelper.Compiletime.Compile
import qualified CabalHelper.Compiletime.Program.Stack as Stack
import qualified CabalHelper.Compiletime.Program.GHC as GHC
import qualified CabalHelper.Compiletime.Program.CabalInstall as CabalInstall
import CabalHelper.Compiletime.Cabal
import CabalHelper.Compiletime.CompPrograms
import CabalHelper.Compiletime.Log
import CabalHelper.Compiletime.Process
import CabalHelper.Compiletime.Sandbox
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Types.Cabal
import CabalHelper.Compiletime.Types.RelativePath
import CabalHelper.Shared.InterfaceTypes
import CabalHelper.Shared.Common
import CabalHelper.Runtime.HelperMain (helper_main)

import CabalHelper.Compiletime.Compat.Version

import Distribution.System (buildPlatform)
import Distribution.Text (display)

-- $type-conventions
-- Throughout the API we use the following conventions for type variables:
--
-- * @pt@ stands for "project type", when instantiated it is always of kind
--   'ProjType'.
--
-- * @c@ stands for "cache". It is used internally to make the cache
--   inaccessible for some parts of the implementation. Users of the API may
--   completely ignore this parameter. See the internal 'qeCacheRef' field
--   accessor of 'QueryEnv' for details.


-- | A query against a package's Cabal configuration. Use 'runQuery' to
-- execute it.
newtype Query pt a = Query
    { Query pt a -> QueryEnv pt -> IO a
unQuery :: QueryEnv pt -> IO a
    -- ^ @runQuery env query@. Run a 'Query' under a given 'QueryEnv.
    }

instance Functor (Query pt) where
    fmap :: (a -> b) -> Query pt a -> Query pt b
fmap = (a -> b) -> Query pt a -> Query pt b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (Query pt) where
    <*> :: Query pt (a -> b) -> Query pt a -> Query pt b
(<*>) = Query pt (a -> b) -> Query pt a -> Query pt b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    pure :: a -> Query pt a
pure = a -> Query pt a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Monad (Query pt) where
    (Query QueryEnv pt -> IO a
ma) >>= :: Query pt a -> (a -> Query pt b) -> Query pt b
>>= a -> Query pt b
amb = (QueryEnv pt -> IO b) -> Query pt b
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO b) -> Query pt b)
-> (QueryEnv pt -> IO b) -> Query pt b
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> QueryEnv pt -> IO a
ma QueryEnv pt
qe IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Query pt b -> QueryEnv pt -> IO b
forall (pt :: ProjType) a. Query pt a -> QueryEnv pt -> IO a
unQuery (a -> Query pt b
amb a
a) QueryEnv pt
qe
    return :: a -> Query pt a
return a
a = (QueryEnv pt -> IO a) -> Query pt a
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO a) -> Query pt a)
-> (QueryEnv pt -> IO a) -> Query pt a
forall a b. (a -> b) -> a -> b
$ IO a -> QueryEnv pt -> IO a
forall a b. a -> b -> a
const (IO a -> QueryEnv pt -> IO a) -> IO a -> QueryEnv pt -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

runQuery :: Query pt a -> QueryEnv pt -> IO a
runQuery :: Query pt a -> QueryEnv pt -> IO a
runQuery (Query QueryEnv pt -> IO a
action) QueryEnv pt
qe = do
  IORef (CacheKeyCache pt)
ckr <- CacheKeyCache pt -> IO (IORef (CacheKeyCache pt))
forall a. a -> IO (IORef a)
newIORef (CacheKeyCache pt -> IO (IORef (CacheKeyCache pt)))
-> CacheKeyCache pt -> IO (IORef (CacheKeyCache pt))
forall a b. (a -> b) -> a -> b
$ Maybe (ProjConf pt, ProjConfModTimes) -> CacheKeyCache pt
forall (pt :: ProjType).
Maybe (ProjConf pt, ProjConfModTimes) -> CacheKeyCache pt
CacheKeyCache Maybe (ProjConf pt, ProjConfModTimes)
forall a. Maybe a
Nothing
  let qe' :: QueryEnv pt
qe' = QueryEnv pt
qe { qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheKeys = IORef (CacheKeyCache pt)
ckr }
  Programs
conf_progs <- QueryEnv pt -> IO Programs
forall (a :: ProjType -> *) b (pt :: ProjType).
QueryEnvI (QCProgs a b) pt -> IO Programs
getConfProgs QueryEnv pt
qe'
  QueryEnv pt -> IO a
action QueryEnv pt
qe' { qePrograms :: Programs
qePrograms = Programs
conf_progs }

-- | @mkQueryEnv projdir distdir@. Smart constructor for 'QueryEnv'.
-- Sets fields 'qeProjLoc' and 'qeDistDir' to @projdir@ and @distdir@
-- respectively and provides sensible defaults for the other fields.
mkQueryEnv
    :: ProjLoc pt
    -- ^ Location of the project.
    -> DistDir pt
    -- ^ Path to the @dist/@ or @dist-newstyle/@ directory, called
    -- /builddir/ in Cabal terminology.
    -> IO (QueryEnv pt)
mkQueryEnv :: ProjLoc pt -> DistDir pt -> IO (QueryEnv pt)
mkQueryEnv ProjLoc pt
projloc DistDir pt
distdir = do
  IORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)
cr <- QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
-> IO (IORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt))
forall a. a -> IO (IORef a)
newIORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
 -> IO (IORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)))
-> QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
-> IO (IORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt))
forall a b. (a -> b) -> a -> b
$ Maybe ((ProjConf pt, ProjConfModTimes), PreInfo pt)
-> Maybe (Programs, Programs)
-> Maybe ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
-> Map DistDirLib UnitInfo
-> QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
Maybe ((ProjConf pt, ProjConfModTimes), pre_info pt)
-> Maybe (Programs, progs)
-> Maybe ((ProjConf pt, ProjConfModTimes), proj_info pt)
-> Map DistDirLib unit_info
-> QueryCacheI pre_info progs proj_info unit_info pt
QueryCache Maybe ((ProjConf pt, ProjConfModTimes), PreInfo pt)
forall a. Maybe a
Nothing Maybe (Programs, Programs)
forall a. Maybe a
Nothing Maybe ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
forall a. Maybe a
Nothing Map DistDirLib UnitInfo
forall k a. Map k a
Map.empty
  QueryEnv pt -> IO (QueryEnv pt)
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryEnv pt -> IO (QueryEnv pt))
-> QueryEnv pt -> IO (QueryEnv pt)
forall a b. (a -> b) -> a -> b
$ QueryEnv :: forall (c :: ProjType -> *) (pt :: ProjType).
ReadProcessWithCwdAndEnv
-> CallProcessWithCwdAndEnv ()
-> Programs
-> ProjLoc pt
-> DistDir pt
-> IORef (c pt)
-> IORef (CacheKeyCache pt)
-> QueryEnvI c pt
QueryEnv
    { qeReadProcess :: ReadProcessWithCwdAndEnv
qeReadProcess = \String
stdin Maybe String
mcwd [(String, EnvOverride)]
env String
exe [String]
args -> do
        (Verbose => IO String) -> IO String
forall a. (Verbose => IO a) -> IO a
withVerbosity ((Verbose => IO String) -> IO String)
-> (Verbose => IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ Verbose =>
Maybe String
-> [(String, EnvOverride)]
-> String
-> [String]
-> String
-> IO String
Maybe String
-> [(String, EnvOverride)]
-> String
-> [String]
-> String
-> IO String
readProcessStderr Maybe String
mcwd [(String, EnvOverride)]
env String
exe [String]
args String
""
    , qeCallProcess :: CallProcessWithCwdAndEnv ()
qeCallProcess  = \Maybe String
mcwd [(String, EnvOverride)]
env String
exe [String]
args ->
        (Verbose => IO ()) -> IO ()
forall a. (Verbose => IO a) -> IO a
withVerbosity ((Verbose => IO ()) -> IO ()) -> (Verbose => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbose => CallProcessWithCwdAndEnv ()
CallProcessWithCwdAndEnv ()
callProcessStderr Maybe String
mcwd [(String, EnvOverride)]
env String
exe [String]
args
    , qePrograms :: Programs
qePrograms     = Programs
defaultPrograms
    , qeProjLoc :: ProjLoc pt
qeProjLoc      = ProjLoc pt
projloc
    , qeDistDir :: DistDir pt
qeDistDir      = DistDir pt
distdir
    , qeCacheRef :: IORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)
qeCacheRef     = IORef (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)
cr
    , qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheKeys    = String -> IORef (CacheKeyCache pt)
forall a. HasCallStack => String -> a
error String
"mkQuery: qeCacheKeys is uninitialized!"
    }

-- | Construct paths to project configuration files given where the project is.
projConf :: ProjLoc pt -> IO (ProjConf pt)
projConf :: ProjLoc pt -> IO (ProjConf pt)
projConf (ProjLocV1Dir String
pkgdir) =
  String -> ProjConf ('Cabal 'CV1)
ProjConfV1 (String -> ProjConf ('Cabal 'CV1))
-> IO String -> IO (ProjConf ('Cabal 'CV1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe String -> IO String
complainIfNoCabalFile String
pkgdir (Maybe String -> IO String) -> IO (Maybe String) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
findCabalFile String
pkgdir)
projConf (ProjLocV1CabalFile String
cabal_file String
_) = ProjConf ('Cabal 'CV1) -> IO (ProjConf ('Cabal 'CV1))
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjConf ('Cabal 'CV1) -> IO (ProjConf ('Cabal 'CV1)))
-> ProjConf ('Cabal 'CV1) -> IO (ProjConf ('Cabal 'CV1))
forall a b. (a -> b) -> a -> b
$
  String -> ProjConf ('Cabal 'CV1)
ProjConfV1 String
cabal_file
projConf (ProjLocV2Dir String
projdir_path) =
  ProjLoc ('Cabal 'CV2) -> IO (ProjConf ('Cabal 'CV2))
forall (pt :: ProjType). ProjLoc pt -> IO (ProjConf pt)
projConf (ProjLoc ('Cabal 'CV2) -> IO (ProjConf ('Cabal 'CV2)))
-> ProjLoc ('Cabal 'CV2) -> IO (ProjConf ('Cabal 'CV2))
forall a b. (a -> b) -> a -> b
$ String -> String -> ProjLoc ('Cabal 'CV2)
ProjLocV2File (String
projdir_path String -> String -> String
</> String
"cabal.project") String
projdir_path
projConf (ProjLocV2File String
proj_file String
_) = ProjConf ('Cabal 'CV2) -> IO (ProjConf ('Cabal 'CV2))
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjConf ('Cabal 'CV2) -> IO (ProjConf ('Cabal 'CV2)))
-> ProjConf ('Cabal 'CV2) -> IO (ProjConf ('Cabal 'CV2))
forall a b. (a -> b) -> a -> b
$
  ProjConfV2 :: String -> String -> String -> ProjConf ('Cabal 'CV2)
ProjConfV2
    { pcV2CabalProjFile :: String
pcV2CabalProjFile       = String
proj_file
    , pcV2CabalProjLocalFile :: String
pcV2CabalProjLocalFile  = String
proj_file String -> String -> String
<.> String
"local"
    , pcV2CabalProjFreezeFile :: String
pcV2CabalProjFreezeFile = String
proj_file String -> String -> String
<.> String
"freeze"
    }
projConf (ProjLocStackYaml String
stack_yaml) = ProjConf 'Stack -> IO (ProjConf 'Stack)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjConf 'Stack -> IO (ProjConf 'Stack))
-> ProjConf 'Stack -> IO (ProjConf 'Stack)
forall a b. (a -> b) -> a -> b
$
  ProjConfStack :: String -> ProjConf 'Stack
ProjConfStack
    { pcStackYaml :: String
pcStackYaml = String
stack_yaml }

-- | Get the current modification-time for each file involved in configuring a
-- project. Optional files in 'ProjConf' are handled by not including them in
-- the result list in 'ProjConfModTimes' if they don\'t exist. This causes the
-- lists to be different if the files end up existing later, which is all we
-- need for cache invalidation.
getProjConfModTime :: ProjConf pt -> IO ProjConfModTimes
getProjConfModTime :: ProjConf pt -> IO ProjConfModTimes
getProjConfModTime ProjConfV1{String
pcV1CabalFile :: ProjConf ('Cabal 'CV1) -> String
pcV1CabalFile :: String
pcV1CabalFile} =
  ([(String, EpochTime)] -> ProjConfModTimes)
-> IO [(String, EpochTime)] -> IO ProjConfModTimes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, EpochTime)] -> ProjConfModTimes
ProjConfModTimes (IO [(String, EpochTime)] -> IO ProjConfModTimes)
-> IO [(String, EpochTime)] -> IO ProjConfModTimes
forall a b. (a -> b) -> a -> b
$ (String -> IO (String, EpochTime))
-> [String] -> IO [(String, EpochTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (String, EpochTime)
getFileModTime
    [ String
pcV1CabalFile
    ]
getProjConfModTime ProjConfV2{String
pcV2CabalProjFreezeFile :: String
pcV2CabalProjLocalFile :: String
pcV2CabalProjFile :: String
pcV2CabalProjFreezeFile :: ProjConf ('Cabal 'CV2) -> String
pcV2CabalProjLocalFile :: ProjConf ('Cabal 'CV2) -> String
pcV2CabalProjFile :: ProjConf ('Cabal 'CV2) -> String
..} = do
  ([Maybe (String, EpochTime)] -> ProjConfModTimes)
-> IO [Maybe (String, EpochTime)] -> IO ProjConfModTimes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(String, EpochTime)] -> ProjConfModTimes
ProjConfModTimes ([(String, EpochTime)] -> ProjConfModTimes)
-> ([Maybe (String, EpochTime)] -> [(String, EpochTime)])
-> [Maybe (String, EpochTime)]
-> ProjConfModTimes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (String, EpochTime)] -> [(String, EpochTime)]
forall a. [Maybe a] -> [a]
catMaybes) (IO [Maybe (String, EpochTime)] -> IO ProjConfModTimes)
-> IO [Maybe (String, EpochTime)] -> IO ProjConfModTimes
forall a b. (a -> b) -> a -> b
$
    (String -> IO (Maybe (String, EpochTime)))
-> [String] -> IO [Maybe (String, EpochTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> IO (String, EpochTime))
-> Maybe String -> IO (Maybe (String, EpochTime))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO (String, EpochTime)
getFileModTime (Maybe String -> IO (Maybe (String, EpochTime)))
-> (String -> IO (Maybe String))
-> String
-> IO (Maybe (String, EpochTime))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO (Maybe String)
mightExist)
      [ String
pcV2CabalProjFile
      , String
pcV2CabalProjLocalFile
      , String
pcV2CabalProjFreezeFile
      ]
getProjConfModTime ProjConfStack{String
pcStackYaml :: String
pcStackYaml :: ProjConf 'Stack -> String
..} =
  ([(String, EpochTime)] -> ProjConfModTimes)
-> IO [(String, EpochTime)] -> IO ProjConfModTimes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, EpochTime)] -> ProjConfModTimes
ProjConfModTimes (IO [(String, EpochTime)] -> IO ProjConfModTimes)
-> IO [(String, EpochTime)] -> IO ProjConfModTimes
forall a b. (a -> b) -> a -> b
$ (String -> IO (String, EpochTime))
-> [String] -> IO [(String, EpochTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (String, EpochTime)
getFileModTime
    [ String
pcStackYaml
    ]

getUnitModTimes :: Unit pt -> IO UnitModTimes
getUnitModTimes :: Unit pt -> IO UnitModTimes
getUnitModTimes
  Unit
    { uDistDir :: forall (pt :: ProjType). Unit pt -> DistDirLib
uDistDir=DistDirLib String
distdirv1
    , uPackage :: forall (pt :: ProjType). Unit pt -> Package' ()
uPackage=Package
      { pCabalFile :: forall units. Package' units -> CabalFile
pCabalFile=CabalFile String
cabal_file_path
      , String
pSourceDir :: String
pSourceDir :: forall units. Package' units -> String
pSourceDir
      }
    , UnitImpl pt
uImpl :: forall (pt :: ProjType). Unit pt -> UnitImpl pt
uImpl :: UnitImpl pt
uImpl
    }
  = do
    Maybe (String, EpochTime)
umtPkgYaml <-
        case UnitImpl pt
uImpl of
          UnitImplStack{}
            -> (String -> IO (String, EpochTime))
-> Maybe String -> IO (Maybe (String, EpochTime))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO (String, EpochTime)
getFileModTime (Maybe String -> IO (Maybe (String, EpochTime)))
-> IO (Maybe String) -> IO (Maybe (String, EpochTime))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
mightExist String
package_yaml_path
          UnitImpl pt
_ -> Maybe (String, EpochTime) -> IO (Maybe (String, EpochTime))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, EpochTime)
forall a. Maybe a
Nothing
    (String, EpochTime)
umtCabalFile <- String -> IO (String, EpochTime)
getFileModTime String
cabal_file_path
    Maybe (String, EpochTime)
umtSetupConfig <- ((String -> IO (String, EpochTime))
-> Maybe String -> IO (Maybe (String, EpochTime))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO (String, EpochTime)
getFileModTime (Maybe String -> IO (Maybe (String, EpochTime)))
-> (String -> IO (Maybe String))
-> String
-> IO (Maybe (String, EpochTime))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO (Maybe String)
mightExist) String
setup_config_path
    UnitModTimes -> IO UnitModTimes
forall (m :: * -> *) a. Monad m => a -> m a
return UnitModTimes :: Maybe (String, EpochTime)
-> (String, EpochTime) -> Maybe (String, EpochTime) -> UnitModTimes
UnitModTimes {Maybe (String, EpochTime)
(String, EpochTime)
umtSetupConfig :: Maybe (String, EpochTime)
umtCabalFile :: (String, EpochTime)
umtPkgYaml :: Maybe (String, EpochTime)
umtSetupConfig :: Maybe (String, EpochTime)
umtCabalFile :: (String, EpochTime)
umtPkgYaml :: Maybe (String, EpochTime)
..}
  where
    package_yaml_path :: String
package_yaml_path = String
pSourceDir  String -> String -> String
</> String
"package.yaml"
    setup_config_path :: String
setup_config_path = String
distdirv1 String -> String -> String
</> String
"setup-config"

-- | Get a random unit from the project. Sometimes we need to get info we
-- can only get after configuring _any_ unit but we do assume that this
-- info is uniform across units.
someUnit :: ProjInfo pt -> Unit pt
someUnit :: ProjInfo pt -> Unit pt
someUnit ProjInfo pt
proj_info =
    NonEmpty (Unit pt) -> Unit pt
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (Unit pt) -> Unit pt) -> NonEmpty (Unit pt) -> Unit pt
forall a b. (a -> b) -> a -> b
$ Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall units. Package' units -> units
pUnits (Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt))
-> Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall a b. (a -> b) -> a -> b
$
    NonEmpty (Package' (NonEmpty (Unit pt)))
-> Package' (NonEmpty (Unit pt))
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (Package' (NonEmpty (Unit pt)))
 -> Package' (NonEmpty (Unit pt)))
-> NonEmpty (Package' (NonEmpty (Unit pt)))
-> Package' (NonEmpty (Unit pt))
forall a b. (a -> b) -> a -> b
$ ProjInfo pt -> NonEmpty (Package' (NonEmpty (Unit pt)))
forall (pt :: ProjType). ProjInfo pt -> NonEmpty (Package pt)
piPackages ProjInfo pt
proj_info

-- | The version of GHC the project is configured to use for compilation.
compilerVersion :: Query pt (String, Version)
compilerVersion :: Query pt (String, Version)
compilerVersion = (QueryEnv pt -> IO (String, Version)) -> Query pt (String, Version)
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO (String, Version))
 -> Query pt (String, Version))
-> (QueryEnv pt -> IO (String, Version))
-> Query pt (String, Version)
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe ->
  QueryEnv pt -> IO (ProjInfo pt)
forall (pt :: ProjType). QueryEnv pt -> IO (ProjInfo pt)
getProjInfo QueryEnv pt
qe IO (ProjInfo pt)
-> (ProjInfo pt -> IO (String, Version)) -> IO (String, Version)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ProjInfo pt
proj_info ->
    let unit :: Unit pt
unit = ProjInfo pt -> Unit pt
forall (pt :: ProjType). ProjInfo pt -> Unit pt
someUnit ProjInfo pt
proj_info in
    --  ^ ASSUMPTION: Here we assume the compiler version is uniform across all
    --  units so we just pick any one.
    case ProjInfo pt -> ProjInfoImpl pt
forall (pt :: ProjType). ProjInfo pt -> ProjInfoImpl pt
piImpl ProjInfo pt
proj_info of
      ProjInfoV1 {} -> UnitInfo -> (String, Version)
uiCompilerId (UnitInfo -> (String, Version))
-> IO UnitInfo -> IO (String, Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryEnv pt -> Unit pt -> IO UnitInfo
forall (pt :: ProjType). QueryEnv pt -> Unit pt -> IO UnitInfo
getUnitInfo QueryEnv pt
qe Unit pt
unit
      ProjInfoV2 { (String, Version)
piV2CompilerId :: ProjInfoImpl ('Cabal 'CV2) -> (String, Version)
piV2CompilerId :: (String, Version)
piV2CompilerId } -> (String, Version) -> IO (String, Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, Version)
piV2CompilerId
      ProjInfoStack {} -> UnitInfo -> (String, Version)
uiCompilerId (UnitInfo -> (String, Version))
-> IO UnitInfo -> IO (String, Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryEnv pt -> Unit pt -> IO UnitInfo
forall (pt :: ProjType). QueryEnv pt -> Unit pt -> IO UnitInfo
getUnitInfo QueryEnv pt
qe Unit pt
unit

-- | All local packages currently active in a project\'s build plan.
projectPackages :: Query pt (NonEmpty (Package pt))
projectPackages :: Query pt (NonEmpty (Package pt))
projectPackages = (QueryEnv pt -> IO (NonEmpty (Package pt)))
-> Query pt (NonEmpty (Package pt))
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO (NonEmpty (Package pt)))
 -> Query pt (NonEmpty (Package pt)))
-> (QueryEnv pt -> IO (NonEmpty (Package pt)))
-> Query pt (NonEmpty (Package pt))
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> ProjInfo pt -> NonEmpty (Package pt)
forall (pt :: ProjType). ProjInfo pt -> NonEmpty (Package pt)
piPackages (ProjInfo pt -> NonEmpty (Package pt))
-> IO (ProjInfo pt) -> IO (NonEmpty (Package pt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryEnv pt -> IO (ProjInfo pt)
forall (pt :: ProjType). QueryEnv pt -> IO (ProjInfo pt)
getProjInfo QueryEnv pt
qe

-- | Get the 'UnitInfo' for a given 'Unit'. To get a 'Unit' see 'projectUnits'.
unitInfo :: Unit pt -> Query pt UnitInfo
unitInfo :: Unit pt -> Query pt UnitInfo
unitInfo Unit pt
u = (QueryEnv pt -> IO UnitInfo) -> Query pt UnitInfo
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO UnitInfo) -> Query pt UnitInfo)
-> (QueryEnv pt -> IO UnitInfo) -> Query pt UnitInfo
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> QueryEnv pt -> Unit pt -> IO UnitInfo
forall (pt :: ProjType). QueryEnv pt -> Unit pt -> IO UnitInfo
getUnitInfo QueryEnv pt
qe Unit pt
u

-- | Get information on all units in a project.
allUnits :: (UnitInfo -> a) -> Query pt (NonEmpty a)
allUnits :: (UnitInfo -> a) -> Query pt (NonEmpty a)
allUnits UnitInfo -> a
f = do
  (UnitInfo -> a) -> NonEmpty UnitInfo -> NonEmpty a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> a
f (NonEmpty UnitInfo -> NonEmpty a)
-> Query pt (NonEmpty UnitInfo) -> Query pt (NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Unit pt -> Query pt UnitInfo)
-> NonEmpty (Unit pt) -> Query pt (NonEmpty UnitInfo)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM Unit pt -> Query pt UnitInfo
forall (pt :: ProjType). Unit pt -> Query pt UnitInfo
unitInfo (NonEmpty (Unit pt) -> Query pt (NonEmpty UnitInfo))
-> Query pt (NonEmpty (Unit pt)) -> Query pt (NonEmpty UnitInfo)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonEmpty (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (NonEmpty (NonEmpty (Unit pt)) -> NonEmpty (Unit pt))
-> (NonEmpty (Package' (NonEmpty (Unit pt)))
    -> NonEmpty (NonEmpty (Unit pt)))
-> NonEmpty (Package' (NonEmpty (Unit pt)))
-> NonEmpty (Unit pt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt))
-> NonEmpty (Package' (NonEmpty (Unit pt)))
-> NonEmpty (NonEmpty (Unit pt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall units. Package' units -> units
pUnits (NonEmpty (Package' (NonEmpty (Unit pt))) -> NonEmpty (Unit pt))
-> Query pt (NonEmpty (Package' (NonEmpty (Unit pt))))
-> Query pt (NonEmpty (Unit pt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query pt (NonEmpty (Package' (NonEmpty (Unit pt))))
forall (pt :: ProjType). Query pt (NonEmpty (Package pt))
projectPackages)


data Cached c ckc k v = Cached
  { Cached c ckc k v -> c -> Maybe (k, v)
cGet      :: !(c -> Maybe (k, v))
  , Cached c ckc k v -> c -> (k, v) -> c
cSet      :: !(c -> (k, v) -> c)

  , Cached c ckc k v -> ckc -> Maybe k
cGetKey   :: !(ckc -> Maybe k)
  , Cached c ckc k v -> ckc -> k -> ckc
cSetKey   :: !(ckc -> k -> ckc)

  , Cached c ckc k v -> IO k
cCheckKey :: !(IO k)
  , Cached c ckc k v -> k -> k -> Bool
cKeyValid :: !(k -> k -> Bool)
  -- ^ @cKeyValid old new@ should return 'True' if 'old' is still valid
  -- relative to the value of 'new'.

  , Cached c ckc k v -> k -> IO v
cRegen    :: !(k -> IO v)
  }

-- | Simple caching scheme. Invalidation is based on equality of a "cache
-- key" the current value of which can be got with the IO action 'cGetKey'.
--
-- Note that we only check the actual value of the cache key once per
-- 'runQuery' call by saving the cache key in an ephemeral map.
cached :: QueryEnvI (QueryCacheI a b c d) pt
       -> Cached (QueryCacheI a b c d pt) (CacheKeyCache pt) k v
       -> IO v
cached :: QueryEnvI (QueryCacheI a b c d) pt
-> Cached (QueryCacheI a b c d pt) (CacheKeyCache pt) k v -> IO v
cached QueryEnvI (QueryCacheI a b c d) pt
qe Cached{IO k
k -> IO v
k -> k -> Bool
CacheKeyCache pt -> Maybe k
CacheKeyCache pt -> k -> CacheKeyCache pt
QueryCacheI a b c d pt -> Maybe (k, v)
QueryCacheI a b c d pt -> (k, v) -> QueryCacheI a b c d pt
cRegen :: k -> IO v
cKeyValid :: k -> k -> Bool
cCheckKey :: IO k
cSetKey :: CacheKeyCache pt -> k -> CacheKeyCache pt
cGetKey :: CacheKeyCache pt -> Maybe k
cSet :: QueryCacheI a b c d pt -> (k, v) -> QueryCacheI a b c d pt
cGet :: QueryCacheI a b c d pt -> Maybe (k, v)
cRegen :: forall c ckc k v. Cached c ckc k v -> k -> IO v
cKeyValid :: forall c ckc k v. Cached c ckc k v -> k -> k -> Bool
cCheckKey :: forall c ckc k v. Cached c ckc k v -> IO k
cSetKey :: forall c ckc k v. Cached c ckc k v -> ckc -> k -> ckc
cGetKey :: forall c ckc k v. Cached c ckc k v -> ckc -> Maybe k
cSet :: forall c ckc k v. Cached c ckc k v -> c -> (k, v) -> c
cGet :: forall c ckc k v. Cached c ckc k v -> c -> Maybe (k, v)
..} = do
  QueryCacheI a b c d pt
c <- IORef (QueryCacheI a b c d pt) -> IO (QueryCacheI a b c d pt)
forall a. IORef a -> IO a
readIORef (QueryEnvI (QueryCacheI a b c d) pt
-> IORef (QueryCacheI a b c d pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheRef QueryEnvI (QueryCacheI a b c d) pt
qe)
  (QueryCacheI a b c d pt
c', v
v) <- QueryCacheI a b c d pt
-> Maybe (k, v) -> IO (QueryCacheI a b c d pt, v)
checkUpdate QueryCacheI a b c d pt
c (QueryCacheI a b c d pt -> Maybe (k, v)
cGet QueryCacheI a b c d pt
c)
  IORef (QueryCacheI a b c d pt) -> QueryCacheI a b c d pt -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (QueryEnvI (QueryCacheI a b c d) pt
-> IORef (QueryCacheI a b c d pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheRef QueryEnvI (QueryCacheI a b c d) pt
qe) QueryCacheI a b c d pt
c'
  v -> IO v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v
 where
  checkUpdate :: QueryCacheI a b c d pt
-> Maybe (k, v) -> IO (QueryCacheI a b c d pt, v)
checkUpdate QueryCacheI a b c d pt
c Maybe (k, v)
m = do
    CacheKeyCache pt
ckc <- IORef (CacheKeyCache pt) -> IO (CacheKeyCache pt)
forall a. IORef a -> IO a
readIORef (QueryEnvI (QueryCacheI a b c d) pt -> IORef (CacheKeyCache pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeCacheKeys QueryEnvI (QueryCacheI a b c d) pt
qe)
    let regen :: k -> IO (k, v)
regen k
ck = (k
ck,) (v -> (k, v)) -> IO v -> IO (k, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> IO v
cRegen k
ck
    (k, v)
n <- case Maybe (k, v)
m of
      Maybe (k, v)
Nothing -> do
        k
ck <- IO k
cCheckKey
        IORef (CacheKeyCache pt) -> CacheKeyCache pt -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (QueryEnvI (QueryCacheI a b c d) pt -> IORef (CacheKeyCache pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeCacheKeys QueryEnvI (QueryCacheI a b c d) pt
qe) (CacheKeyCache pt -> k -> CacheKeyCache pt
cSetKey CacheKeyCache pt
ckc k
ck)
        k -> IO (k, v)
regen k
ck
      Just old :: (k, v)
old@(k
old_ck, v
old_v) -> do
        k
ck <- case CacheKeyCache pt -> Maybe k
cGetKey CacheKeyCache pt
ckc of
          Just k
cck ->
            k -> IO k
forall (m :: * -> *) a. Monad m => a -> m a
return k
cck -- TODO: skip valid check below in this case
          Maybe k
Nothing -> do
            k
ck <- IO k
cCheckKey
            IORef (CacheKeyCache pt) -> CacheKeyCache pt -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (QueryEnvI (QueryCacheI a b c d) pt -> IORef (CacheKeyCache pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeCacheKeys QueryEnvI (QueryCacheI a b c d) pt
qe) (CacheKeyCache pt -> k -> CacheKeyCache pt
cSetKey CacheKeyCache pt
ckc k
ck)
            k -> IO k
forall (m :: * -> *) a. Monad m => a -> m a
return k
ck
        if
          | k -> k -> Bool
cKeyValid k
old_ck k
ck -> (k, v) -> IO (k, v)
forall (m :: * -> *) a. Monad m => a -> m a
return (k, v)
old
          | Bool
otherwise -> k -> IO (k, v)
regen k
ck
    (QueryCacheI a b c d pt, v) -> IO (QueryCacheI a b c d pt, v)
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryCacheI a b c d pt -> (k, v) -> QueryCacheI a b c d pt
cSet QueryCacheI a b c d pt
c (k, v)
n, (k, v) -> v
forall a b. (a, b) -> b
snd (k, v)
n)

getProjConfAndModTime :: QueryEnvI c pt -> IO (ProjConf pt, ProjConfModTimes)
getProjConfAndModTime :: QueryEnvI c pt -> IO (ProjConf pt, ProjConfModTimes)
getProjConfAndModTime QueryEnvI c pt
qe = do
  ProjConf pt
proj_conf <- ProjLoc pt -> IO (ProjConf pt)
forall (pt :: ProjType). ProjLoc pt -> IO (ProjConf pt)
projConf (QueryEnvI c pt -> ProjLoc pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc QueryEnvI c pt
qe)
  ProjConfModTimes
mtime <- ProjConf pt -> IO ProjConfModTimes
forall (pt :: ProjType). ProjConf pt -> IO ProjConfModTimes
getProjConfModTime ProjConf pt
proj_conf
  (ProjConf pt, ProjConfModTimes)
-> IO (ProjConf pt, ProjConfModTimes)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjConf pt
proj_conf, ProjConfModTimes
mtime)

getPreInfo :: QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo :: QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo QueryEnvI (QCPreInfo a b c) pt
qe =
  QueryEnvI (QCPreInfo a b c) pt
-> Cached
     (QueryCacheI PreInfo a b c pt)
     (CacheKeyCache pt)
     (ProjConf pt, ProjConfModTimes)
     (PreInfo pt)
-> IO (PreInfo pt)
forall (a :: ProjType -> *) b (c :: ProjType -> *) d
       (pt :: ProjType) k v.
QueryEnvI (QueryCacheI a b c d) pt
-> Cached (QueryCacheI a b c d pt) (CacheKeyCache pt) k v -> IO v
cached QueryEnvI (QCPreInfo a b c) pt
qe (Cached
   (QueryCacheI PreInfo a b c pt)
   (CacheKeyCache pt)
   (ProjConf pt, ProjConfModTimes)
   (PreInfo pt)
 -> IO (PreInfo pt))
-> Cached
     (QueryCacheI PreInfo a b c pt)
     (CacheKeyCache pt)
     (ProjConf pt, ProjConfModTimes)
     (PreInfo pt)
-> IO (PreInfo pt)
forall a b. (a -> b) -> a -> b
$ Cached :: forall c ckc k v.
(c -> Maybe (k, v))
-> (c -> (k, v) -> c)
-> (ckc -> Maybe k)
-> (ckc -> k -> ckc)
-> IO k
-> (k -> k -> Bool)
-> (k -> IO v)
-> Cached c ckc k v
Cached
    { cGet :: QueryCacheI PreInfo a b c pt
-> Maybe ((ProjConf pt, ProjConfModTimes), PreInfo pt)
cGet = QueryCacheI PreInfo a b c pt
-> Maybe ((ProjConf pt, ProjConfModTimes), PreInfo pt)
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
QueryCacheI pre_info progs proj_info unit_info pt
-> Maybe ((ProjConf pt, ProjConfModTimes), pre_info pt)
qcPreInfo
    , cSet :: QueryCacheI PreInfo a b c pt
-> ((ProjConf pt, ProjConfModTimes), PreInfo pt)
-> QueryCacheI PreInfo a b c pt
cSet = \QueryCacheI PreInfo a b c pt
a ((ProjConf pt, ProjConfModTimes), PreInfo pt)
b -> QueryCacheI PreInfo a b c pt
a { qcPreInfo :: Maybe ((ProjConf pt, ProjConfModTimes), PreInfo pt)
qcPreInfo = ((ProjConf pt, ProjConfModTimes), PreInfo pt)
-> Maybe ((ProjConf pt, ProjConfModTimes), PreInfo pt)
forall a. a -> Maybe a
Just ((ProjConf pt, ProjConfModTimes), PreInfo pt)
b }
    , cGetKey :: CacheKeyCache pt -> Maybe (ProjConf pt, ProjConfModTimes)
cGetKey = CacheKeyCache pt -> Maybe (ProjConf pt, ProjConfModTimes)
forall (pt :: ProjType).
CacheKeyCache pt -> Maybe (ProjConf pt, ProjConfModTimes)
ckcProjConf
    , cSetKey :: CacheKeyCache pt
-> (ProjConf pt, ProjConfModTimes) -> CacheKeyCache pt
cSetKey = \CacheKeyCache pt
a (ProjConf pt, ProjConfModTimes)
b -> CacheKeyCache pt
a { ckcProjConf :: Maybe (ProjConf pt, ProjConfModTimes)
ckcProjConf = (ProjConf pt, ProjConfModTimes)
-> Maybe (ProjConf pt, ProjConfModTimes)
forall a. a -> Maybe a
Just (ProjConf pt, ProjConfModTimes)
b }
    , cCheckKey :: IO (ProjConf pt, ProjConfModTimes)
cCheckKey = QueryEnvI (QCPreInfo a b c) pt
-> IO (ProjConf pt, ProjConfModTimes)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IO (ProjConf pt, ProjConfModTimes)
getProjConfAndModTime QueryEnvI (QCPreInfo a b c) pt
qe
    , cKeyValid :: (ProjConf pt, ProjConfModTimes)
-> (ProjConf pt, ProjConfModTimes) -> Bool
cKeyValid = ProjConfModTimes -> ProjConfModTimes -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ProjConfModTimes -> ProjConfModTimes -> Bool)
-> ((ProjConf pt, ProjConfModTimes) -> ProjConfModTimes)
-> (ProjConf pt, ProjConfModTimes)
-> (ProjConf pt, ProjConfModTimes)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ProjConf pt, ProjConfModTimes) -> ProjConfModTimes
forall a b. (a, b) -> b
snd
    , cRegen :: (ProjConf pt, ProjConfModTimes) -> IO (PreInfo pt)
cRegen = \(ProjConf pt, ProjConfModTimes)
_k -> QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IO (PreInfo pt)
readPreInfo QueryEnvI (QCPreInfo a b c) pt
qe
    }

readPreInfo :: QueryEnvI c pt -> IO (PreInfo pt)
readPreInfo :: QueryEnvI c pt -> IO (PreInfo pt)
readPreInfo QueryEnvI c pt
qe = do
  case QueryEnvI c pt -> SProjType pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> SProjType pt
projTypeOfQueryEnv QueryEnvI c pt
qe of
    SProjType pt
SStack -> do
      StackProjPaths
piStackProjPaths <- QueryEnvI c 'Stack -> IO StackProjPaths
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> IO StackProjPaths
Stack.projPaths QueryEnvI c pt
QueryEnvI c 'Stack
qe
      PreInfo 'Stack -> IO (PreInfo 'Stack)
forall (m :: * -> *) a. Monad m => a -> m a
return PreInfoStack :: StackProjPaths -> PreInfo 'Stack
PreInfoStack
        { StackProjPaths
piStackProjPaths :: StackProjPaths
piStackProjPaths :: StackProjPaths
piStackProjPaths
        }
    (SCabal SCabalProjType pt
_) ->
      PreInfo ('Cabal pt) -> IO (PreInfo ('Cabal pt))
forall (m :: * -> *) a. Monad m => a -> m a
return PreInfo ('Cabal pt)
forall (cpt :: CabalProjType). PreInfo ('Cabal cpt)
PreInfoCabal

getProjInfo :: QueryEnv pt -> IO (ProjInfo pt)
getProjInfo :: QueryEnv pt -> IO (ProjInfo pt)
getProjInfo QueryEnv pt
qe = do
  PreInfo pt
pre_info <- QueryEnv pt -> IO (PreInfo pt)
forall a (b :: ProjType -> *) c (pt :: ProjType).
QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo QueryEnv pt
qe
  QueryEnv pt
-> Cached
     (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)
     (CacheKeyCache pt)
     (ProjConf pt, ProjConfModTimes)
     (ProjInfo pt)
-> IO (ProjInfo pt)
forall (a :: ProjType -> *) b (c :: ProjType -> *) d
       (pt :: ProjType) k v.
QueryEnvI (QueryCacheI a b c d) pt
-> Cached (QueryCacheI a b c d pt) (CacheKeyCache pt) k v -> IO v
cached QueryEnv pt
qe (Cached
   (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)
   (CacheKeyCache pt)
   (ProjConf pt, ProjConfModTimes)
   (ProjInfo pt)
 -> IO (ProjInfo pt))
-> Cached
     (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt)
     (CacheKeyCache pt)
     (ProjConf pt, ProjConfModTimes)
     (ProjInfo pt)
-> IO (ProjInfo pt)
forall a b. (a -> b) -> a -> b
$ Cached :: forall c ckc k v.
(c -> Maybe (k, v))
-> (c -> (k, v) -> c)
-> (ckc -> Maybe k)
-> (ckc -> k -> ckc)
-> IO k
-> (k -> k -> Bool)
-> (k -> IO v)
-> Cached c ckc k v
Cached
    { cGet :: QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
-> Maybe ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
cGet = QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
-> Maybe ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
QueryCacheI pre_info progs proj_info unit_info pt
-> Maybe ((ProjConf pt, ProjConfModTimes), proj_info pt)
qcProjInfo
    , cSet :: QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
-> ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
-> QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
cSet = \QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
c n :: ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
n@((ProjConf pt, ProjConfModTimes)
_, ProjInfo pt
proj_info) ->
        let active_units :: [Unit pt]
active_units = NonEmpty (Unit pt) -> [Unit pt]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty (Unit pt) -> [Unit pt])
-> NonEmpty (Unit pt) -> [Unit pt]
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (NonEmpty (NonEmpty (Unit pt)) -> NonEmpty (Unit pt))
-> NonEmpty (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall a b. (a -> b) -> a -> b
$
              (Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt))
-> NonEmpty (Package' (NonEmpty (Unit pt)))
-> NonEmpty (NonEmpty (Unit pt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package' (NonEmpty (Unit pt)) -> NonEmpty (Unit pt)
forall units. Package' units -> units
pUnits (NonEmpty (Package' (NonEmpty (Unit pt)))
 -> NonEmpty (NonEmpty (Unit pt)))
-> NonEmpty (Package' (NonEmpty (Unit pt)))
-> NonEmpty (NonEmpty (Unit pt))
forall a b. (a -> b) -> a -> b
$ ProjInfo pt -> NonEmpty (Package' (NonEmpty (Unit pt)))
forall (pt :: ProjType). ProjInfo pt -> NonEmpty (Package pt)
piPackages ProjInfo pt
proj_info in
        QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
c { qcProjInfo :: Maybe ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
qcProjInfo = ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
-> Maybe ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
forall a. a -> Maybe a
Just ((ProjConf pt, ProjConfModTimes), ProjInfo pt)
n
          , qcUnitInfos :: Map DistDirLib UnitInfo
qcUnitInfos =
               [Unit pt] -> Map DistDirLib UnitInfo -> Map DistDirLib UnitInfo
forall (pt :: ProjType).
[Unit pt] -> Map DistDirLib UnitInfo -> Map DistDirLib UnitInfo
discardInactiveUnitInfos [Unit pt]
active_units (QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
-> Map DistDirLib UnitInfo
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
QueryCacheI pre_info progs proj_info unit_info pt
-> Map DistDirLib unit_info
qcUnitInfos QueryCacheI PreInfo Programs ProjInfo UnitInfo pt
c)
          }
    , cGetKey :: CacheKeyCache pt -> Maybe (ProjConf pt, ProjConfModTimes)
cGetKey = CacheKeyCache pt -> Maybe (ProjConf pt, ProjConfModTimes)
forall (pt :: ProjType).
CacheKeyCache pt -> Maybe (ProjConf pt, ProjConfModTimes)
ckcProjConf
    , cSetKey :: CacheKeyCache pt
-> (ProjConf pt, ProjConfModTimes) -> CacheKeyCache pt
cSetKey = \CacheKeyCache pt
a (ProjConf pt, ProjConfModTimes)
b -> CacheKeyCache pt
a { ckcProjConf :: Maybe (ProjConf pt, ProjConfModTimes)
ckcProjConf = (ProjConf pt, ProjConfModTimes)
-> Maybe (ProjConf pt, ProjConfModTimes)
forall a. a -> Maybe a
Just (ProjConf pt, ProjConfModTimes)
b }
    , cCheckKey :: IO (ProjConf pt, ProjConfModTimes)
cCheckKey = QueryEnv pt -> IO (ProjConf pt, ProjConfModTimes)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IO (ProjConf pt, ProjConfModTimes)
getProjConfAndModTime QueryEnv pt
qe
    , cKeyValid :: (ProjConf pt, ProjConfModTimes)
-> (ProjConf pt, ProjConfModTimes) -> Bool
cKeyValid = ProjConfModTimes -> ProjConfModTimes -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ProjConfModTimes -> ProjConfModTimes -> Bool)
-> ((ProjConf pt, ProjConfModTimes) -> ProjConfModTimes)
-> (ProjConf pt, ProjConfModTimes)
-> (ProjConf pt, ProjConfModTimes)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ProjConf pt, ProjConfModTimes) -> ProjConfModTimes
forall a b. (a, b) -> b
snd
    , cRegen :: (ProjConf pt, ProjConfModTimes) -> IO (ProjInfo pt)
cRegen = \(ProjConf pt
proj_conf, ProjConfModTimes
mtime) -> do
        QueryEnv pt -> IO ()
forall (a :: ProjType -> *) b (pt :: ProjType).
QueryEnvI (QCProgs a b) pt -> IO ()
shallowReconfigureProject QueryEnv pt
qe
        QueryEnv pt
-> ProjConf pt
-> ProjConfModTimes
-> PreInfo pt
-> IO (ProjInfo pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> ProjConf pt
-> ProjConfModTimes
-> PreInfo pt
-> IO (ProjInfo pt)
readProjInfo QueryEnv pt
qe ProjConf pt
proj_conf ProjConfModTimes
mtime PreInfo pt
pre_info
    }


-- | Get the cabal version we need to build for this project.
getCabalLibVersion :: QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
getCabalLibVersion :: QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
getCabalLibVersion QueryEnv pt
_ Reconfigured pt
_ ProjInfo{piImpl :: forall (pt :: ProjType). ProjInfo pt -> ProjInfoImpl pt
piImpl=ProjInfoV1 {CabalVersion
piV1CabalVersion :: ProjInfoImpl ('Cabal 'CV1) -> CabalVersion
piV1CabalVersion :: CabalVersion
piV1CabalVersion}} =
  CabalVersion -> IO CabalVersion
forall (m :: * -> *) a. Monad m => a -> m a
return CabalVersion
piV1CabalVersion
getCabalLibVersion QueryEnv pt
qe Reconfigured pt
reconf ProjInfo pt
proj_info = do
  Unit pt
unit <- case Reconfigured pt
reconf of
    AlreadyReconfigured Unit pt
unit ->
        Unit pt -> IO (Unit pt)
forall (m :: * -> *) a. Monad m => a -> m a
return Unit pt
unit
    Reconfigured pt
Haven'tReconfigured -> do
        let unit :: Unit pt
unit = ProjInfo pt -> Unit pt
forall (pt :: ProjType). ProjInfo pt -> Unit pt
someUnit ProjInfo pt
proj_info
        QueryEnv pt -> Unit pt -> IO (Reconfigured pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Unit pt -> IO (Reconfigured pt)
reconfigureUnit QueryEnv pt
qe Unit pt
unit
        Unit pt -> IO (Unit pt)
forall (m :: * -> *) a. Monad m => a -> m a
return Unit pt
unit
  let DistDirLib String
distdir = Unit pt -> DistDirLib
forall (pt :: ProjType). Unit pt -> DistDirLib
uDistDir (Unit pt -> DistDirLib) -> Unit pt -> DistDirLib
forall a b. (a -> b) -> a -> b
$ Unit pt
unit
  UnitHeader
hdr <- String -> IO UnitHeader
readSetupConfigHeader (String -> IO UnitHeader) -> String -> IO UnitHeader
forall a b. (a -> b) -> a -> b
$ String
distdir String -> String -> String
</> String
"setup-config"
  let (ByteString
"Cabal", Version
cabalVer) = UnitHeader -> (ByteString, Version)
uhSetupId UnitHeader
hdr
  CabalVersion -> IO CabalVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalVersion -> IO CabalVersion)
-> CabalVersion -> IO CabalVersion
forall a b. (a -> b) -> a -> b
$ Version -> CabalVersion
forall a. Version -> CabalVersion' a
CabalVersion Version
cabalVer


getUnitInfo :: QueryEnv pt -> Unit pt -> IO UnitInfo
getUnitInfo :: QueryEnv pt -> Unit pt -> IO UnitInfo
getUnitInfo qe :: QueryEnv pt
qe@QueryEnv{IORef (CacheKeyCache pt)
IORef (QueryCache pt)
Programs
DistDir pt
ProjLoc pt
ReadProcessWithCwdAndEnv
CallProcessWithCwdAndEnv ()
qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheRef :: IORef (QueryCache pt)
qeDistDir :: DistDir pt
qeProjLoc :: ProjLoc pt
qePrograms :: Programs
qeCallProcess :: CallProcessWithCwdAndEnv ()
qeReadProcess :: ReadProcessWithCwdAndEnv
qeCacheRef :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheKeys :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qePrograms :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qeCallProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeReadProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
..} unit :: Unit pt
unit@Unit{DistDirLib
uDistDir :: DistDirLib
uDistDir :: forall (pt :: ProjType). Unit pt -> DistDirLib
uDistDir} = do
  PreInfo pt
pre_info <- QueryEnv pt -> IO (PreInfo pt)
forall a (b :: ProjType -> *) c (pt :: ProjType).
QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo QueryEnv pt
qe
  ProjInfo pt
proj_info <- QueryEnv pt -> IO (ProjInfo pt)
forall (pt :: ProjType). QueryEnv pt -> IO (ProjInfo pt)
getProjInfo QueryEnv pt
qe
  QueryEnv pt
-> Cached (QueryCache pt) (CacheKeyCache pt) UnitModTimes UnitInfo
-> IO UnitInfo
forall (a :: ProjType -> *) b (c :: ProjType -> *) d
       (pt :: ProjType) k v.
QueryEnvI (QueryCacheI a b c d) pt
-> Cached (QueryCacheI a b c d pt) (CacheKeyCache pt) k v -> IO v
cached QueryEnv pt
qe (Cached (QueryCache pt) (CacheKeyCache pt) UnitModTimes UnitInfo
 -> IO UnitInfo)
-> Cached (QueryCache pt) (CacheKeyCache pt) UnitModTimes UnitInfo
-> IO UnitInfo
forall a b. (a -> b) -> a -> b
$ Cached :: forall c ckc k v.
(c -> Maybe (k, v))
-> (c -> (k, v) -> c)
-> (ckc -> Maybe k)
-> (ckc -> k -> ckc)
-> IO k
-> (k -> k -> Bool)
-> (k -> IO v)
-> Cached c ckc k v
Cached
    { cGet :: QueryCache pt -> Maybe (UnitModTimes, UnitInfo)
cGet = \QueryCache pt
c -> do
        UnitInfo
ui <- DistDirLib -> Map DistDirLib UnitInfo -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DistDirLib
uDistDir (QueryCache pt -> Map DistDirLib UnitInfo
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
QueryCacheI pre_info progs proj_info unit_info pt
-> Map DistDirLib unit_info
qcUnitInfos QueryCache pt
c)
        (UnitModTimes, UnitInfo) -> Maybe (UnitModTimes, UnitInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo -> UnitModTimes
uiModTimes UnitInfo
ui, UnitInfo
ui)
    , cSet :: QueryCache pt -> (UnitModTimes, UnitInfo) -> QueryCache pt
cSet = \QueryCache pt
c (UnitModTimes
_mtimes, UnitInfo
unit_info) -> QueryCache pt
c { qcUnitInfos :: Map DistDirLib UnitInfo
qcUnitInfos =
        DistDirLib
-> UnitInfo -> Map DistDirLib UnitInfo -> Map DistDirLib UnitInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DistDirLib
uDistDir UnitInfo
unit_info (QueryCache pt -> Map DistDirLib UnitInfo
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
QueryCacheI pre_info progs proj_info unit_info pt
-> Map DistDirLib unit_info
qcUnitInfos QueryCache pt
c) }

    , cGetKey :: CacheKeyCache pt -> Maybe UnitModTimes
cGetKey = Maybe UnitModTimes -> CacheKeyCache pt -> Maybe UnitModTimes
forall a b. a -> b -> a
const Maybe UnitModTimes
forall a. Maybe a
Nothing
    , cSetKey :: CacheKeyCache pt -> UnitModTimes -> CacheKeyCache pt
cSetKey = CacheKeyCache pt -> UnitModTimes -> CacheKeyCache pt
forall a b. a -> b -> a
const
    , cCheckKey :: IO UnitModTimes
cCheckKey = Unit pt -> IO UnitModTimes
forall (pt :: ProjType). Unit pt -> IO UnitModTimes
getUnitModTimes Unit pt
unit
    , cKeyValid :: UnitModTimes -> UnitModTimes -> Bool
cKeyValid = UnitModTimes -> UnitModTimes -> Bool
forall a. Eq a => a -> a -> Bool
(==)

    , cRegen :: UnitModTimes -> IO UnitInfo
cRegen = \UnitModTimes
mtimes -> do
        Reconfigured pt
reconf <- QueryEnv pt -> Unit pt -> IO (Reconfigured pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Unit pt -> IO (Reconfigured pt)
reconfigureUnit QueryEnv pt
qe Unit pt
unit
        CabalVersion
cabal_ver <- QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
forall (pt :: ProjType).
QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
getCabalLibVersion QueryEnv pt
qe Reconfigured pt
reconf ProjInfo pt
proj_info
        Helper pt
helper <- QueryEnv pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
getHelper QueryEnv pt
qe PreInfo pt
pre_info ProjInfo pt
proj_info CabalVersion
cabal_ver
        Helper pt -> Unit pt -> UnitModTimes -> IO UnitInfo
forall (pt :: ProjType).
Helper pt -> Unit pt -> UnitModTimes -> IO UnitInfo
readUnitInfo Helper pt
helper Unit pt
unit UnitModTimes
mtimes
    }

-- | Restrict 'UnitInfo' cache to units that are still active
discardInactiveUnitInfos
    :: [Unit pt]
    -> Map DistDirLib UnitInfo
    -> Map DistDirLib UnitInfo
discardInactiveUnitInfos :: [Unit pt] -> Map DistDirLib UnitInfo -> Map DistDirLib UnitInfo
discardInactiveUnitInfos [Unit pt]
active_units Map DistDirLib UnitInfo
uis0 =
    Map DistDirLib UnitInfo
-> Set DistDirLib -> Map DistDirLib UnitInfo
forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeysMap Map DistDirLib UnitInfo
uis0 (Set DistDirLib -> Map DistDirLib UnitInfo)
-> Set DistDirLib -> Map DistDirLib UnitInfo
forall a b. (a -> b) -> a -> b
$ [DistDirLib] -> Set DistDirLib
forall a. Ord a => [a] -> Set a
Set.fromList ([DistDirLib] -> Set DistDirLib) -> [DistDirLib] -> Set DistDirLib
forall a b. (a -> b) -> a -> b
$ (Unit pt -> DistDirLib) -> [Unit pt] -> [DistDirLib]
forall a b. (a -> b) -> [a] -> [b]
map Unit pt -> DistDirLib
forall (pt :: ProjType). Unit pt -> DistDirLib
uDistDir [Unit pt]
active_units
  where
    restrictKeysMap :: Ord k => Map k a -> Set k -> Map k a
    restrictKeysMap :: Map k a -> Set k -> Map k a
restrictKeysMap Map k a
m Set k
s = (k -> a -> Bool) -> Map k a -> Map k a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\k
k a
_ -> k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set k
s) Map k a
m


-- | Regenerate project-level information by calling the appropriate build
-- system.
shallowReconfigureProject :: QueryEnvI (QCProgs a b) pt -> IO ()
shallowReconfigureProject :: QueryEnvI (QCProgs a b) pt -> IO ()
shallowReconfigureProject QueryEnv
  { qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc = ProjLocStackYaml String
_stack_yaml, IORef (CacheKeyCache pt)
IORef (QCProgs a b pt)
Programs
DistDir pt
ReadProcessWithCwdAndEnv
CallProcessWithCwdAndEnv ()
qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheRef :: IORef (QCProgs a b pt)
qeDistDir :: DistDir pt
qePrograms :: Programs
qeCallProcess :: CallProcessWithCwdAndEnv ()
qeReadProcess :: ReadProcessWithCwdAndEnv
qeCacheRef :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheKeys :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qePrograms :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qeCallProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeReadProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
.. } = do
    -- Stack's dry-run only generates the cabal file from package.yaml (or
    -- well that's the only thing we would care about). reconfigureUnit
    -- will take care of this though and we don't need the cabal files
    -- before the Unit stage anyways.
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
shallowReconfigureProject QueryEnvI (QCProgs a b) pt
qe = do
  QueryEnvI (QCProgs a b) pt
-> Maybe (Unit pt) -> BuildStage -> IO ()
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
buildProjectTarget QueryEnvI (QCProgs a b) pt
qe Maybe (Unit pt)
forall a. Maybe a
Nothing BuildStage
DryRun

data Reconfigured pt = AlreadyReconfigured (Unit pt) | Haven'tReconfigured
reconfigureUnit :: QueryEnvI c pt -> Unit pt -> IO (Reconfigured pt)
reconfigureUnit :: QueryEnvI c pt -> Unit pt -> IO (Reconfigured pt)
reconfigureUnit QueryEnvI c pt
qe Unit pt
u = do
  QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
buildProjectTarget QueryEnvI c pt
qe (Unit pt -> Maybe (Unit pt)
forall a. a -> Maybe a
Just Unit pt
u) BuildStage
OnlyCfg
  Reconfigured pt -> IO (Reconfigured pt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Unit pt -> Reconfigured pt
forall (pt :: ProjType). Unit pt -> Reconfigured pt
AlreadyReconfigured Unit pt
u)

buildUnits :: [Unit pt] -> Query pt ()
buildUnits :: [Unit pt] -> Query pt ()
buildUnits [Unit pt]
units = (QueryEnv pt -> IO ()) -> Query pt ()
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO ()) -> Query pt ())
-> (QueryEnv pt -> IO ()) -> Query pt ()
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> do
  Programs
conf_progs <- QueryEnv pt -> IO Programs
forall (a :: ProjType -> *) b (pt :: ProjType).
QueryEnvI (QCProgs a b) pt -> IO Programs
getConfProgs QueryEnv pt
qe
  [Unit pt] -> (Unit pt -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Unit pt]
units ((Unit pt -> IO ()) -> IO ()) -> (Unit pt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Unit pt
u ->
    QueryEnv pt -> Maybe (Unit pt) -> BuildStage -> IO ()
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
buildProjectTarget QueryEnv pt
qe { qePrograms :: Programs
qePrograms = Programs
conf_progs } (Unit pt -> Maybe (Unit pt)
forall a. a -> Maybe a
Just Unit pt
u) BuildStage
DoBuild

buildProject :: Query pt ()
buildProject :: Query pt ()
buildProject = (QueryEnv pt -> IO ()) -> Query pt ()
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO ()) -> Query pt ())
-> (QueryEnv pt -> IO ()) -> Query pt ()
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> do
  Programs
conf_progs <- QueryEnv pt -> IO Programs
forall (a :: ProjType -> *) b (pt :: ProjType).
QueryEnvI (QCProgs a b) pt -> IO Programs
getConfProgs QueryEnv pt
qe
  QueryEnv pt -> Maybe (Unit pt) -> BuildStage -> IO ()
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
buildProjectTarget QueryEnv pt
qe { qePrograms :: Programs
qePrograms = Programs
conf_progs } Maybe (Unit pt)
forall a. Maybe a
Nothing BuildStage
DoBuild

data BuildStage = DryRun | OnlyCfg | DoBuild

buildProjectTarget
    :: QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
buildProjectTarget :: QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO ()
buildProjectTarget QueryEnvI c pt
qe Maybe (Unit pt)
mu BuildStage
stage = do
  -- Stack and cabal just happen to have the same stage options, totally by
  -- accident :)
  [String]
stage_opts :: [String] <- [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ case BuildStage
stage of
    BuildStage
DryRun  -> [String
"--dry-run"]
    BuildStage
OnlyCfg -> [String
"--only-configure"]
    BuildStage
DoBuild -> []
  -- TODO: version check for cabal's --only-configure
  case QueryEnvI c pt
qe of
    QueryEnv { qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeDistDir = DistDirCabal SCabalProjType pt
cpt String
distdir, ProjLoc pt
qeProjLoc :: ProjLoc pt
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc } -> do
      let projdir :: String
projdir = ProjLoc ('Cabal pt) -> String
forall (cpt :: CabalProjType). ProjLoc ('Cabal cpt) -> String
plCabalProjectDir ProjLoc pt
ProjLoc ('Cabal pt)
qeProjLoc
      CabalInstallCommand
cmd <- CabalInstallCommand -> IO CabalInstallCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalInstallCommand -> IO CabalInstallCommand)
-> CabalInstallCommand -> IO CabalInstallCommand
forall a b. (a -> b) -> a -> b
$ case BuildStage
stage of
        BuildStage
DryRun | SCabalProjType pt
SCV1 <- SCabalProjType pt
cpt ->
          CabalInstallCommand
CabalInstall.CIConfigure
          -- TODO: in v1 we configure twice because we do configure for
          -- DryRun and OnlyCfg.
        BuildStage
OnlyCfg ->
          CabalInstallCommand
CabalInstall.CIConfigure
        BuildStage
_ ->
          CabalInstallCommand
CabalInstall.CIBuild
      QueryEnvI c ('Cabal pt)
-> Maybe String -> CabalInstallCommand -> [String] -> IO ()
forall (c :: ProjType -> *) (cpt :: CabalProjType).
QueryEnvI c ('Cabal cpt)
-> Maybe String -> CabalInstallCommand -> [String] -> IO ()
CabalInstall.callCabalInstallCmd QueryEnvI c pt
QueryEnvI c ('Cabal pt)
qe (String -> Maybe String
forall a. a -> Maybe a
Just String
projdir) CabalInstallCommand
cmd ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
        case SCabalProjType pt
cpt of
          SCabalProjType pt
SCV1 ->
            [ String
"--builddir="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
distdir ]
          SCabalProjType pt
SCV2 -> do
            [String]
targets <- [String] -> [[String]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [[String]]) -> [String] -> [[String]]
forall a b. (a -> b) -> a -> b
$ case Maybe (Unit pt)
mu of
              Maybe (Unit pt)
Nothing -> [String
"all"]
              Just Unit{UnitImpl pt
uImpl :: UnitImpl pt
uImpl :: forall (pt :: ProjType). Unit pt -> UnitImpl pt
uImpl} -> [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ if UnitImpl ('Cabal 'CV2) -> Bool
uiV2OnlyDependencies UnitImpl pt
UnitImpl ('Cabal 'CV2)
uImpl
                    then [String
"--only-dependencies"] else []
                , ((ChComponentName, String) -> String)
-> [(ChComponentName, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ChComponentName, String) -> String
forall a b. (a, b) -> b
snd ([(ChComponentName, String)] -> [String])
-> [(ChComponentName, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((ChComponentName, String) -> Bool)
-> [(ChComponentName, String)] -> [(ChComponentName, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ChComponentName -> ChComponentName -> Bool
forall a. Eq a => a -> a -> Bool
/= ChComponentName
ChSetupHsName) (ChComponentName -> Bool)
-> ((ChComponentName, String) -> ChComponentName)
-> (ChComponentName, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChComponentName, String) -> ChComponentName
forall a b. (a, b) -> a
fst) ([(ChComponentName, String)] -> [(ChComponentName, String)])
-> [(ChComponentName, String)] -> [(ChComponentName, String)]
forall a b. (a -> b) -> a -> b
$ UnitImpl ('Cabal 'CV2) -> [(ChComponentName, String)]
uiV2Components UnitImpl pt
UnitImpl ('Cabal 'CV2)
uImpl
                ]
            case ProjLoc pt
qeProjLoc of
              ProjLocV2File {String
plCabalProjectFile :: ProjLoc ('Cabal 'CV2) -> String
plCabalProjectFile :: String
plCabalProjectFile} ->
                [ String
"--project-file="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
plCabalProjectFile
                , String
"--builddir="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
distdir
                ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
stage_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
targets
              ProjLocV2Dir {} ->
                [ String
"--builddir="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
distdir
                ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
stage_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
targets

    QueryEnv { qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeDistDir = DistDirStack Maybe RelativePath
mworkdir
             , qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc = qeProjLoc :: ProjLoc pt
qeProjLoc@ProjLocStackYaml {String
plStackYaml :: ProjLoc 'Stack -> String
plStackYaml :: String
plStackYaml}
             } -> do
      let projdir :: String
projdir = ProjLoc 'Stack -> String
plStackProjectDir ProjLoc pt
ProjLoc 'Stack
qeProjLoc
      let workdir_opts :: [String]
workdir_opts = QueryEnvI c 'Stack -> [String]
forall (c :: ProjType -> *). QueryEnvI c 'Stack -> [String]
Stack.workdirArg QueryEnvI c pt
QueryEnvI c 'Stack
qe
      case Maybe (Unit pt)
mu of
        Just Unit{uPackage :: forall (pt :: ProjType). Unit pt -> Package' ()
uPackage=Package{String
pSourceDir :: String
pSourceDir :: forall units. Package' units -> String
pSourceDir}} ->
          QueryEnvI c 'Stack -> Maybe String -> [String] -> IO ()
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> Maybe String -> [String] -> IO ()
Stack.callStackCmd QueryEnvI c pt
QueryEnvI c 'Stack
qe (String -> Maybe String
forall a. a -> Maybe a
Just String
pSourceDir) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [String]
workdir_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            [ String
"--stack-yaml="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
plStackYaml, String
"build", String
"."
            ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
stage_opts
        Maybe (Unit pt)
Nothing ->
          QueryEnvI c 'Stack -> Maybe String -> [String] -> IO ()
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> Maybe String -> [String] -> IO ()
Stack.callStackCmd QueryEnvI c pt
QueryEnvI c 'Stack
qe (String -> Maybe String
forall a. a -> Maybe a
Just String
projdir) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [String]
workdir_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            [ String
"--stack-yaml="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
plStackYaml, String
"build"
            ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
stage_opts

getFileModTime :: FilePath -> IO (FilePath, EpochTime)
getFileModTime :: String -> IO (String, EpochTime)
getFileModTime String
f = do
  EpochTime
t <- FileStatus -> EpochTime
modificationTime (FileStatus -> EpochTime) -> IO FileStatus -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
f
  (String, EpochTime) -> IO (String, EpochTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f, EpochTime
t)

readProjInfo
    :: QueryEnvI c pt -> ProjConf pt -> ProjConfModTimes -> PreInfo pt -> IO (ProjInfo pt)
readProjInfo :: QueryEnvI c pt
-> ProjConf pt
-> ProjConfModTimes
-> PreInfo pt
-> IO (ProjInfo pt)
readProjInfo QueryEnvI c pt
qe ProjConf pt
pc ProjConfModTimes
pcm PreInfo pt
_pi = (Verbose => IO (ProjInfo pt)) -> IO (ProjInfo pt)
forall a. (Verbose => IO a) -> IO a
withVerbosity ((Verbose => IO (ProjInfo pt)) -> IO (ProjInfo pt))
-> (Verbose => IO (ProjInfo pt)) -> IO (ProjInfo pt)
forall a b. (a -> b) -> a -> b
$ do
  let projloc :: ProjLoc pt
projloc = QueryEnvI c pt -> ProjLoc pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc QueryEnvI c pt
qe
  case (QueryEnvI c pt -> DistDir pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeDistDir QueryEnvI c pt
qe, ProjConf pt
pc) of
    (DistDirCabal SCabalProjType pt
SCV1 String
distdir, ProjConfV1{String
pcV1CabalFile :: String
pcV1CabalFile :: ProjConf ('Cabal 'CV1) -> String
pcV1CabalFile}) -> do
      String
setup_config_path <- String -> IO String
canonicalizePath (String
distdir String -> String -> String
</> String
"setup-config")
      hdr :: UnitHeader
hdr@(UnitHeader (ByteString
pkg_name_bs, Version
_pkg_ver) (ByteString
"Cabal", Version
hdrCabalVersion) (ByteString, Version)
_)
          <- String -> IO UnitHeader
readSetupConfigHeader String
setup_config_path
      let
        v3_0_0_0 :: Version
v3_0_0_0 = [Int] -> Version
makeVersion [Int
3,Int
0,Int
0,Int
0]
        pkg_name :: String
pkg_name
          | Version
hdrCabalVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
v3_0_0_0 = ByteString -> String
BSU.toString ByteString
pkg_name_bs
          | Bool
otherwise = ByteString -> String
BS8.unpack ByteString
pkg_name_bs
        pkg :: Package' (NonEmpty (Unit ('Cabal 'CV1)))
pkg = Package :: forall units.
String
-> String
-> CabalFile
-> [(String, Bool)]
-> units
-> Package' units
Package
          { pPackageName :: String
pPackageName = String
pkg_name
          , pSourceDir :: String
pSourceDir = ProjLoc ('Cabal 'CV1) -> String
forall (cpt :: CabalProjType). ProjLoc ('Cabal cpt) -> String
plCabalProjectDir ProjLoc pt
ProjLoc ('Cabal 'CV1)
projloc
          , pCabalFile :: CabalFile
pCabalFile = String -> CabalFile
CabalFile String
pcV1CabalFile
          , pFlags :: [(String, Bool)]
pFlags = []
          , pUnits :: NonEmpty (Unit ('Cabal 'CV1))
pUnits = (Unit ('Cabal 'CV1)
-> [Unit ('Cabal 'CV1)] -> NonEmpty (Unit ('Cabal 'CV1))
forall a. a -> [a] -> NonEmpty a
:|[]) Unit :: forall (pt :: ProjType).
UnitId -> Package' () -> DistDirLib -> UnitImpl pt -> Unit pt
Unit
            { uUnitId :: UnitId
uUnitId = String -> UnitId
UnitId String
pkg_name
            , uPackage :: Package' ()
uPackage = Package' (NonEmpty (Unit ('Cabal 'CV1)))
pkg { pUnits :: ()
pUnits = () }
            , uDistDir :: DistDirLib
uDistDir = String -> DistDirLib
DistDirLib String
distdir
            , uImpl :: UnitImpl ('Cabal 'CV1)
uImpl = UnitImpl ('Cabal 'CV1)
UnitImplV1
            }
          }
        piImpl :: ProjInfoImpl ('Cabal 'CV1)
piImpl = ProjInfoV1 :: UnitHeader -> CabalVersion -> ProjInfoImpl ('Cabal 'CV1)
ProjInfoV1
          { piV1SetupHeader :: UnitHeader
piV1SetupHeader = UnitHeader
hdr
          , piV1CabalVersion :: CabalVersion
piV1CabalVersion = Version -> CabalVersion
forall a. Version -> CabalVersion' a
CabalVersion Version
hdrCabalVersion
          }
      ProjInfo ('Cabal 'CV1) -> IO (ProjInfo ('Cabal 'CV1))
forall (m :: * -> *) a. Monad m => a -> m a
return ProjInfo :: forall (pt :: ProjType).
NonEmpty (Package pt)
-> ProjInfoImpl pt -> ProjConfModTimes -> ProjInfo pt
ProjInfo
        { piProjConfModTimes :: ProjConfModTimes
piProjConfModTimes = ProjConfModTimes
pcm
        , piPackages :: NonEmpty (Package' (NonEmpty (Unit ('Cabal 'CV1))))
piPackages = Package' (NonEmpty (Unit ('Cabal 'CV1)))
pkg Package' (NonEmpty (Unit ('Cabal 'CV1)))
-> [Package' (NonEmpty (Unit ('Cabal 'CV1)))]
-> NonEmpty (Package' (NonEmpty (Unit ('Cabal 'CV1))))
forall a. a -> [a] -> NonEmpty a
:| []
        , ProjInfoImpl ('Cabal 'CV1)
piImpl :: ProjInfoImpl ('Cabal 'CV1)
piImpl :: ProjInfoImpl ('Cabal 'CV1)
piImpl
        }

    (DistDirCabal SCabalProjType pt
SCV2 String
distdirv2, ProjConf pt
_) -> do
      let plan_path :: String
plan_path = String
distdirv2 String -> String -> String
</> String
"cache" String -> String -> String
</> String
"plan.json"
      EpochTime
plan_mtime <- FileStatus -> EpochTime
modificationTime (FileStatus -> EpochTime) -> IO FileStatus -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
plan_path
      plan :: PlanJson
plan@PlanJson { pjCabalLibVersion :: PlanJson -> Ver
pjCabalLibVersion=Ver [Int]
pjCabalLibVersion
                    , Ver
pjCabalVersion :: PlanJson -> Ver
pjCabalVersion :: Ver
pjCabalVersion
                    , pjCompilerId :: PlanJson -> PkgId
pjCompilerId=PkgId (PkgName Text
compName) (Ver [Int]
compVer)
                    }
          <- String -> IO PlanJson
decodePlanJson String
plan_path
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ver
pjCabalVersion Ver -> Ver -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Ver
Ver [Int
2,Int
4,Int
1,Int
0]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall a. String -> IO a
panicIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"plan.json was produced by too-old a version of\
                  \cabal-install. The 'dist-dir' keys will be missing. \
                  \Please upgrade to at least cabal-instal-2.4.1.0"

      Just NonEmpty (Package ('Cabal 'CV2))
pkgs <- [Package ('Cabal 'CV2)] -> Maybe (NonEmpty (Package ('Cabal 'CV2)))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty ([Package ('Cabal 'CV2)]
 -> Maybe (NonEmpty (Package ('Cabal 'CV2))))
-> IO [Package ('Cabal 'CV2)]
-> IO (Maybe (NonEmpty (Package ('Cabal 'CV2))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlanJson -> IO [Package ('Cabal 'CV2)]
CabalInstall.planPackages PlanJson
plan
      ProjInfo ('Cabal 'CV2) -> IO (ProjInfo ('Cabal 'CV2))
forall (m :: * -> *) a. Monad m => a -> m a
return ProjInfo :: forall (pt :: ProjType).
NonEmpty (Package pt)
-> ProjInfoImpl pt -> ProjConfModTimes -> ProjInfo pt
ProjInfo
        { piProjConfModTimes :: ProjConfModTimes
piProjConfModTimes = ProjConfModTimes
pcm
        , piPackages :: NonEmpty (Package ('Cabal 'CV2))
piPackages = (Package ('Cabal 'CV2) -> String)
-> NonEmpty (Package ('Cabal 'CV2))
-> NonEmpty (Package ('Cabal 'CV2))
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NonEmpty.sortWith Package ('Cabal 'CV2) -> String
forall units. Package' units -> String
pPackageName NonEmpty (Package ('Cabal 'CV2))
pkgs
        , piImpl :: ProjInfoImpl ('Cabal 'CV2)
piImpl = ProjInfoV2 :: PlanJson
-> EpochTime -> (String, Version) -> ProjInfoImpl ('Cabal 'CV2)
ProjInfoV2
          { piV2Plan :: PlanJson
piV2Plan = PlanJson
plan
          , piV2PlanModTime :: EpochTime
piV2PlanModTime = EpochTime
plan_mtime
          , piV2CompilerId :: (String, Version)
piV2CompilerId = (Text -> String
Text.unpack Text
compName, [Int] -> Version
makeDataVersion [Int]
compVer)
          }
        }
    (DistDirStack{}, ProjConf pt
_) -> do
      Just NonEmpty CabalFile
cabal_files <- [CabalFile] -> Maybe (NonEmpty CabalFile)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty ([CabalFile] -> Maybe (NonEmpty CabalFile))
-> IO [CabalFile] -> IO (Maybe (NonEmpty CabalFile))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryEnvI c 'Stack -> IO [CabalFile]
forall (c :: ProjType -> *). QueryEnvI c 'Stack -> IO [CabalFile]
Stack.listPackageCabalFiles QueryEnvI c pt
QueryEnvI c 'Stack
qe
      NonEmpty (Package 'Stack)
pkgs <- (CabalFile -> IO (Package 'Stack))
-> NonEmpty CabalFile -> IO (NonEmpty (Package 'Stack))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QueryEnvI c 'Stack -> CabalFile -> IO (Package 'Stack)
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> CabalFile -> IO (Package 'Stack)
Stack.getPackage QueryEnvI c pt
QueryEnvI c 'Stack
qe) NonEmpty CabalFile
cabal_files
      ProjInfo 'Stack -> IO (ProjInfo 'Stack)
forall (m :: * -> *) a. Monad m => a -> m a
return ProjInfo :: forall (pt :: ProjType).
NonEmpty (Package pt)
-> ProjInfoImpl pt -> ProjConfModTimes -> ProjInfo pt
ProjInfo
        { piProjConfModTimes :: ProjConfModTimes
piProjConfModTimes = ProjConfModTimes
pcm
        , piPackages :: NonEmpty (Package 'Stack)
piPackages = (Package 'Stack -> String)
-> NonEmpty (Package 'Stack) -> NonEmpty (Package 'Stack)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NonEmpty.sortWith Package 'Stack -> String
forall units. Package' units -> String
pPackageName NonEmpty (Package 'Stack)
pkgs
        , piImpl :: ProjInfoImpl 'Stack
piImpl = ProjInfoImpl 'Stack
ProjInfoStack
        }

readUnitInfo :: Helper pt -> Unit pt -> UnitModTimes -> IO UnitInfo
readUnitInfo :: Helper pt -> Unit pt -> UnitModTimes -> IO UnitInfo
readUnitInfo Helper pt
helper u :: Unit pt
u@Unit{uImpl :: forall (pt :: ProjType). Unit pt -> UnitImpl pt
uImpl=ui :: UnitImpl pt
ui@UnitImplV2{[(ChComponentName, String)]
uiV2Components :: [(ChComponentName, String)]
uiV2Components :: UnitImpl ('Cabal 'CV2) -> [(ChComponentName, String)]
uiV2Components}} UnitModTimes
umt
    | ChComponentName
ChSetupHsName ChComponentName -> [ChComponentName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((ChComponentName, String) -> ChComponentName)
-> [(ChComponentName, String)] -> [ChComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (ChComponentName, String) -> ChComponentName
forall a b. (a, b) -> a
fst [(ChComponentName, String)]
uiV2Components = do
        let unit' :: Unit pt
unit' = Unit pt
u {
          uImpl :: UnitImpl pt
uImpl = UnitImpl pt
ui
            { uiV2Components :: [(ChComponentName, String)]
uiV2Components = ((ChComponentName, String) -> Bool)
-> [(ChComponentName, String)] -> [(ChComponentName, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ChComponentName -> ChComponentName -> Bool
forall a. Eq a => a -> a -> Bool
/= ChComponentName
ChSetupHsName) (ChComponentName -> Bool)
-> ((ChComponentName, String) -> ChComponentName)
-> (ChComponentName, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChComponentName, String) -> ChComponentName
forall a b. (a, b) -> a
fst) [(ChComponentName, String)]
uiV2Components
            }
          }
        -- TODO: Add a synthetic UnitInfo for the setup executable. Cabal
        -- doesn't allow building it via a target on the cmdline and it
        -- doesn't really exist as far as setup-config is concerned but
        -- plan.json has the dependency versions for custom-setup so we
        -- should be able to represet that as a UnitInfo.
        Helper pt -> Unit pt -> UnitModTimes -> IO UnitInfo
forall (pt :: ProjType).
Helper pt -> Unit pt -> UnitModTimes -> IO UnitInfo
readUnitInfo Helper pt
helper Unit pt
unit' UnitModTimes
umt
readUnitInfo Helper pt
helper unit :: Unit pt
unit@Unit {uUnitId :: forall (pt :: ProjType). Unit pt -> UnitId
uUnitId=UnitId
uiUnitId} UnitModTimes
uiModTimes = do
    [Maybe ChResponse]
res <- Helper pt -> Unit pt -> [String] -> IO [Maybe ChResponse]
forall (pt :: ProjType).
Helper pt -> Unit pt -> [String] -> IO [Maybe ChResponse]
runHelper Helper pt
helper Unit pt
unit
           [ String
"package-id"
           , String
"compiler-id"
           , String
"flags"
           , String
"config-flags"
           , String
"non-default-config-flags"
           , String
"component-info"
           ]
    let [ Just (ChResponseVersion        (String, Version)
uiPackageId),
          Just (ChResponseVersion        (String, Version)
uiCompilerId),
          Just (ChResponseFlags          [(String, Bool)]
uiPackageFlags),
          Just (ChResponseFlags          [(String, Bool)]
uiConfigFlags),
          Just (ChResponseFlags          [(String, Bool)]
uiNonDefaultConfigFlags),
          Just (ChResponseComponentsInfo Map ChComponentName ChComponentInfo
uiComponents)
          ] = [Maybe ChResponse]
res
    UnitInfo -> IO UnitInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo -> IO UnitInfo) -> UnitInfo -> IO UnitInfo
forall a b. (a -> b) -> a -> b
$ UnitInfo :: UnitId
-> (String, Version)
-> Map ChComponentName ChComponentInfo
-> (String, Version)
-> [(String, Bool)]
-> [(String, Bool)]
-> [(String, Bool)]
-> UnitModTimes
-> UnitInfo
UnitInfo {[(String, Bool)]
(String, Version)
Map ChComponentName ChComponentInfo
UnitModTimes
UnitId
uiNonDefaultConfigFlags :: [(String, Bool)]
uiConfigFlags :: [(String, Bool)]
uiPackageFlags :: [(String, Bool)]
uiComponents :: Map ChComponentName ChComponentInfo
uiPackageId :: (String, Version)
uiUnitId :: UnitId
uiComponents :: Map ChComponentName ChComponentInfo
uiNonDefaultConfigFlags :: [(String, Bool)]
uiConfigFlags :: [(String, Bool)]
uiPackageFlags :: [(String, Bool)]
uiCompilerId :: (String, Version)
uiPackageId :: (String, Version)
uiModTimes :: UnitModTimes
uiUnitId :: UnitId
uiModTimes :: UnitModTimes
uiCompilerId :: (String, Version)
..}

readHelper
    :: QueryEnvI c pt
    -> FilePath
    -> CabalFile
    -> DistDirLib
    -> [String]
    -> IO [Maybe ChResponse]
readHelper :: QueryEnvI c pt
-> String
-> CabalFile
-> DistDirLib
-> [String]
-> IO [Maybe ChResponse]
readHelper QueryEnvI c pt
qe String
exe CabalFile
cabal_file DistDirLib
distdir [String]
args = do
  String
out <- QueryEnvI c pt
-> String -> CabalFile -> DistDirLib -> [String] -> IO String
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> String -> CabalFile -> DistDirLib -> [String] -> IO String
invokeHelper QueryEnvI c pt
qe String
exe CabalFile
cabal_file DistDirLib
distdir [String]
args
  let res :: [Maybe ChResponse]
      res :: [Maybe ChResponse]
res = String -> [Maybe ChResponse]
forall a. Read a => String -> a
read String
out
  IO [Maybe ChResponse] -> IO [Maybe ChResponse]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe ChResponse] -> IO [Maybe ChResponse])
-> IO [Maybe ChResponse] -> IO [Maybe ChResponse]
forall a b. (a -> b) -> a -> b
$ [Maybe ChResponse] -> IO [Maybe ChResponse]
forall a. a -> IO a
evaluate [Maybe ChResponse]
res IO [Maybe ChResponse]
-> (ErrorCall -> IO [Maybe ChResponse]) -> IO [Maybe ChResponse]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \ex :: ErrorCall
ex@ErrorCall{} -> do
      Maybe String
md <- String -> IO (Maybe String)
lookupEnv' String
"CABAL_HELPER_DEBUG"
      let msg :: String
msg = String
"readHelper: exception: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ErrorCall -> String
forall a. Show a => a -> String
show ErrorCall
ex String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
      String -> IO [Maybe ChResponse]
forall a. String -> IO a
panicIO (String -> IO [Maybe ChResponse])
-> String -> IO [Maybe ChResponse]
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ case Maybe String
md of
        Maybe String
Nothing -> String
"\n  for more information set the environment variable CABAL_HELPER_DEBUG and try again"
        Just String
_ -> String
"\n  output:\n'"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

invokeHelper
    :: QueryEnvI c pt
    -> FilePath
    -> CabalFile
    -> DistDirLib
    -> [String]
    -> IO String
invokeHelper :: QueryEnvI c pt
-> String -> CabalFile -> DistDirLib -> [String] -> IO String
invokeHelper
  QueryEnv {IORef (c pt)
IORef (CacheKeyCache pt)
Programs
DistDir pt
ProjLoc pt
ReadProcessWithCwdAndEnv
CallProcessWithCwdAndEnv ()
qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheRef :: IORef (c pt)
qeDistDir :: DistDir pt
qeProjLoc :: ProjLoc pt
qePrograms :: Programs
qeCallProcess :: CallProcessWithCwdAndEnv ()
qeReadProcess :: ReadProcessWithCwdAndEnv
qeCacheRef :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheKeys :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qePrograms :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qeCallProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeReadProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
..}
  String
exe
  (CabalFile String
cabal_file_path)
  (DistDirLib String
distdir)
  [String]
args0
  = do
    let args1 :: [String]
args1 = String
cabal_file_path String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
distdir String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args0
    String -> IO String
forall a. a -> IO a
evaluate (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReadProcessWithCwdAndEnv
qeReadProcess String
"" Maybe String
forall a. Maybe a
Nothing [] String
exe [String]
args1 IO String -> (IOException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
      \(IOException
_ :: E.IOException) ->
        String -> IO String
forall a. String -> IO a
panicIO (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [String
"invokeHelper", String
": ", String
exe, String
" "
          , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show [String]
args1)
          , String
" failed!"
          ]

-- | Make sure the appropriate helper executable for the given project is
-- installed and ready to run queries.
--
-- The idea is you can run this at a convinient time instead of having the
-- helper compilation happen during a time-sensitive user interaction. This
-- will however happen automatically as needed if you don't run it first.
prepare :: Query pt ()
prepare :: Query pt ()
prepare = (QueryEnv pt -> IO ()) -> Query pt ()
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO ()) -> Query pt ())
-> (QueryEnv pt -> IO ()) -> Query pt ()
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> do
  PreInfo pt
pre_info <- QueryEnv pt -> IO (PreInfo pt)
forall a (b :: ProjType -> *) c (pt :: ProjType).
QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo QueryEnv pt
qe
  ProjInfo pt
proj_info <- QueryEnv pt -> IO (ProjInfo pt)
forall (pt :: ProjType). QueryEnv pt -> IO (ProjInfo pt)
getProjInfo QueryEnv pt
qe
  CabalVersion
cabal_ver <- QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
forall (pt :: ProjType).
QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
getCabalLibVersion QueryEnv pt
qe Reconfigured pt
forall (pt :: ProjType). Reconfigured pt
Haven'tReconfigured ProjInfo pt
proj_info
  IO (Helper pt) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Helper pt) -> IO ()) -> IO (Helper pt) -> IO ()
forall a b. (a -> b) -> a -> b
$ QueryEnv pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
getHelper QueryEnv pt
qe PreInfo pt
pre_info ProjInfo pt
proj_info CabalVersion
cabal_ver

-- | Create @cabal_macros.h@, @Paths_\<pkg\>.hs@ and other generated files
-- in the usual place. See 'Distribution.Simple.Build.initialBuildSteps'.
--
-- This is usually only needed on the first load of a unit or after the
-- cabal file changes.
writeAutogenFiles :: Unit pt -> Query pt ()
writeAutogenFiles :: Unit pt -> Query pt ()
writeAutogenFiles Unit pt
unit = (QueryEnv pt -> IO ()) -> Query pt ()
forall (pt :: ProjType) a. (QueryEnv pt -> IO a) -> Query pt a
Query ((QueryEnv pt -> IO ()) -> Query pt ())
-> (QueryEnv pt -> IO ()) -> Query pt ()
forall a b. (a -> b) -> a -> b
$ \QueryEnv pt
qe -> do
  PreInfo pt
pre_info <- QueryEnv pt -> IO (PreInfo pt)
forall a (b :: ProjType -> *) c (pt :: ProjType).
QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo QueryEnv pt
qe
  ProjInfo pt
proj_info <- QueryEnv pt -> IO (ProjInfo pt)
forall (pt :: ProjType). QueryEnv pt -> IO (ProjInfo pt)
getProjInfo QueryEnv pt
qe
  CabalVersion
cabal_ver <- QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
forall (pt :: ProjType).
QueryEnv pt -> Reconfigured pt -> ProjInfo pt -> IO CabalVersion
getCabalLibVersion QueryEnv pt
qe Reconfigured pt
forall (pt :: ProjType). Reconfigured pt
Haven'tReconfigured ProjInfo pt
proj_info
  Helper pt
helper <- QueryEnv pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
getHelper QueryEnv pt
qe PreInfo pt
pre_info ProjInfo pt
proj_info CabalVersion
cabal_ver
  IO [Maybe ChResponse] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Maybe ChResponse] -> IO ()) -> IO [Maybe ChResponse] -> IO ()
forall a b. (a -> b) -> a -> b
$ Helper pt -> Unit pt -> [String] -> IO [Maybe ChResponse]
forall (pt :: ProjType).
Helper pt -> Unit pt -> [String] -> IO [Maybe ChResponse]
runHelper Helper pt
helper Unit pt
unit [String
"write-autogen-files"]

-- | Get the path to the sandbox package-db in a project
getSandboxPkgDb
    :: String
    -- ^ Cabal build platform, i.e. @buildPlatform@
    -> GHC.GhcVersion
    -- ^ GHC version (@cProjectVersion@ is your friend)
    -> FilePath
    -- ^ Path to the project directory, i.e. a directory containing a
    -- @cabal.sandbox.config@ file
    -> IO (Maybe FilePath)
getSandboxPkgDb :: String -> GhcVersion -> String -> IO (Maybe String)
getSandboxPkgDb String
buildPlat GhcVersion
ghcVer String
projdir =
  String -> GhcVersion -> String -> IO (Maybe String)
CabalHelper.Compiletime.Sandbox.getSandboxPkgDb String
buildPlat GhcVersion
ghcVer String
projdir

buildPlatform :: String
buildPlatform :: String
buildPlatform = Platform -> String
forall a. Pretty a => a -> String
display Platform
Distribution.System.buildPlatform

lookupEnv' :: String -> IO (Maybe String)
lookupEnv' :: String -> IO (Maybe String)
lookupEnv' String
k = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k ([(String, String)] -> Maybe String)
-> IO [(String, String)] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment

withVerbosity :: (Verbose => IO a) -> IO a
withVerbosity :: (Verbose => IO a) -> IO a
withVerbosity Verbose => IO a
act = do
  Maybe String
x <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup  String
"CABAL_HELPER_DEBUG" ([(String, String)] -> Maybe String)
-> IO [(String, String)] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
  let ?verbose = \level ->
        case x >>= readMaybe of
          Just x | x >= level -> True
          _ -> False
  IO a
Verbose => IO a
act

getConfProgs :: QueryEnvI (QCProgs a b) pt -> IO Programs
getConfProgs :: QueryEnvI (QCProgs a b) pt -> IO Programs
getConfProgs QueryEnvI (QCProgs a b) pt
qe = do
  PreInfo pt
pre_info <- QueryEnvI (QCProgs a b) pt -> IO (PreInfo pt)
forall a (b :: ProjType -> *) c (pt :: ProjType).
QueryEnvI (QCPreInfo a b c) pt -> IO (PreInfo pt)
getPreInfo QueryEnvI (QCProgs a b) pt
qe
  QueryEnvI (QCProgs a b) pt
-> Cached
     (QueryCacheI PreInfo Programs a b pt)
     (CacheKeyCache pt)
     Programs
     Programs
-> IO Programs
forall (a :: ProjType -> *) b (c :: ProjType -> *) d
       (pt :: ProjType) k v.
QueryEnvI (QueryCacheI a b c d) pt
-> Cached (QueryCacheI a b c d pt) (CacheKeyCache pt) k v -> IO v
cached QueryEnvI (QCProgs a b) pt
qe (Cached
   (QueryCacheI PreInfo Programs a b pt)
   (CacheKeyCache pt)
   Programs
   Programs
 -> IO Programs)
-> Cached
     (QueryCacheI PreInfo Programs a b pt)
     (CacheKeyCache pt)
     Programs
     Programs
-> IO Programs
forall a b. (a -> b) -> a -> b
$ Cached :: forall c ckc k v.
(c -> Maybe (k, v))
-> (c -> (k, v) -> c)
-> (ckc -> Maybe k)
-> (ckc -> k -> ckc)
-> IO k
-> (k -> k -> Bool)
-> (k -> IO v)
-> Cached c ckc k v
Cached
    { cGet :: QueryCacheI PreInfo Programs a b pt -> Maybe (Programs, Programs)
cGet = QueryCacheI PreInfo Programs a b pt -> Maybe (Programs, Programs)
forall (pre_info :: ProjType -> *) progs
       (proj_info :: ProjType -> *) unit_info (pt :: ProjType).
QueryCacheI pre_info progs proj_info unit_info pt
-> Maybe (Programs, progs)
qcConfProgs
    , cSet :: QueryCacheI PreInfo Programs a b pt
-> (Programs, Programs) -> QueryCacheI PreInfo Programs a b pt
cSet = \QueryCacheI PreInfo Programs a b pt
a (Programs, Programs)
b -> QueryCacheI PreInfo Programs a b pt
a { qcConfProgs :: Maybe (Programs, Programs)
qcConfProgs = (Programs, Programs) -> Maybe (Programs, Programs)
forall a. a -> Maybe a
Just (Programs, Programs)
b }
    , cGetKey :: CacheKeyCache pt -> Maybe Programs
cGetKey = Maybe Programs -> CacheKeyCache pt -> Maybe Programs
forall a b. a -> b -> a
const Maybe Programs
forall a. Maybe a
Nothing
    , cSetKey :: CacheKeyCache pt -> Programs -> CacheKeyCache pt
cSetKey = CacheKeyCache pt -> Programs -> CacheKeyCache pt
forall a b. a -> b -> a
const
    , cCheckKey :: IO Programs
cCheckKey = Programs -> IO Programs
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryEnvI (QCProgs a b) pt -> Programs
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qePrograms QueryEnvI (QCProgs a b) pt
qe)
    , cKeyValid :: Programs -> Programs -> Bool
cKeyValid = Programs -> Programs -> Bool
forall a. Eq a => a -> a -> Bool
(==)
    , cRegen :: Programs -> IO Programs
cRegen = \Programs
_k -> QueryEnvI (QCProgs a b) pt -> PreInfo pt -> IO Programs
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> PreInfo pt -> IO Programs
configurePrograms QueryEnvI (QCProgs a b) pt
qe PreInfo pt
pre_info
    }

-- | Fixup program paths as appropriate for current project-type and bring
-- 'Programs' into scope as an implicit parameter.
configurePrograms :: QueryEnvI c pt -> PreInfo pt -> IO Programs
configurePrograms :: QueryEnvI c pt -> PreInfo pt -> IO Programs
configurePrograms qe :: QueryEnvI c pt
qe@QueryEnv{IORef (c pt)
IORef (CacheKeyCache pt)
Programs
DistDir pt
ProjLoc pt
ReadProcessWithCwdAndEnv
CallProcessWithCwdAndEnv ()
qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheRef :: IORef (c pt)
qeDistDir :: DistDir pt
qeProjLoc :: ProjLoc pt
qePrograms :: Programs
qeCallProcess :: CallProcessWithCwdAndEnv ()
qeReadProcess :: ReadProcessWithCwdAndEnv
qeCacheRef :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheKeys :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qePrograms :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qeCallProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeReadProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
..} PreInfo pt
pre_info = (Verbose => IO Programs) -> IO Programs
forall a. (Verbose => IO a) -> IO a
withVerbosity ((Verbose => IO Programs) -> IO Programs)
-> (Verbose => IO Programs) -> IO Programs
forall a b. (a -> b) -> a -> b
$ do
  SProjType pt -> Programs -> IO Programs
forall (pt :: ProjType). SProjType pt -> Programs -> IO Programs
patchBuildToolProgs (QueryEnvI c pt -> SProjType pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> SProjType pt
projTypeOfQueryEnv QueryEnvI c pt
qe) (Programs -> IO Programs)
-> (Programs -> IO Programs) -> Programs -> IO Programs
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Verbose => Programs -> IO Programs
Programs -> IO Programs
guessCompProgramPaths (Programs -> IO Programs) -> Programs -> IO Programs
forall a b. (a -> b) -> a -> b
$
    case PreInfo pt
pre_info of
      PreInfoStack StackProjPaths
projPaths ->
        StackProjPaths -> Programs -> Programs
Stack.patchCompPrograms StackProjPaths
projPaths Programs
qePrograms
      PreInfo pt
_ -> Programs
qePrograms

newtype Helper pt
  = Helper { Helper pt -> Unit pt -> [String] -> IO [Maybe ChResponse]
runHelper :: Unit pt -> [String] -> IO [Maybe ChResponse] }

getHelper :: QueryEnvI c pt -> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
getHelper :: QueryEnvI c pt
-> PreInfo pt -> ProjInfo pt -> CabalVersion -> IO (Helper pt)
getHelper qe :: QueryEnvI c pt
qe@QueryEnv{IORef (c pt)
IORef (CacheKeyCache pt)
Programs
DistDir pt
ProjLoc pt
ReadProcessWithCwdAndEnv
CallProcessWithCwdAndEnv ()
qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheRef :: IORef (c pt)
qeDistDir :: DistDir pt
qeProjLoc :: ProjLoc pt
qePrograms :: Programs
qeCallProcess :: CallProcessWithCwdAndEnv ()
qeReadProcess :: ReadProcessWithCwdAndEnv
qeCacheRef :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheKeys :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qePrograms :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qeCallProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeReadProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
..} PreInfo pt
_pre_info ProjInfo pt
_proj_info CabalVersion
cabal_ver
  | CabalVersion
cabal_ver CabalVersion -> CabalVersion -> Bool
forall a. Eq a => a -> a -> Bool
== CabalVersion
bultinCabalVersion = Helper pt -> IO (Helper pt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Helper pt -> IO (Helper pt)) -> Helper pt -> IO (Helper pt)
forall a b. (a -> b) -> a -> b
$ (Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt
forall (pt :: ProjType).
(Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt
Helper ((Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt)
-> (Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt
forall a b. (a -> b) -> a -> b
$
      \Unit{ uDistDir :: forall (pt :: ProjType). Unit pt -> DistDirLib
uDistDir=DistDirLib String
distdir
           , uPackage :: forall (pt :: ProjType). Unit pt -> Package' ()
uPackage=Package{pCabalFile :: forall units. Package' units -> CabalFile
pCabalFile=CabalFile String
cabal_file}
           } [String]
args ->
        let pt :: String
pt = SProjType pt -> String
forall (pt :: ProjType). SProjType pt -> String
dispHelperProjectType (QueryEnvI c pt -> SProjType pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> SProjType pt
projTypeOfQueryEnv QueryEnvI c pt
qe) in
        [String] -> IO [Maybe ChResponse]
helper_main ([String] -> IO [Maybe ChResponse])
-> [String] -> IO [Maybe ChResponse]
forall a b. (a -> b) -> a -> b
$ String
cabal_file String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
distdir String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
pt String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
getHelper qe :: QueryEnvI c pt
qe@QueryEnv{IORef (c pt)
IORef (CacheKeyCache pt)
Programs
DistDir pt
ProjLoc pt
ReadProcessWithCwdAndEnv
CallProcessWithCwdAndEnv ()
qeCacheKeys :: IORef (CacheKeyCache pt)
qeCacheRef :: IORef (c pt)
qeDistDir :: DistDir pt
qeProjLoc :: ProjLoc pt
qePrograms :: Programs
qeCallProcess :: CallProcessWithCwdAndEnv ()
qeReadProcess :: ReadProcessWithCwdAndEnv
qeCacheRef :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (c pt)
qeCacheKeys :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> IORef (CacheKeyCache pt)
qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qePrograms :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qeCallProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeReadProcess :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
..} PreInfo pt
pre_info ProjInfo pt
proj_info CabalVersion
cabal_ver = do
  (Verbose => IO (Helper pt)) -> IO (Helper pt)
forall a. (Verbose => IO a) -> IO a
withVerbosity ((Verbose => IO (Helper pt)) -> IO (Helper pt))
-> (Verbose => IO (Helper pt)) -> IO (Helper pt)
forall a b. (a -> b) -> a -> b
$ do
    let ?progs = qePrograms
    TimeSpec
t0 <- Clock -> IO TimeSpec
Clock.getTime Clock
Monotonic
    Either ExitCode String
eexe <- Env => CompHelperEnv -> IO (Either ExitCode String)
CompHelperEnv -> IO (Either ExitCode String)
compileHelper (CompHelperEnv -> IO (Either ExitCode String))
-> CompHelperEnv -> IO (Either ExitCode String)
forall a b. (a -> b) -> a -> b
$ ProjLoc pt
-> DistDir pt
-> PreInfo pt
-> ProjInfo pt
-> CabalVersion
-> CompHelperEnv
forall (pt :: ProjType).
Verbose =>
ProjLoc pt
-> DistDir pt
-> PreInfo pt
-> ProjInfo pt
-> CabalVersion
-> CompHelperEnv
mkCompHelperEnv ProjLoc pt
qeProjLoc DistDir pt
qeDistDir PreInfo pt
pre_info ProjInfo pt
proj_info CabalVersion
cabal_ver
    TimeSpec
t1 <- Clock -> IO TimeSpec
Clock.getTime Clock
Monotonic
    let dt :: Float
dt = (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
10Float -> Integer -> Float
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
9) (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Integer -> Float
forall a. Num a => Integer -> a
fromInteger (Integer -> Float) -> Integer -> Float
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Integer) -> TimeSpec -> Integer
forall a b. (a -> b) -> a -> b
$ TimeSpec -> TimeSpec -> TimeSpec
Clock.diffTimeSpec TimeSpec
t0 TimeSpec
t1
        dt :: Float
    String -> IO ()
forall (m :: * -> *). (MonadIO m, Verbose) => String -> m ()
vLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Float -> String
forall r. PrintfType r => String -> r
printf String
"compileHelper took %.5fs" Float
dt
    case Either ExitCode String
eexe of
      Left ExitCode
rv ->
        String -> IO (Helper pt)
forall a. String -> IO a
panicIO (String -> IO (Helper pt)) -> String -> IO (Helper pt)
forall a b. (a -> b) -> a -> b
$ String
"compileHelper': compiling helper failed! exit code "String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
rv
      Right String
exe ->
        let pt :: String
pt = SProjType pt -> String
forall (pt :: ProjType). SProjType pt -> String
dispHelperProjectType (QueryEnvI c pt -> SProjType pt
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> SProjType pt
projTypeOfQueryEnv QueryEnvI c pt
qe) in
        Helper pt -> IO (Helper pt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Helper pt -> IO (Helper pt)) -> Helper pt -> IO (Helper pt)
forall a b. (a -> b) -> a -> b
$ (Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt
forall (pt :: ProjType).
(Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt
Helper ((Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt)
-> (Unit pt -> [String] -> IO [Maybe ChResponse]) -> Helper pt
forall a b. (a -> b) -> a -> b
$ \Unit{DistDirLib
uDistDir :: DistDirLib
uDistDir :: forall (pt :: ProjType). Unit pt -> DistDirLib
uDistDir, uPackage :: forall (pt :: ProjType). Unit pt -> Package' ()
uPackage=Package{CabalFile
pCabalFile :: CabalFile
pCabalFile :: forall units. Package' units -> CabalFile
pCabalFile}} [String]
args ->
          QueryEnvI c pt
-> String
-> CabalFile
-> DistDirLib
-> [String]
-> IO [Maybe ChResponse]
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> String
-> CabalFile
-> DistDirLib
-> [String]
-> IO [Maybe ChResponse]
readHelper QueryEnvI c pt
qe String
exe CabalFile
pCabalFile DistDirLib
uDistDir (String
pt String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args)

dispHelperProjectType :: SProjType pt -> String
dispHelperProjectType :: SProjType pt -> String
dispHelperProjectType (SCabal SCabalProjType pt
SCV1) = String
"v1"
--  ^ v1-build needs a last minute addition of the inplace package-db
-- beyond what lbi has
dispHelperProjectType (SCabal SCabalProjType pt
SCV2) = String
"v2"
dispHelperProjectType SProjType pt
SStack        = String
"v2"
--  ^ stack also embeds all necessary options into lbi like v2

mkCompHelperEnv
    :: Verbose
    => ProjLoc pt
    -> DistDir pt
    -> PreInfo pt
    -> ProjInfo pt
    -> CabalVersion
    -> CompHelperEnv
mkCompHelperEnv :: ProjLoc pt
-> DistDir pt
-> PreInfo pt
-> ProjInfo pt
-> CabalVersion
-> CompHelperEnv
mkCompHelperEnv
  ProjLoc pt
projloc
  (DistDirCabal SCabalProjType pt
SCV1 String
distdir)
  PreInfo pt
PreInfoCabal
  ProjInfo {}
  CabalVersion
cabal_ver
  = CompHelperEnv :: forall cv.
cv
-> [PackageDbDir]
-> String
-> Maybe (Map UnitId Unit)
-> Maybe String
-> String
-> CompHelperEnv' cv
CompHelperEnv
    { cheCabalVer :: CabalVersion
cheCabalVer = CabalVersion
cabal_ver
    , cheProjDir :: String
cheProjDir  = ProjLoc ('Cabal 'CV1) -> String
forall (cpt :: CabalProjType). ProjLoc ('Cabal cpt) -> String
plCabalProjectDir ProjLoc pt
ProjLoc ('Cabal 'CV1)
projloc
    , cheProjLocalCacheDir :: String
cheProjLocalCacheDir = String
distdir
    , chePkgDb :: [PackageDbDir]
chePkgDb    = []
    , chePjUnits :: Maybe (Map UnitId Unit)
chePjUnits = Maybe (Map UnitId Unit)
forall a. Maybe a
Nothing
    , cheDistV2 :: Maybe String
cheDistV2 = Maybe String
forall a. Maybe a
Nothing
    }
mkCompHelperEnv
  ProjLoc pt
projloc
  (DistDirCabal SCabalProjType pt
SCV2 String
distdir)
  PreInfo pt
PreInfoCabal
  ProjInfo{piImpl :: forall (pt :: ProjType). ProjInfo pt -> ProjInfoImpl pt
piImpl=ProjInfoV2{piV2Plan :: ProjInfoImpl ('Cabal 'CV2) -> PlanJson
piV2Plan=PlanJson
plan}}
  CabalVersion
cabal_ver
  = CompHelperEnv :: forall cv.
cv
-> [PackageDbDir]
-> String
-> Maybe (Map UnitId Unit)
-> Maybe String
-> String
-> CompHelperEnv' cv
CompHelperEnv {String
[PackageDbDir]
Maybe String
Maybe (Map UnitId Unit)
CabalVersion
forall a. [a]
cheDistV2 :: Maybe String
chePjUnits :: Maybe (Map UnitId Unit)
chePkgDb :: forall a. [a]
cheProjLocalCacheDir :: String
cheCabalVer :: CabalVersion
cheProjDir :: String
cheDistV2 :: Maybe String
chePjUnits :: Maybe (Map UnitId Unit)
chePkgDb :: [PackageDbDir]
cheProjLocalCacheDir :: String
cheProjDir :: String
cheCabalVer :: CabalVersion
..}
  where
    cheProjDir :: String
cheProjDir  = ProjLoc ('Cabal 'CV2) -> String
forall (cpt :: CabalProjType). ProjLoc ('Cabal cpt) -> String
plCabalProjectDir ProjLoc pt
ProjLoc ('Cabal 'CV2)
projloc
    cheCabalVer :: CabalVersion
cheCabalVer = CabalVersion
cabal_ver
    cheProjLocalCacheDir :: String
cheProjLocalCacheDir = String
distdir String -> String -> String
</> String
"cache"
    chePkgDb :: [a]
chePkgDb    = []
    chePjUnits :: Maybe (Map UnitId Unit)
chePjUnits  = Map UnitId Unit -> Maybe (Map UnitId Unit)
forall a. a -> Maybe a
Just (Map UnitId Unit -> Maybe (Map UnitId Unit))
-> Map UnitId Unit -> Maybe (Map UnitId Unit)
forall a b. (a -> b) -> a -> b
$ PlanJson -> Map UnitId Unit
pjUnits PlanJson
plan
    cheDistV2 :: Maybe String
cheDistV2   = String -> Maybe String
forall a. a -> Maybe a
Just String
distdir
mkCompHelperEnv
  (ProjLocStackYaml String
stack_yaml)
  (DistDirStack Maybe RelativePath
mworkdir)
  PreInfoStack
    { piStackProjPaths :: PreInfo 'Stack -> StackProjPaths
piStackProjPaths=StackProjPaths
      { PackageDbDir
sppGlobalPkgDb :: StackProjPaths -> PackageDbDir
sppGlobalPkgDb :: PackageDbDir
sppGlobalPkgDb, PackageDbDir
sppSnapPkgDb :: StackProjPaths -> PackageDbDir
sppSnapPkgDb :: PackageDbDir
sppSnapPkgDb, PackageDbDir
sppLocalPkgDb :: StackProjPaths -> PackageDbDir
sppLocalPkgDb :: PackageDbDir
sppLocalPkgDb }
    }
  ProjInfo {}
  CabalVersion
cabal_ver
  = let workdir :: String
workdir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
".stack-work" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ RelativePath -> String
unRelativePath (RelativePath -> String) -> Maybe RelativePath -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RelativePath
mworkdir in
    let projdir :: String
projdir = String -> String
takeDirectory String
stack_yaml in
    CompHelperEnv :: forall cv.
cv
-> [PackageDbDir]
-> String
-> Maybe (Map UnitId Unit)
-> Maybe String
-> String
-> CompHelperEnv' cv
CompHelperEnv
    { cheCabalVer :: CabalVersion
cheCabalVer = CabalVersion
cabal_ver
    , cheProjDir :: String
cheProjDir  = String
projdir
    , cheProjLocalCacheDir :: String
cheProjLocalCacheDir = String
projdir String -> String -> String
</> String
workdir
    , chePkgDb :: [PackageDbDir]
chePkgDb    = [PackageDbDir
sppGlobalPkgDb, PackageDbDir
sppSnapPkgDb, PackageDbDir
sppLocalPkgDb]
    , chePjUnits :: Maybe (Map UnitId Unit)
chePjUnits = Maybe (Map UnitId Unit)
forall a. Maybe a
Nothing
    , cheDistV2 :: Maybe String
cheDistV2 = Maybe String
forall a. Maybe a
Nothing
    }