{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Lock
( lockCachedWanted
, LockedLocation(..)
, Locked(..)
) where
import Pantry.Internal.AesonExtended
import Data.ByteString.Builder (byteString)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Yaml as Yaml
import Pantry
import Path (parent)
import Path.Extended (addExtension)
import Path.IO (doesFileExist)
import Stack.Prelude
import Stack.SourceMap
import Stack.Types.Config
import Stack.Types.SourceMap
data LockedLocation a b = LockedLocation
{ LockedLocation a b -> a
llOriginal :: a
, LockedLocation a b -> b
llCompleted :: b
} deriving (LockedLocation a b -> LockedLocation a b -> Bool
(LockedLocation a b -> LockedLocation a b -> Bool)
-> (LockedLocation a b -> LockedLocation a b -> Bool)
-> Eq (LockedLocation a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
LockedLocation a b -> LockedLocation a b -> Bool
/= :: LockedLocation a b -> LockedLocation a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
LockedLocation a b -> LockedLocation a b -> Bool
== :: LockedLocation a b -> LockedLocation a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
LockedLocation a b -> LockedLocation a b -> Bool
Eq, Int -> LockedLocation a b -> ShowS
[LockedLocation a b] -> ShowS
LockedLocation a b -> String
(Int -> LockedLocation a b -> ShowS)
-> (LockedLocation a b -> String)
-> ([LockedLocation a b] -> ShowS)
-> Show (LockedLocation a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> LockedLocation a b -> ShowS
forall a b. (Show a, Show b) => [LockedLocation a b] -> ShowS
forall a b. (Show a, Show b) => LockedLocation a b -> String
showList :: [LockedLocation a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [LockedLocation a b] -> ShowS
show :: LockedLocation a b -> String
$cshow :: forall a b. (Show a, Show b) => LockedLocation a b -> String
showsPrec :: Int -> LockedLocation a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> LockedLocation a b -> ShowS
Show)
instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where
toJSON :: LockedLocation a b -> Value
toJSON LockedLocation a b
ll =
[Pair] -> Value
object [ Text
"original" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= LockedLocation a b -> a
forall a b. LockedLocation a b -> a
llOriginal LockedLocation a b
ll, Text
"completed" Text -> b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= LockedLocation a b -> b
forall a b. LockedLocation a b -> b
llCompleted LockedLocation a b
ll ]
instance ( FromJSON (WithJSONWarnings (Unresolved a))
, FromJSON (WithJSONWarnings (Unresolved b))
) =>
FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where
parseJSON :: Value
-> Parser (WithJSONWarnings (Unresolved (LockedLocation a b)))
parseJSON =
String
-> (Object -> WarningParser (Unresolved (LockedLocation a b)))
-> Value
-> Parser (WithJSONWarnings (Unresolved (LockedLocation a b)))
forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
"LockedLocation" ((Object -> WarningParser (Unresolved (LockedLocation a b)))
-> Value
-> Parser (WithJSONWarnings (Unresolved (LockedLocation a b))))
-> (Object -> WarningParser (Unresolved (LockedLocation a b)))
-> Value
-> Parser (WithJSONWarnings (Unresolved (LockedLocation a b)))
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
Unresolved a
original <- WarningParser (WithJSONWarnings (Unresolved a))
-> WarningParser (Unresolved a)
forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings (WarningParser (WithJSONWarnings (Unresolved a))
-> WarningParser (Unresolved a))
-> WarningParser (WithJSONWarnings (Unresolved a))
-> WarningParser (Unresolved a)
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Text -> WarningParser (WithJSONWarnings (Unresolved a))
forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"original"
Unresolved b
completed <- WarningParser (WithJSONWarnings (Unresolved b))
-> WarningParser (Unresolved b)
forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings (WarningParser (WithJSONWarnings (Unresolved b))
-> WarningParser (Unresolved b))
-> WarningParser (WithJSONWarnings (Unresolved b))
-> WarningParser (Unresolved b)
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Text -> WarningParser (WithJSONWarnings (Unresolved b))
forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"completed"
Unresolved (LockedLocation a b)
-> WarningParser (Unresolved (LockedLocation a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved (LockedLocation a b)
-> WarningParser (Unresolved (LockedLocation a b)))
-> Unresolved (LockedLocation a b)
-> WarningParser (Unresolved (LockedLocation a b))
forall a b. (a -> b) -> a -> b
$ a -> b -> LockedLocation a b
forall a b. a -> b -> LockedLocation a b
LockedLocation (a -> b -> LockedLocation a b)
-> Unresolved a -> Unresolved (b -> LockedLocation a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unresolved a
original Unresolved (b -> LockedLocation a b)
-> Unresolved b -> Unresolved (LockedLocation a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Unresolved b
completed
newtype SingleRPLI = SingleRPLI { SingleRPLI -> RawPackageLocationImmutable
unSingleRPLI :: RawPackageLocationImmutable}
instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where
parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved SingleRPLI))
parseJSON Value
v =
do
WithJSONWarnings Unresolved (NonEmpty RawPackageLocationImmutable)
unresolvedRPLIs [JSONWarning]
ws <- Value
-> Parser
(WithJSONWarnings
(Unresolved (NonEmpty RawPackageLocationImmutable)))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
let withWarnings :: a -> WithJSONWarnings a
withWarnings a
x = a -> [JSONWarning] -> WithJSONWarnings a
forall a. a -> [JSONWarning] -> WithJSONWarnings a
WithJSONWarnings a
x [JSONWarning]
ws
WithJSONWarnings (Unresolved SingleRPLI)
-> Parser (WithJSONWarnings (Unresolved SingleRPLI))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithJSONWarnings (Unresolved SingleRPLI)
-> Parser (WithJSONWarnings (Unresolved SingleRPLI)))
-> WithJSONWarnings (Unresolved SingleRPLI)
-> Parser (WithJSONWarnings (Unresolved SingleRPLI))
forall a b. (a -> b) -> a -> b
$ Unresolved SingleRPLI -> WithJSONWarnings (Unresolved SingleRPLI)
forall a. a -> WithJSONWarnings a
withWarnings (Unresolved SingleRPLI -> WithJSONWarnings (Unresolved SingleRPLI))
-> Unresolved SingleRPLI
-> WithJSONWarnings (Unresolved SingleRPLI)
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> SingleRPLI
SingleRPLI (RawPackageLocationImmutable -> SingleRPLI)
-> (NonEmpty RawPackageLocationImmutable
-> RawPackageLocationImmutable)
-> NonEmpty RawPackageLocationImmutable
-> SingleRPLI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty RawPackageLocationImmutable -> RawPackageLocationImmutable
forall a. NonEmpty a -> a
NE.head (NonEmpty RawPackageLocationImmutable -> SingleRPLI)
-> Unresolved (NonEmpty RawPackageLocationImmutable)
-> Unresolved SingleRPLI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unresolved (NonEmpty RawPackageLocationImmutable)
unresolvedRPLIs
data Locked = Locked
{ Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
, Locked
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations :: [LockedLocation RawPackageLocationImmutable PackageLocationImmutable]
} deriving (Locked -> Locked -> Bool
(Locked -> Locked -> Bool)
-> (Locked -> Locked -> Bool) -> Eq Locked
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Locked -> Locked -> Bool
$c/= :: Locked -> Locked -> Bool
== :: Locked -> Locked -> Bool
$c== :: Locked -> Locked -> Bool
Eq, Int -> Locked -> ShowS
[Locked] -> ShowS
Locked -> String
(Int -> Locked -> ShowS)
-> (Locked -> String) -> ([Locked] -> ShowS) -> Show Locked
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Locked] -> ShowS
$cshowList :: [Locked] -> ShowS
show :: Locked -> String
$cshow :: Locked -> String
showsPrec :: Int -> Locked -> ShowS
$cshowsPrec :: Int -> Locked -> ShowS
Show)
instance ToJSON Locked where
toJSON :: Locked -> Value
toJSON Locked {[LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
[LockedLocation RawSnapshotLocation SnapshotLocation]
lckPkgImmutableLocations :: [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
lckPkgImmutableLocations :: Locked
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckSnapshotLocations :: Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
..} =
[Pair] -> Value
object
[ Text
"snapshots" Text
-> [LockedLocation RawSnapshotLocation SnapshotLocation] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations
, Text
"packages" Text
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations
]
instance FromJSON (WithJSONWarnings (Unresolved Locked)) where
parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved Locked))
parseJSON = String
-> (Object -> WarningParser (Unresolved Locked))
-> Value
-> Parser (WithJSONWarnings (Unresolved Locked))
forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
"Locked" ((Object -> WarningParser (Unresolved Locked))
-> Value -> Parser (WithJSONWarnings (Unresolved Locked)))
-> (Object -> WarningParser (Unresolved Locked))
-> Value
-> Parser (WithJSONWarnings (Unresolved Locked))
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
[Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
snapshots <- WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation))]
-> WarningParser
[Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT (WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation))]
-> WarningParser
[Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)])
-> WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation))]
-> WarningParser
[Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
forall a b. (a -> b) -> a -> b
$ Object
o Object
-> Text
-> WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation))]
forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"snapshots"
[Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
packages <- WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation SingleRPLI PackageLocationImmutable))]
-> WarningParser
[Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT (WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation SingleRPLI PackageLocationImmutable))]
-> WarningParser
[Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)])
-> WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation SingleRPLI PackageLocationImmutable))]
-> WarningParser
[Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
forall a b. (a -> b) -> a -> b
$ Object
o Object
-> Text
-> WarningParser
[WithJSONWarnings
(Unresolved (LockedLocation SingleRPLI PackageLocationImmutable))]
forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"packages"
let unwrap :: LockedLocation SingleRPLI b
-> LockedLocation RawPackageLocationImmutable b
unwrap LockedLocation SingleRPLI b
ll = LockedLocation SingleRPLI b
ll { llOriginal :: RawPackageLocationImmutable
llOriginal = SingleRPLI -> RawPackageLocationImmutable
unSingleRPLI (LockedLocation SingleRPLI b -> SingleRPLI
forall a b. LockedLocation a b -> a
llOriginal LockedLocation SingleRPLI b
ll) }
Unresolved Locked -> WarningParser (Unresolved Locked)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved Locked -> WarningParser (Unresolved Locked))
-> Unresolved Locked -> WarningParser (Unresolved Locked)
forall a b. (a -> b) -> a -> b
$ [LockedLocation RawSnapshotLocation SnapshotLocation]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked
Locked ([LockedLocation RawSnapshotLocation SnapshotLocation]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked)
-> Unresolved [LockedLocation RawSnapshotLocation SnapshotLocation]
-> Unresolved
([LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
-> Unresolved [LockedLocation RawSnapshotLocation SnapshotLocation]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
snapshots Unresolved
([LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked)
-> Unresolved
[LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Unresolved Locked
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((LockedLocation SingleRPLI PackageLocationImmutable
-> LockedLocation
RawPackageLocationImmutable PackageLocationImmutable)
-> [LockedLocation SingleRPLI PackageLocationImmutable]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map LockedLocation SingleRPLI PackageLocationImmutable
-> LockedLocation
RawPackageLocationImmutable PackageLocationImmutable
forall b.
LockedLocation SingleRPLI b
-> LockedLocation RawPackageLocationImmutable b
unwrap ([LockedLocation SingleRPLI PackageLocationImmutable]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable])
-> Unresolved [LockedLocation SingleRPLI PackageLocationImmutable]
-> Unresolved
[LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
-> Unresolved [LockedLocation SingleRPLI PackageLocationImmutable]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
packages)
loadYamlThrow
:: HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadYamlThrow :: (Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadYamlThrow Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
Value
val <- IO Value -> RIO env Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> RIO env Value) -> IO Value -> RIO env Value
forall a b. (a -> b) -> a -> b
$ String -> IO Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path)
case (Value -> Parser (WithJSONWarnings a))
-> Value -> Either String (WithJSONWarnings a)
forall a b. (a -> Parser b) -> a -> Either String b
Yaml.parseEither Value -> Parser (WithJSONWarnings a)
parser Value
val of
Left String
err -> ParseException -> RIO env a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ParseException -> RIO env a) -> ParseException -> RIO env a
forall a b. (a -> b) -> a -> b
$ String -> ParseException
Yaml.AesonException String
err
Right (WithJSONWarnings a
res [JSONWarning]
warnings) -> do
String -> [JSONWarning] -> RIO env ()
forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
String -> [JSONWarning] -> m ()
logJSONWarnings (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path) [JSONWarning]
warnings
a -> RIO env a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
lockCachedWanted ::
(HasPantryConfig env, HasRunner env)
=> Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env ( SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted :: Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted Path Abs File
stackFile RawSnapshotLocation
resolver Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillWanted = do
Path Abs File
lockFile <- IO (Path Abs File) -> RIO env (Path Abs File)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs File) -> RIO env (Path Abs File))
-> IO (Path Abs File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ String -> Path Abs File -> IO (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
addExtension String
".lock" Path Abs File
stackFile
let getLockExists :: RIO env Bool
getLockExists = Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
lockFile
LockFileBehavior
lfb <- Getting LockFileBehavior env LockFileBehavior
-> RIO env LockFileBehavior
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LockFileBehavior env LockFileBehavior
forall env. HasRunner env => SimpleGetter env LockFileBehavior
lockFileBehaviorL
Bool
readLockFile <-
case LockFileBehavior
lfb of
LockFileBehavior
LFBIgnore -> Bool -> RIO env Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
LockFileBehavior
LFBReadWrite -> RIO env Bool
getLockExists
LockFileBehavior
LFBReadOnly -> RIO env Bool
getLockExists
LockFileBehavior
LFBErrorOnWrite -> RIO env Bool
getLockExists
Locked
locked <-
if Bool
readLockFile
then do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Using package location completions from a lock file"
Unresolved Locked
unresolvedLocked <- (Value -> Parser (WithJSONWarnings (Unresolved Locked)))
-> Path Abs File -> RIO env (Unresolved Locked)
forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadYamlThrow Value -> Parser (WithJSONWarnings (Unresolved Locked))
forall a. FromJSON a => Value -> Parser a
parseJSON Path Abs File
lockFile
Maybe (Path Abs Dir) -> Unresolved Locked -> RIO env Locked
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
stackFile) Unresolved Locked
unresolvedLocked
else do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Not reading lock file"
Locked -> RIO env Locked
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Locked -> RIO env Locked) -> Locked -> RIO env Locked
forall a b. (a -> b) -> a -> b
$ [LockedLocation RawSnapshotLocation SnapshotLocation]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked
Locked [] []
let toMap :: Ord a => [LockedLocation a b] -> Map a b
toMap :: [LockedLocation a b] -> Map a b
toMap = [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, b)] -> Map a b)
-> ([LockedLocation a b] -> [(a, b)])
-> [LockedLocation a b]
-> Map a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LockedLocation a b -> (a, b)) -> [LockedLocation a b] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\LockedLocation a b
ll -> (LockedLocation a b -> a
forall a b. LockedLocation a b -> a
llOriginal LockedLocation a b
ll, LockedLocation a b -> b
forall a b. LockedLocation a b -> b
llCompleted LockedLocation a b
ll))
slocCache :: Map RawSnapshotLocation SnapshotLocation
slocCache = [LockedLocation RawSnapshotLocation SnapshotLocation]
-> Map RawSnapshotLocation SnapshotLocation
forall a b. Ord a => [LockedLocation a b] -> Map a b
toMap ([LockedLocation RawSnapshotLocation SnapshotLocation]
-> Map RawSnapshotLocation SnapshotLocation)
-> [LockedLocation RawSnapshotLocation SnapshotLocation]
-> Map RawSnapshotLocation SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations Locked
locked
pkgLocCache :: Map RawPackageLocationImmutable PackageLocationImmutable
pkgLocCache = [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Map RawPackageLocationImmutable PackageLocationImmutable
forall a b. Ord a => [LockedLocation a b] -> Map a b
toMap ([LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Map RawPackageLocationImmutable PackageLocationImmutable)
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Map RawPackageLocationImmutable PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ Locked
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations Locked
locked
(Snapshot
snap, [CompletedSL]
slocCompleted, [CompletedPLI]
pliCompleted) <-
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw RawSnapshotLocation
resolver Map RawSnapshotLocation SnapshotLocation
slocCache Map RawPackageLocationImmutable PackageLocationImmutable
pkgLocCache
let compiler :: WantedCompiler
compiler = Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snap
snPkgs :: Map PackageName (Bool -> RIO env DepPackage)
snPkgs = (PackageName -> SnapshotPackage -> Bool -> RIO env DepPackage)
-> Map PackageName SnapshotPackage
-> Map PackageName (Bool -> RIO env DepPackage)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\PackageName
n SnapshotPackage
p Bool
h -> Bool -> PackageName -> SnapshotPackage -> RIO env DepPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageName -> SnapshotPackage -> RIO env DepPackage
snapToDepPackage Bool
h PackageName
n SnapshotPackage
p) (Snapshot -> Map PackageName SnapshotPackage
snapshotPackages Snapshot
snap)
(SMWanted
wanted, [CompletedPLI]
prjCompleted) <- Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillWanted Map RawPackageLocationImmutable PackageLocationImmutable
pkgLocCache WantedCompiler
compiler Map PackageName (Bool -> RIO env DepPackage)
snPkgs
let lockLocations :: [CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lockLocations = (CompletedPLI
-> LockedLocation
RawPackageLocationImmutable PackageLocationImmutable)
-> [CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map (\(CompletedPLI RawPackageLocationImmutable
r PackageLocationImmutable
c) -> RawPackageLocationImmutable
-> PackageLocationImmutable
-> LockedLocation
RawPackageLocationImmutable PackageLocationImmutable
forall a b. a -> b -> LockedLocation a b
LockedLocation RawPackageLocationImmutable
r PackageLocationImmutable
c)
differentSnapLocs :: CompletedSL
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
differentSnapLocs (CompletedSL RawSnapshotLocation
raw SnapshotLocation
complete)
| RawSnapshotLocation
raw RawSnapshotLocation -> RawSnapshotLocation -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
complete = Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
forall a. Maybe a
Nothing
| Bool
otherwise = LockedLocation RawSnapshotLocation SnapshotLocation
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
forall a. a -> Maybe a
Just (LockedLocation RawSnapshotLocation SnapshotLocation
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation))
-> LockedLocation RawSnapshotLocation SnapshotLocation
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation
-> SnapshotLocation
-> LockedLocation RawSnapshotLocation SnapshotLocation
forall a b. a -> b -> LockedLocation a b
LockedLocation RawSnapshotLocation
raw SnapshotLocation
complete
newLocked :: Locked
newLocked = Locked :: [LockedLocation RawSnapshotLocation SnapshotLocation]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked
Locked { lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations = (CompletedSL
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation))
-> [CompletedSL]
-> [LockedLocation RawSnapshotLocation SnapshotLocation]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CompletedSL
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
differentSnapLocs [CompletedSL]
slocCompleted
, lckPkgImmutableLocations :: [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations =
[CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lockLocations ([CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable])
-> [CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
forall a b. (a -> b) -> a -> b
$ [CompletedPLI]
pliCompleted [CompletedPLI] -> [CompletedPLI] -> [CompletedPLI]
forall a. Semigroup a => a -> a -> a
<> [CompletedPLI]
prjCompleted
}
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Locked
newLocked Locked -> Locked -> Bool
forall a. Eq a => a -> a -> Bool
/= Locked
locked) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
case LockFileBehavior
lfb of
LockFileBehavior
LFBReadWrite ->
Path Abs File -> Builder -> RIO env ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
lockFile (Builder -> RIO env ()) -> Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
byteString (Locked -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Locked
newLocked)
LockFileBehavior
LFBErrorOnWrite -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"You indicated that Stack should error out on writing a lock file"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"I just tried to write the following lock file contents to " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
lockFile)
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Locked -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Locked
newLocked
RIO env ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
LockFileBehavior
LFBIgnore -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
LockFileBehavior
LFBReadOnly -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SMWanted -> RIO env SMWanted
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMWanted
wanted
where
header :: Builder
header =
Builder
"# This file was autogenerated by Stack.\n\
\# You should not edit this file by hand.\n\
\# For more information, please see the documentation at:\n\
\# https://docs.haskellstack.org/en/stable/lock_files\n\n"