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

-- Special wrapper extracting only 1 RawPackageLocationImmutable
-- serialization should not produce locations with multiple subdirs
-- so we should be OK using just a head element
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"