{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Stack.Lock
  ( lockCachedWanted
  , LockedLocation (..)
  , Locked (..)
  ) where

import           Data.Aeson.Types ( FromJSON (..), ToJSON, Value, (.=), object )
import           Data.Aeson.WarningParser
                   ( WithJSONWarnings (..), (..:), jsonSubWarnings
                   , jsonSubWarningsT, logJSONWarnings, withObjectWarnings
                   )
import           Data.ByteString.Builder ( byteString )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import           Path ( parent )
import           Path.Extended ( addExtension )
import           Path.IO ( doesFileExist )
import           Stack.Prelude
import           Stack.SourceMap ( snapToDepPackage )
import           Stack.Types.Config.Exception ( ConfigPrettyException (..) )
import           Stack.Types.LockFileBehavior ( LockFileBehavior (..) )
import           Stack.Types.Runner ( HasRunner, lockFileBehaviorL, rslInLogL )
import           Stack.Types.SourceMap ( DepPackage, SMWanted )

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Lock" module.

data LockPrettyException
  = WritingLockFileError (Path Abs File) Locked
  deriving (Int -> LockPrettyException -> ShowS
[LockPrettyException] -> ShowS
LockPrettyException -> String
(Int -> LockPrettyException -> ShowS)
-> (LockPrettyException -> String)
-> ([LockPrettyException] -> ShowS)
-> Show LockPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LockPrettyException -> ShowS
showsPrec :: Int -> LockPrettyException -> ShowS
$cshow :: LockPrettyException -> String
show :: LockPrettyException -> String
$cshowList :: [LockPrettyException] -> ShowS
showList :: [LockPrettyException] -> ShowS
Show, Typeable)

instance Pretty LockPrettyException where
  pretty :: LockPrettyException -> StyleDoc
pretty (WritingLockFileError Path Abs File
lockFile Locked
newLocked) =
    StyleDoc
"[S-1353]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack is configured to report an error on writing a lock file."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack just tried to write the following lock file content to"
         , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
lockFile StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
newLocked'
   where
    newLocked' :: String
newLocked' = Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Locked -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Locked
newLocked

instance Exception LockPrettyException

data LockedLocation a b = LockedLocation
  { forall a b. LockedLocation a b -> a
llOriginal :: a
  , forall a b. 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
$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
/= :: 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
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> LockedLocation a b -> ShowS
showsPrec :: Int -> LockedLocation a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => LockedLocation a b -> String
show :: LockedLocation a b -> String
$cshowList :: forall a b. (Show a, Show b) => [LockedLocation a b] -> ShowS
showList :: [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 [ Key
"original" Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= LockedLocation a b -> a
forall a b. LockedLocation a b -> a
llOriginal LockedLocation a b
ll, Key
"completed" Key -> b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= 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 a. a -> WriterT WarningParserMonoid Parser a
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 a b. Unresolved (a -> b) -> Unresolved a -> Unresolved 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 a. a -> Parser a
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
$c== :: Locked -> Locked -> Bool
== :: Locked -> Locked -> Bool
$c/= :: Locked -> Locked -> Bool
/= :: 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
$cshowsPrec :: Int -> Locked -> ShowS
showsPrec :: Int -> Locked -> ShowS
$cshow :: Locked -> String
show :: Locked -> String
$cshowList :: [Locked] -> ShowS
showList :: [Locked] -> ShowS
Show)

instance ToJSON Locked where
  toJSON :: Locked -> Value
toJSON Locked {[LockedLocation RawSnapshotLocation SnapshotLocation]
[LockedLocation
   RawPackageLocationImmutable PackageLocationImmutable]
lckSnapshotLocations :: Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
lckPkgImmutableLocations :: Locked
-> [LockedLocation
      RawPackageLocationImmutable PackageLocationImmutable]
lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
lckPkgImmutableLocations :: [LockedLocation
   RawPackageLocationImmutable PackageLocationImmutable]
..} =
    [Pair] -> Value
object
      [ Key
"snapshots" Key
-> [LockedLocation RawSnapshotLocation SnapshotLocation] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations
      , Key
"packages" Key
-> [LockedLocation
      RawPackageLocationImmutable PackageLocationImmutable]
-> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [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 a. a -> WriterT WarningParserMonoid Parser a
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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
snapshots Unresolved
  ([LockedLocation
      RawPackageLocationImmutable PackageLocationImmutable]
   -> Locked)
-> Unresolved
     [LockedLocation
        RawPackageLocationImmutable PackageLocationImmutable]
-> Unresolved Locked
forall a b. Unresolved (a -> b) -> Unresolved a -> Unresolved b
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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
packages)

loadYamlThrow ::
     HasLogFunc env
  => (Value -> Yaml.Parser (WithJSONWarnings a))
  -> Path Abs File
  -> RIO env a
loadYamlThrow :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadYamlThrow Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
  Either ParseException Value
eVal <- IO (Either ParseException Value)
-> RIO env (Either ParseException Value)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseException Value)
 -> RIO env (Either ParseException Value))
-> IO (Either ParseException Value)
-> RIO env (Either ParseException Value)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path)
  case Either ParseException Value
eVal of
    Left ParseException
parseException -> ConfigPrettyException -> RIO env a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ConfigPrettyException -> RIO env a)
-> ConfigPrettyException -> RIO env a
forall a b. (a -> b) -> a -> b
$
      Path Abs File -> ParseException -> ConfigPrettyException
ParseConfigFileException Path Abs File
path ParseException
parseException
    Right Value
val -> 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall env.
(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
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 a. IO a -> RIO env a
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
SimpleGetter env LockFileBehavior
lockFileBehaviorL
  Bool
readLockFile <-
    case LockFileBehavior
lfb of
      LockFileBehavior
LFBIgnore -> Bool -> RIO env Bool
forall a. a -> RIO env a
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 a. a -> RIO env a
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 :: forall a b. Ord a => [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 -> a
forall a b. LockedLocation a b -> a
llOriginal (LockedLocation a b -> a)
-> (LockedLocation a b -> b) -> LockedLocation a b -> (a, b)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& LockedLocation a b -> b
forall a b. LockedLocation a b -> b
llCompleted)
      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
  Bool
debugRSL <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasRunner env => SimpleGetter env Bool
SimpleGetter env Bool
rslInLogL
  (Snapshot
snap, [CompletedSL]
slocCompleted, [CompletedPLI]
pliCompleted) <-
    Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL 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
        { 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
$
    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 ->
        LockPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (LockPrettyException -> RIO env ())
-> LockPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Locked -> LockPrettyException
WritingLockFileError Path Abs File
lockFile Locked
newLocked
      LockFileBehavior
LFBIgnore -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LockFileBehavior
LFBReadOnly -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SMWanted -> RIO env SMWanted
forall a. a -> RIO env a
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"