{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}

module Pantry.Types
  ( PantryConfig (..)
  , PackageIndexConfig (..)
  , HackageSecurityConfig (..)
  , defaultHackageSecurityConfig
  , Storage (..)
  , HasPantryConfig (..)
  , BlobKey (..)
  , PackageName
  , Version
  , PackageIdentifier (..)
  , Revision (..)
  , ModuleName
  , CabalFileInfo (..)
  , PrintWarnings (..)
  , PackageNameP (..)
  , VersionP (..)
  , ModuleNameP (..)
  , PackageIdentifierRevision (..)
  , pirForHash
  , FileType (..)
  , BuildFile (..)
  , FileSize (..)
  , TreeEntry (..)
  , SafeFilePath
  , unSafeFilePath
  , mkSafeFilePath
  , safeFilePathToPath
  , hpackSafeFilePath
  , TreeKey (..)
  , Tree (..)
  , renderTree
  , parseTree
  , parseTreeM
  , SHA256
  , Unresolved
  , resolvePaths
  , Package (..)
  , PackageCabal (..)
  , PHpack (..)
  -- , PackageTarball (..)

  , RawPackageLocation (..)
  , PackageLocation (..)
  , toRawPL
  , RawPackageLocationImmutable (..)
  , PackageLocationImmutable (..)
  , toRawPLI
  , RawArchive (..)
  , Archive (..)
  , toRawArchive
  , Repo (..)
  , AggregateRepo (..)
  , SimpleRepo (..)
  , toAggregateRepos
  , rToSimpleRepo
  , arToSimpleRepo
  , RepoType (..)
  , parsePackageIdentifier
  , parsePackageName
  , parsePackageNameThrowing
  , parseFlagName
  , parseVersion
  , parseVersionThrowing
  , packageIdentifierString
  , packageNameString
  , flagNameString
  , versionString
  , moduleNameString
  , OptionalSubdirs (..)
  , ArchiveLocation (..)
  , RelFilePath (..)
  , CabalString (..)
  , toCabalStringMap
  , unCabalStringMap
  , parsePackageIdentifierRevision
  , Mismatch (..)
  , PantryException (..)
  , FuzzyResults (..)
  , ResolvedPath (..)
  , HpackExecutable (..)
  , WantedCompiler (..)
  --, resolveSnapshotLocation

  , snapshotLocation
  , defaultSnapshotLocation
  , SnapName (..)
  , parseSnapName
  , RawSnapshotLocation (..)
  , SnapshotLocation (..)
  , toRawSL
  , parseHackageText
  , parseRawSnapshotLocation
  , RawSnapshotLayer (..)
  , SnapshotLayer (..)
  , toRawSnapshotLayer
  , RawSnapshot (..)
  , Snapshot (..)
  , RawSnapshotPackage (..)
  , SnapshotPackage (..)
  , parseWantedCompiler
  , RawPackageMetadata (..)
  , PackageMetadata (..)
  , toRawPM
  , cabalFileName
  , SnapshotCacheHash (..)
  , getGlobalHintsFile
  , bsToBlobKey
  , warnMissingCabalFile
  , connRDBMS
  ) where

import           Casa.Client ( CasaRepoPrefix )
import           Database.Persist
import           Database.Persist.Sql
#if MIN_VERSION_persistent(2, 13, 0)
import           Database.Persist.SqlBackend.Internal ( connRDBMS )
#endif
import           Data.Aeson.Encoding.Internal ( unsafeToEncoding )
import           Data.Aeson.Types
                   ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..)
                   , Object, Parser, ToJSON (..), ToJSONKey (..)
                   , ToJSONKeyFunction (..), Value (..), (.=), object
                   , toJSONKeyText, withObject, withText
                   )
import           Data.Aeson.WarningParser
                   ( WarningParser, WithJSONWarnings, (..:), (..:?), (..!=)
                   , (.:), (...:?), jsonSubWarnings, jsonSubWarningsT
                   , noJSONWarnings, tellJSONField, withObjectWarnings
                   )
import           Data.ByteString.Builder
                   ( byteString, toLazyByteString, wordDec )
import qualified Data.Conduit.Tar as Tar
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map ( mapKeysMonotonic )
import           Data.Text.Read ( decimal )
import           Distribution.CabalSpecVersion ( cabalSpecLatest )
#if MIN_VERSION_Cabal(3,4,0)
import           Distribution.CabalSpecVersion ( cabalSpecToVersionDigits )
#else
import           Distribution.CabalSpecVersion ( CabalSpecVersion (..) )
#endif
import qualified Distribution.Compat.CharParsing as Parse
import           Distribution.ModuleName ( ModuleName )
import           Distribution.PackageDescription
                   ( FlagName, GenericPackageDescription, unFlagName )
import           Distribution.Parsec
                   ( PError (..), PWarning (..), ParsecParser
                   , explicitEitherParsec, parsec, showPos
                   )
import qualified Distribution.Pretty
import qualified Distribution.Text
import           Distribution.Types.PackageId ( PackageIdentifier (..) )
import           Distribution.Types.PackageName
                   ( PackageName, mkPackageName, unPackageName )
import           Distribution.Types.Version ( Version, mkVersion, nullVersion )
import           Distribution.Types.VersionRange ( VersionRange )
import qualified Hpack.Config as Hpack
import           Network.HTTP.Client ( parseRequest )
import           Network.HTTP.Types ( Status, statusCode )
import           Pantry.SHA256 ( SHA256 )
import qualified Pantry.SHA256 as SHA256
import           Path
                   ( Abs, Dir, File, Path, (</>), filename, parseRelFile
                   , toFilePath
                   )
import           Path.IO ( resolveDir, resolveFile )
import qualified RIO.Set as Set
import           RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import           RIO.List ( groupBy, intersperse )
import qualified RIO.Text as T
import           RIO.Time ( Day, UTCTime, toGregorian )
import qualified RIO.Map as Map
import           RIO.PrettyPrint
                   ( bulletedList, fillSep, flow, hang, line, mkNarrativeList
                   , parens, string, style
                   )
import           RIO.PrettyPrint.Types ( Style (..) )
import           Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc )

#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as HM
import qualified Data.Aeson.Key

type AesonKey = Data.Aeson.Key.Key
#else
import qualified RIO.HashMap as HM

type AesonKey = Text
#endif

-- | Parsed tree with more information on the Haskell package it contains.

--

-- @since 0.1.0.0

data Package = Package
  { Package -> TreeKey
packageTreeKey :: !TreeKey
    -- ^ The 'TreeKey' containing this package.

    --

    -- This is a hash of the binary representation of 'packageTree'.

    --

    -- @since 0.1.0.0

  , Package -> Tree
packageTree :: !Tree
    -- ^ The 'Tree' containing this package.

    --

    -- @since 0.1.0.0

  , Package -> PackageCabal
packageCabalEntry :: !PackageCabal
    -- ^ Information on the cabal file inside this package.

    --

    -- @since 0.1.0.0

  , Package -> PackageIdentifier
packageIdent :: !PackageIdentifier
    -- ^ The package name and version in this package.

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> Package -> ShowS
[Package] -> ShowS
Package -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Package] -> ShowS
$cshowList :: [Package] -> ShowS
show :: Package -> [Char]
$cshow :: Package -> [Char]
showsPrec :: Int -> Package -> ShowS
$cshowsPrec :: Int -> Package -> ShowS
Show, Package -> Package -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Package -> Package -> Bool
$c/= :: Package -> Package -> Bool
== :: Package -> Package -> Bool
$c== :: Package -> Package -> Bool
Eq, Eq Package
Package -> Package -> Bool
Package -> Package -> Ordering
Package -> Package -> Package
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Package -> Package -> Package
$cmin :: Package -> Package -> Package
max :: Package -> Package -> Package
$cmax :: Package -> Package -> Package
>= :: Package -> Package -> Bool
$c>= :: Package -> Package -> Bool
> :: Package -> Package -> Bool
$c> :: Package -> Package -> Bool
<= :: Package -> Package -> Bool
$c<= :: Package -> Package -> Bool
< :: Package -> Package -> Bool
$c< :: Package -> Package -> Bool
compare :: Package -> Package -> Ordering
$ccompare :: Package -> Package -> Ordering
Ord)

data PHpack = PHpack
  { PHpack -> TreeEntry
phOriginal :: !TreeEntry
    -- ^ Original hpack file

  , PHpack -> TreeEntry
phGenerated :: !TreeEntry
    -- ^ Generated Cabal file

  , PHpack -> Version
phVersion :: !Version
    -- ^ Version of Hpack used

  }
  deriving (Int -> PHpack -> ShowS
[PHpack] -> ShowS
PHpack -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PHpack] -> ShowS
$cshowList :: [PHpack] -> ShowS
show :: PHpack -> [Char]
$cshow :: PHpack -> [Char]
showsPrec :: Int -> PHpack -> ShowS
$cshowsPrec :: Int -> PHpack -> ShowS
Show, PHpack -> PHpack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PHpack -> PHpack -> Bool
$c/= :: PHpack -> PHpack -> Bool
== :: PHpack -> PHpack -> Bool
$c== :: PHpack -> PHpack -> Bool
Eq, Eq PHpack
PHpack -> PHpack -> Bool
PHpack -> PHpack -> Ordering
PHpack -> PHpack -> PHpack
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PHpack -> PHpack -> PHpack
$cmin :: PHpack -> PHpack -> PHpack
max :: PHpack -> PHpack -> PHpack
$cmax :: PHpack -> PHpack -> PHpack
>= :: PHpack -> PHpack -> Bool
$c>= :: PHpack -> PHpack -> Bool
> :: PHpack -> PHpack -> Bool
$c> :: PHpack -> PHpack -> Bool
<= :: PHpack -> PHpack -> Bool
$c<= :: PHpack -> PHpack -> Bool
< :: PHpack -> PHpack -> Bool
$c< :: PHpack -> PHpack -> Bool
compare :: PHpack -> PHpack -> Ordering
$ccompare :: PHpack -> PHpack -> Ordering
Ord)

data PackageCabal
  = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file

  | PCHpack !PHpack
  deriving (Int -> PackageCabal -> ShowS
[PackageCabal] -> ShowS
PackageCabal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageCabal] -> ShowS
$cshowList :: [PackageCabal] -> ShowS
show :: PackageCabal -> [Char]
$cshow :: PackageCabal -> [Char]
showsPrec :: Int -> PackageCabal -> ShowS
$cshowsPrec :: Int -> PackageCabal -> ShowS
Show, PackageCabal -> PackageCabal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageCabal -> PackageCabal -> Bool
$c/= :: PackageCabal -> PackageCabal -> Bool
== :: PackageCabal -> PackageCabal -> Bool
$c== :: PackageCabal -> PackageCabal -> Bool
Eq, Eq PackageCabal
PackageCabal -> PackageCabal -> Bool
PackageCabal -> PackageCabal -> Ordering
PackageCabal -> PackageCabal -> PackageCabal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageCabal -> PackageCabal -> PackageCabal
$cmin :: PackageCabal -> PackageCabal -> PackageCabal
max :: PackageCabal -> PackageCabal -> PackageCabal
$cmax :: PackageCabal -> PackageCabal -> PackageCabal
>= :: PackageCabal -> PackageCabal -> Bool
$c>= :: PackageCabal -> PackageCabal -> Bool
> :: PackageCabal -> PackageCabal -> Bool
$c> :: PackageCabal -> PackageCabal -> Bool
<= :: PackageCabal -> PackageCabal -> Bool
$c<= :: PackageCabal -> PackageCabal -> Bool
< :: PackageCabal -> PackageCabal -> Bool
$c< :: PackageCabal -> PackageCabal -> Bool
compare :: PackageCabal -> PackageCabal -> Ordering
$ccompare :: PackageCabal -> PackageCabal -> Ordering
Ord)

cabalFileName :: PackageName -> SafeFilePath
cabalFileName :: PackageName -> SafeFilePath
cabalFileName PackageName
name =
  case Text -> Maybe SafeFilePath
mkSafeFilePath forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Text
".cabal" of
    Maybe SafeFilePath
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"cabalFileName: failed for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name
    Just SafeFilePath
sfp -> SafeFilePath
sfp

-- | The revision number of a package from Hackage, counting upwards from 0 (the

-- original cabal file).

--

-- See caveats on 'CFIRevision'.

--

-- @since 0.1.0.0

newtype Revision = Revision Word
  deriving (forall x. Rep Revision x -> Revision
forall x. Revision -> Rep Revision x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Revision x -> Revision
$cfrom :: forall x. Revision -> Rep Revision x
Generic, Int -> Revision -> ShowS
[Revision] -> ShowS
Revision -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Revision] -> ShowS
$cshowList :: [Revision] -> ShowS
show :: Revision -> [Char]
$cshow :: Revision -> [Char]
showsPrec :: Int -> Revision -> ShowS
$cshowsPrec :: Int -> Revision -> ShowS
Show, Revision -> Revision -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Revision -> Revision -> Bool
$c/= :: Revision -> Revision -> Bool
== :: Revision -> Revision -> Bool
$c== :: Revision -> Revision -> Bool
Eq, Revision -> ()
forall a. (a -> ()) -> NFData a
rnf :: Revision -> ()
$crnf :: Revision -> ()
NFData, Typeable Revision
Revision -> DataType
Revision -> Constr
(forall b. Data b => b -> b) -> Revision -> Revision
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Revision -> u
forall u. (forall d. Data d => d -> u) -> Revision -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Revision
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Revision -> c Revision
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Revision)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Revision)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Revision -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Revision -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Revision -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Revision -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
gmapT :: (forall b. Data b => b -> b) -> Revision -> Revision
$cgmapT :: (forall b. Data b => b -> b) -> Revision -> Revision
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Revision)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Revision)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Revision)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Revision)
dataTypeOf :: Revision -> DataType
$cdataTypeOf :: Revision -> DataType
toConstr :: Revision -> Constr
$ctoConstr :: Revision -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Revision
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Revision
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Revision -> c Revision
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Revision -> c Revision
Data, Typeable, Eq Revision
Revision -> Revision -> Bool
Revision -> Revision -> Ordering
Revision -> Revision -> Revision
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Revision -> Revision -> Revision
$cmin :: Revision -> Revision -> Revision
max :: Revision -> Revision -> Revision
$cmax :: Revision -> Revision -> Revision
>= :: Revision -> Revision -> Bool
$c>= :: Revision -> Revision -> Bool
> :: Revision -> Revision -> Bool
$c> :: Revision -> Revision -> Bool
<= :: Revision -> Revision -> Bool
$c<= :: Revision -> Revision -> Bool
< :: Revision -> Revision -> Bool
$c< :: Revision -> Revision -> Bool
compare :: Revision -> Revision -> Ordering
$ccompare :: Revision -> Revision -> Ordering
Ord, Eq Revision
Int -> Revision -> Int
Revision -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Revision -> Int
$chash :: Revision -> Int
hashWithSalt :: Int -> Revision -> Int
$chashWithSalt :: Int -> Revision -> Int
Hashable, Revision -> Text
Revision -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: Revision -> Text
$ctextDisplay :: Revision -> Text
display :: Revision -> Utf8Builder
$cdisplay :: Revision -> Utf8Builder
Display, PersistValue -> Either Text Revision
Revision -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text Revision
$cfromPersistValue :: PersistValue -> Either Text Revision
toPersistValue :: Revision -> PersistValue
$ctoPersistValue :: Revision -> PersistValue
PersistField, PersistField Revision
Proxy Revision -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy Revision -> SqlType
$csqlType :: Proxy Revision -> SqlType
PersistFieldSql)

-- | Represents a SQL database connection.


-- This used to be a newtype wrapper around a connection pool. However, when

-- investigating <https://github.com/commercialhaskell/stack/issues/4471>, it

-- appeared that holding a pool resulted in overly long write locks being held

-- on the database. As a result, we now abstract away whether a pool is used,

-- and the default implementation in "Pantry.Storage" does not use a pool.

data Storage = Storage
  { Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage_ ::
         forall env a. HasLogFunc env
      => ReaderT SqlBackend (RIO env) a
      -> RIO env a
  , Storage -> forall env a. HasLogFunc env => RIO env a -> RIO env a
withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a
  }

-- | Configuration value used by the entire pantry package. Create one using

-- 'withPantryConfig' or 'withPantryConfig''. See also 'PantryApp' for a

-- convenience approach to using pantry.

--

-- @since 0.1.0.0

data PantryConfig = PantryConfig
  { PantryConfig -> PackageIndexConfig
pcPackageIndex :: !PackageIndexConfig
  , PantryConfig -> HpackExecutable
pcHpackExecutable :: !HpackExecutable
  , PantryConfig -> Path Abs Dir
pcRootDir :: !(Path Abs Dir)
  , PantryConfig -> Storage
pcStorage :: !Storage
  , PantryConfig -> MVar Bool
pcUpdateRef :: !(MVar Bool)
    -- ^ Want to try updating the index once during a single run for missing

    -- package identifiers. We also want to ensure we only update once at a

    -- time. Start at @True@.

  , PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable ::
      !(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
    -- ^ Cache of previously parsed cabal files, to save on slow parsing time.

  , PantryConfig
-> IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
pcParsedCabalFilesMutable ::
      !( IORef
           ( Map
             (Path Abs Dir)
             ( PrintWarnings -> IO GenericPackageDescription
             , PackageName
             , Path Abs File
             )
           )
       )
    -- ^ Cache for mutable packages. We want to allow for an optimization:

    -- deferring parsing of the 'GenericPackageDescription' until its actually

    -- needed. Therefore, we keep the filepath and the 'PackageName' derived

    -- from that filepath. When the @IO GenericPackageDescription@ is run, it

    -- will ensure that the @PackageName@ matches the value inside the cabal

    -- file, and print out any warnings that still need to be printed.

  , PantryConfig -> Int
pcConnectionCount :: !Int
    -- ^ concurrently open downloads

  , PantryConfig -> Maybe (CasaRepoPrefix, Int)
pcCasaConfig :: !(Maybe (CasaRepoPrefix, Int))
    -- ^ Optionally, the Casa pull URL e.g. @https://casa.stackage.org@ and

    -- the maximum number of Casa keys to pull per request.

  , PantryConfig -> SnapName -> RawSnapshotLocation
pcSnapshotLocation :: SnapName -> RawSnapshotLocation
    -- ^ The location of snapshot synonyms

  }

-- | Get the location of a snapshot synonym from the 'PantryConfig'.

--

-- @since 0.5.0.0

snapshotLocation ::
     HasPantryConfig env
  => SnapName
  -> RIO env RawSnapshotLocation
snapshotLocation :: forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
name = do
  SnapName -> RawSnapshotLocation
loc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> SnapName -> RawSnapshotLocation
pcSnapshotLocation
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
loc SnapName
name

-- | Should we print warnings when loading a cabal file?

--

-- @since 0.1.0.0

data PrintWarnings = YesPrintWarnings | NoPrintWarnings

-- | Wraps a value which potentially contains relative paths. Needs to be

-- provided with a base directory to resolve these paths.

--

-- Unwrap this using 'resolvePaths'.

--

-- @since 0.1.0.0

newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a)
  deriving forall a b. a -> Unresolved b -> Unresolved a
forall a b. (a -> b) -> Unresolved a -> Unresolved b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Unresolved b -> Unresolved a
$c<$ :: forall a b. a -> Unresolved b -> Unresolved a
fmap :: forall a b. (a -> b) -> Unresolved a -> Unresolved b
$cfmap :: forall a b. (a -> b) -> Unresolved a -> Unresolved b
Functor

instance Applicative Unresolved where
  pure :: forall a. a -> Unresolved a
pure = forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Unresolved Maybe (Path Abs Dir) -> IO (a -> b)
f <*> :: forall a b. Unresolved (a -> b) -> Unresolved a -> Unresolved b
<*> Unresolved Maybe (Path Abs Dir) -> IO a
x = forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> Maybe (Path Abs Dir) -> IO (a -> b)
f Maybe (Path Abs Dir)
mdir forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Path Abs Dir) -> IO a
x Maybe (Path Abs Dir)
mdir

-- | Resolve all of the file paths in an 'Unresolved' relative to the given

-- directory.

--

-- @since 0.1.0.0

resolvePaths ::
     MonadIO m
  => Maybe (Path Abs Dir) -- ^ directory to use for relative paths

  -> Unresolved a
  -> m a
resolvePaths :: forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir (Unresolved Maybe (Path Abs Dir) -> IO a
f) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe (Path Abs Dir) -> IO a
f Maybe (Path Abs Dir)
mdir)

-- | A combination of the relative path provided in a config file, together with

-- the resolved absolute path.

--

-- @since 0.1.0.0

data ResolvedPath t = ResolvedPath
  { forall t. ResolvedPath t -> RelFilePath
resolvedRelative :: !RelFilePath
    -- ^ Original value parsed from a config file.

  , forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute :: !(Path Abs t)
    -- ^ Absolute path resolved against base directory loaded from.

  }
  deriving (Int -> ResolvedPath t -> ShowS
forall t. Int -> ResolvedPath t -> ShowS
forall t. [ResolvedPath t] -> ShowS
forall t. ResolvedPath t -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ResolvedPath t] -> ShowS
$cshowList :: forall t. [ResolvedPath t] -> ShowS
show :: ResolvedPath t -> [Char]
$cshow :: forall t. ResolvedPath t -> [Char]
showsPrec :: Int -> ResolvedPath t -> ShowS
$cshowsPrec :: forall t. Int -> ResolvedPath t -> ShowS
Show, ResolvedPath t -> ResolvedPath t -> Bool
forall t. ResolvedPath t -> ResolvedPath t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResolvedPath t -> ResolvedPath t -> Bool
$c/= :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
== :: ResolvedPath t -> ResolvedPath t -> Bool
$c== :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (ResolvedPath t) x -> ResolvedPath t
forall t x. ResolvedPath t -> Rep (ResolvedPath t) x
$cto :: forall t x. Rep (ResolvedPath t) x -> ResolvedPath t
$cfrom :: forall t x. ResolvedPath t -> Rep (ResolvedPath t) x
Generic, ResolvedPath t -> ResolvedPath t -> Bool
ResolvedPath t -> ResolvedPath t -> Ordering
forall t. Eq (ResolvedPath t)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t. ResolvedPath t -> ResolvedPath t -> Bool
forall t. ResolvedPath t -> ResolvedPath t -> Ordering
forall t. ResolvedPath t -> ResolvedPath t -> ResolvedPath t
min :: ResolvedPath t -> ResolvedPath t -> ResolvedPath t
$cmin :: forall t. ResolvedPath t -> ResolvedPath t -> ResolvedPath t
max :: ResolvedPath t -> ResolvedPath t -> ResolvedPath t
$cmax :: forall t. ResolvedPath t -> ResolvedPath t -> ResolvedPath t
>= :: ResolvedPath t -> ResolvedPath t -> Bool
$c>= :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
> :: ResolvedPath t -> ResolvedPath t -> Bool
$c> :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
<= :: ResolvedPath t -> ResolvedPath t -> Bool
$c<= :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
< :: ResolvedPath t -> ResolvedPath t -> Bool
$c< :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
compare :: ResolvedPath t -> ResolvedPath t -> Ordering
$ccompare :: forall t. ResolvedPath t -> ResolvedPath t -> Ordering
Ord)

instance NFData (ResolvedPath t)

-- | Location to load a package from. Can either be immutable (see

-- 'PackageLocationImmutable') or a local directory which is expected to change

-- over time. Raw version doesn't include exact package version (e.g. could

-- refer to the latest revision on Hackage)

--

-- @since 0.1.0.0

data RawPackageLocation
  = RPLImmutable !RawPackageLocationImmutable
  | RPLMutable !(ResolvedPath Dir)
  deriving (Int -> RawPackageLocation -> ShowS
[RawPackageLocation] -> ShowS
RawPackageLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawPackageLocation] -> ShowS
$cshowList :: [RawPackageLocation] -> ShowS
show :: RawPackageLocation -> [Char]
$cshow :: RawPackageLocation -> [Char]
showsPrec :: Int -> RawPackageLocation -> ShowS
$cshowsPrec :: Int -> RawPackageLocation -> ShowS
Show, RawPackageLocation -> RawPackageLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPackageLocation -> RawPackageLocation -> Bool
$c/= :: RawPackageLocation -> RawPackageLocation -> Bool
== :: RawPackageLocation -> RawPackageLocation -> Bool
$c== :: RawPackageLocation -> RawPackageLocation -> Bool
Eq, forall x. Rep RawPackageLocation x -> RawPackageLocation
forall x. RawPackageLocation -> Rep RawPackageLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawPackageLocation x -> RawPackageLocation
$cfrom :: forall x. RawPackageLocation -> Rep RawPackageLocation x
Generic)

instance NFData RawPackageLocation

-- | Location to load a package from. Can either be immutable (see

-- 'PackageLocationImmutable') or a local directory which is expected to change

-- over time.

--

-- @since 0.1.0.0

data PackageLocation
  = PLImmutable !PackageLocationImmutable
  | PLMutable !(ResolvedPath Dir)
  deriving (Int -> PackageLocation -> ShowS
[PackageLocation] -> ShowS
PackageLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageLocation] -> ShowS
$cshowList :: [PackageLocation] -> ShowS
show :: PackageLocation -> [Char]
$cshow :: PackageLocation -> [Char]
showsPrec :: Int -> PackageLocation -> ShowS
$cshowsPrec :: Int -> PackageLocation -> ShowS
Show, PackageLocation -> PackageLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageLocation -> PackageLocation -> Bool
$c/= :: PackageLocation -> PackageLocation -> Bool
== :: PackageLocation -> PackageLocation -> Bool
$c== :: PackageLocation -> PackageLocation -> Bool
Eq, forall x. Rep PackageLocation x -> PackageLocation
forall x. PackageLocation -> Rep PackageLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageLocation x -> PackageLocation
$cfrom :: forall x. PackageLocation -> Rep PackageLocation x
Generic)

instance NFData PackageLocation

instance Display PackageLocation where
  display :: PackageLocation -> Utf8Builder
display (PLImmutable PackageLocationImmutable
loc) = forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
loc
  display (PLMutable ResolvedPath Dir
fp) = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
fp

-- | Convert `PackageLocation` to its "raw" equivalent

--

-- @since 0.1.0.0

toRawPL :: PackageLocation -> RawPackageLocation
toRawPL :: PackageLocation -> RawPackageLocation
toRawPL (PLImmutable PackageLocationImmutable
im) = RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
im)
toRawPL (PLMutable ResolvedPath Dir
m) = ResolvedPath Dir -> RawPackageLocation
RPLMutable ResolvedPath Dir
m

-- | Location for remote packages or archives assumed to be immutable.

-- as user specifies it i.e. not an exact location

--

-- @since 0.1.0.0

data RawPackageLocationImmutable
  = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey)
  | RPLIArchive !RawArchive !RawPackageMetadata
  | RPLIRepo    !Repo !RawPackageMetadata
  deriving (Int -> RawPackageLocationImmutable -> ShowS
[RawPackageLocationImmutable] -> ShowS
RawPackageLocationImmutable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawPackageLocationImmutable] -> ShowS
$cshowList :: [RawPackageLocationImmutable] -> ShowS
show :: RawPackageLocationImmutable -> [Char]
$cshow :: RawPackageLocationImmutable -> [Char]
showsPrec :: Int -> RawPackageLocationImmutable -> ShowS
$cshowsPrec :: Int -> RawPackageLocationImmutable -> ShowS
Show, RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c/= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
== :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c== :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
Eq, Eq RawPackageLocationImmutable
RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
RawPackageLocationImmutable
-> RawPackageLocationImmutable -> Ordering
RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
$cmin :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
max :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
$cmax :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
>= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c>= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
> :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c> :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
<= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c<= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
< :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c< :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
compare :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> Ordering
$ccompare :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> Ordering
Ord, forall x.
Rep RawPackageLocationImmutable x -> RawPackageLocationImmutable
forall x.
RawPackageLocationImmutable -> Rep RawPackageLocationImmutable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep RawPackageLocationImmutable x -> RawPackageLocationImmutable
$cfrom :: forall x.
RawPackageLocationImmutable -> Rep RawPackageLocationImmutable x
Generic)

instance NFData RawPackageLocationImmutable

instance Display RawPackageLocationImmutable where
  display :: RawPackageLocationImmutable -> Utf8Builder
display (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_tree) = forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (from Hackage)"
  display (RPLIArchive RawArchive
archive RawPackageMetadata
_pm) =
    Utf8Builder
"Archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (RawArchive -> ArchiveLocation
raLocation RawArchive
archive) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ RawArchive -> Text
raSubdir RawArchive
archive
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (RawArchive -> Text
raSubdir RawArchive
archive))
  display (RPLIRepo Repo
repo RawPackageMetadata
_pm) =
    Utf8Builder
"Repo from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoUrl Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoCommit Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Repo -> Text
repoSubdir Repo
repo
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoSubdir Repo
repo))

instance Pretty RawPackageLocationImmutable where
  pretty :: RawPackageLocationImmutable -> StyleDoc
pretty (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_tree) = [StyleDoc] -> StyleDoc
fillSep
    [ forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageIdentifierRevision
pir
    , StyleDoc -> StyleDoc
parens ([Char] -> StyleDoc
flow [Char]
"from Hackage")
    ]
  pretty (RPLIArchive RawArchive
archive RawPackageMetadata
_pm) = [StyleDoc] -> StyleDoc
fillSep
    [ [Char] -> StyleDoc
flow [Char]
"Archive from"
    , forall a. Pretty a => a -> StyleDoc
pretty (RawArchive -> ArchiveLocation
raLocation RawArchive
archive)
    , if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ RawArchive -> Text
raSubdir RawArchive
archive
        then forall a. Monoid a => a
mempty
        else [StyleDoc] -> StyleDoc
fillSep
          [ [Char] -> StyleDoc
flow [Char]
"in subdir"
          , Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (RawArchive -> Text
raSubdir RawArchive
archive))
          ]
    ]
  pretty (RPLIRepo Repo
repo RawPackageMetadata
_pm) = [StyleDoc] -> StyleDoc
fillSep
    [ [Char] -> StyleDoc
flow [Char]
"Repo from"
    , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Repo -> Text
repoUrl Repo
repo)) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
    , StyleDoc
"commit"
    , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Repo -> Text
repoCommit Repo
repo)
    , if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Repo -> Text
repoSubdir Repo
repo
        then forall a. Monoid a => a
mempty
        else [StyleDoc] -> StyleDoc
fillSep
          [ [Char] -> StyleDoc
flow [Char]
"in subdir"
          , Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Repo -> Text
repoSubdir Repo
repo))
          ]
    ]

-- | Location for remote packages or archives assumed to be immutable.

--

-- @since 0.1.0.0

data PackageLocationImmutable
  = PLIHackage !PackageIdentifier !BlobKey !TreeKey
  | PLIArchive !Archive !PackageMetadata
  | PLIRepo    !Repo !PackageMetadata
  deriving (forall x.
Rep PackageLocationImmutable x -> PackageLocationImmutable
forall x.
PackageLocationImmutable -> Rep PackageLocationImmutable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep PackageLocationImmutable x -> PackageLocationImmutable
$cfrom :: forall x.
PackageLocationImmutable -> Rep PackageLocationImmutable x
Generic, Int -> PackageLocationImmutable -> ShowS
[PackageLocationImmutable] -> ShowS
PackageLocationImmutable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageLocationImmutable] -> ShowS
$cshowList :: [PackageLocationImmutable] -> ShowS
show :: PackageLocationImmutable -> [Char]
$cshow :: PackageLocationImmutable -> [Char]
showsPrec :: Int -> PackageLocationImmutable -> ShowS
$cshowsPrec :: Int -> PackageLocationImmutable -> ShowS
Show, PackageLocationImmutable -> PackageLocationImmutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c/= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
== :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c== :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
Eq, Eq PackageLocationImmutable
PackageLocationImmutable -> PackageLocationImmutable -> Bool
PackageLocationImmutable -> PackageLocationImmutable -> Ordering
PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
$cmin :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
max :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
$cmax :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
>= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c>= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
> :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c> :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
<= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c<= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
< :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c< :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
compare :: PackageLocationImmutable -> PackageLocationImmutable -> Ordering
$ccompare :: PackageLocationImmutable -> PackageLocationImmutable -> Ordering
Ord, Typeable)

instance NFData PackageLocationImmutable

instance Display PackageLocationImmutable where
  display :: PackageLocationImmutable -> Utf8Builder
display (PLIHackage PackageIdentifier
ident BlobKey
_cabalHash TreeKey
_tree) =
    forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (from Hackage)"
  display (PLIArchive Archive
archive PackageMetadata
_pm) =
    Utf8Builder
"Archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Archive -> ArchiveLocation
archiveLocation Archive
archive) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Archive -> Text
archiveSubdir Archive
archive
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Archive -> Text
archiveSubdir Archive
archive))
  display (PLIRepo Repo
repo PackageMetadata
_pm) =
    Utf8Builder
"Repo from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoUrl Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoCommit Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Repo -> Text
repoSubdir Repo
repo
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoSubdir Repo
repo))

instance ToJSON PackageLocationImmutable where
  toJSON :: PackageLocationImmutable -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI

-- | Package identifier and revision with a specified cabal file hash

--

-- @since 0.1.0.0

pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash (PackageIdentifier PackageName
name Version
ver) (BlobKey SHA256
sha FileSize
size') =
  let cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (forall a. a -> Maybe a
Just FileSize
size')
  in PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
cfi

-- | Convert `PackageLocationImmutable` to its "raw" equivalent

--

-- @since 0.1.0.0

toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (PLIHackage PackageIdentifier
ident BlobKey
cfKey TreeKey
treeKey) =
  PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash PackageIdentifier
ident BlobKey
cfKey) (forall a. a -> Maybe a
Just TreeKey
treeKey)
toRawPLI (PLIArchive Archive
archive PackageMetadata
pm) =
  RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive (Archive -> RawArchive
toRawArchive Archive
archive) (PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm)
toRawPLI (PLIRepo Repo
repo PackageMetadata
pm) = Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo Repo
repo (PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm)

-- | A raw package archive, specified by a user, could have no

-- hash and file size information.

--

-- @since 0.1.0.0

data RawArchive = RawArchive
  { RawArchive -> ArchiveLocation
raLocation :: !ArchiveLocation
    -- ^ Location of the archive

    --

    -- @since 0.1.0.0

  , RawArchive -> Maybe SHA256
raHash :: !(Maybe SHA256)
    -- ^ Cryptographic hash of the archive file

    --

    -- @since 0.1.0.0

  , RawArchive -> Maybe FileSize
raSize :: !(Maybe FileSize)
    -- ^ Size of the archive file

    --

    -- @since 0.1.0.0

  , RawArchive -> Text
raSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.

    --

    -- @since 0.1.0.0

  }
  deriving (forall x. Rep RawArchive x -> RawArchive
forall x. RawArchive -> Rep RawArchive x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawArchive x -> RawArchive
$cfrom :: forall x. RawArchive -> Rep RawArchive x
Generic, Int -> RawArchive -> ShowS
[RawArchive] -> ShowS
RawArchive -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawArchive] -> ShowS
$cshowList :: [RawArchive] -> ShowS
show :: RawArchive -> [Char]
$cshow :: RawArchive -> [Char]
showsPrec :: Int -> RawArchive -> ShowS
$cshowsPrec :: Int -> RawArchive -> ShowS
Show, RawArchive -> RawArchive -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawArchive -> RawArchive -> Bool
$c/= :: RawArchive -> RawArchive -> Bool
== :: RawArchive -> RawArchive -> Bool
$c== :: RawArchive -> RawArchive -> Bool
Eq, Eq RawArchive
RawArchive -> RawArchive -> Bool
RawArchive -> RawArchive -> Ordering
RawArchive -> RawArchive -> RawArchive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawArchive -> RawArchive -> RawArchive
$cmin :: RawArchive -> RawArchive -> RawArchive
max :: RawArchive -> RawArchive -> RawArchive
$cmax :: RawArchive -> RawArchive -> RawArchive
>= :: RawArchive -> RawArchive -> Bool
$c>= :: RawArchive -> RawArchive -> Bool
> :: RawArchive -> RawArchive -> Bool
$c> :: RawArchive -> RawArchive -> Bool
<= :: RawArchive -> RawArchive -> Bool
$c<= :: RawArchive -> RawArchive -> Bool
< :: RawArchive -> RawArchive -> Bool
$c< :: RawArchive -> RawArchive -> Bool
compare :: RawArchive -> RawArchive -> Ordering
$ccompare :: RawArchive -> RawArchive -> Ordering
Ord, Typeable)

instance NFData RawArchive

-- | A package archive, could be from a URL or a local file path. Local file

-- path archives are assumed to be unchanging over time, and so are allowed in

-- custom snapshots.

--

-- @since 0.1.0.0

data Archive = Archive
  { Archive -> ArchiveLocation
archiveLocation :: !ArchiveLocation
    -- ^ Location of the archive

    --

    -- @since 0.1.0.0

  , Archive -> SHA256
archiveHash :: !SHA256
    -- ^ Cryptographic hash of the archive file

    --

    -- @since 0.1.0.0

  , Archive -> FileSize
archiveSize :: !FileSize
    -- ^ Size of the archive file

    --

    -- @since 0.1.0.0

  , Archive -> Text
archiveSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.

    --

    -- @since 0.1.0.0

  }
  deriving (forall x. Rep Archive x -> Archive
forall x. Archive -> Rep Archive x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Archive x -> Archive
$cfrom :: forall x. Archive -> Rep Archive x
Generic, Int -> Archive -> ShowS
[Archive] -> ShowS
Archive -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Archive] -> ShowS
$cshowList :: [Archive] -> ShowS
show :: Archive -> [Char]
$cshow :: Archive -> [Char]
showsPrec :: Int -> Archive -> ShowS
$cshowsPrec :: Int -> Archive -> ShowS
Show, Archive -> Archive -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Archive -> Archive -> Bool
$c/= :: Archive -> Archive -> Bool
== :: Archive -> Archive -> Bool
$c== :: Archive -> Archive -> Bool
Eq, Eq Archive
Archive -> Archive -> Bool
Archive -> Archive -> Ordering
Archive -> Archive -> Archive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Archive -> Archive -> Archive
$cmin :: Archive -> Archive -> Archive
max :: Archive -> Archive -> Archive
$cmax :: Archive -> Archive -> Archive
>= :: Archive -> Archive -> Bool
$c>= :: Archive -> Archive -> Bool
> :: Archive -> Archive -> Bool
$c> :: Archive -> Archive -> Bool
<= :: Archive -> Archive -> Bool
$c<= :: Archive -> Archive -> Bool
< :: Archive -> Archive -> Bool
$c< :: Archive -> Archive -> Bool
compare :: Archive -> Archive -> Ordering
$ccompare :: Archive -> Archive -> Ordering
Ord, Typeable)

instance NFData Archive

-- | Convert archive to its "raw" equivalent.

--

-- @since 0.1.0.0

toRawArchive :: Archive -> RawArchive
toRawArchive :: Archive -> RawArchive
toRawArchive Archive
archive =
  ArchiveLocation
-> Maybe SHA256 -> Maybe FileSize -> Text -> RawArchive
RawArchive (Archive -> ArchiveLocation
archiveLocation Archive
archive) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Archive -> SHA256
archiveHash Archive
archive)
             (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Archive -> FileSize
archiveSize Archive
archive) (Archive -> Text
archiveSubdir Archive
archive)

-- | The type of a source control repository.

--

-- @since 0.1.0.0

data RepoType = RepoGit | RepoHg
  deriving (forall x. Rep RepoType x -> RepoType
forall x. RepoType -> Rep RepoType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RepoType x -> RepoType
$cfrom :: forall x. RepoType -> Rep RepoType x
Generic, Int -> RepoType -> ShowS
[RepoType] -> ShowS
RepoType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RepoType] -> ShowS
$cshowList :: [RepoType] -> ShowS
show :: RepoType -> [Char]
$cshow :: RepoType -> [Char]
showsPrec :: Int -> RepoType -> ShowS
$cshowsPrec :: Int -> RepoType -> ShowS
Show, RepoType -> RepoType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RepoType -> RepoType -> Bool
$c/= :: RepoType -> RepoType -> Bool
== :: RepoType -> RepoType -> Bool
$c== :: RepoType -> RepoType -> Bool
Eq, Eq RepoType
RepoType -> RepoType -> Bool
RepoType -> RepoType -> Ordering
RepoType -> RepoType -> RepoType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RepoType -> RepoType -> RepoType
$cmin :: RepoType -> RepoType -> RepoType
max :: RepoType -> RepoType -> RepoType
$cmax :: RepoType -> RepoType -> RepoType
>= :: RepoType -> RepoType -> Bool
$c>= :: RepoType -> RepoType -> Bool
> :: RepoType -> RepoType -> Bool
$c> :: RepoType -> RepoType -> Bool
<= :: RepoType -> RepoType -> Bool
$c<= :: RepoType -> RepoType -> Bool
< :: RepoType -> RepoType -> Bool
$c< :: RepoType -> RepoType -> Bool
compare :: RepoType -> RepoType -> Ordering
$ccompare :: RepoType -> RepoType -> Ordering
Ord, Typeable)

instance NFData RepoType

instance PersistField RepoType where
  toPersistValue :: RepoType -> PersistValue
toPersistValue RepoType
RepoGit = forall a. PersistField a => a -> PersistValue
toPersistValue (Int32
1 :: Int32)
  toPersistValue RepoType
RepoHg = forall a. PersistField a => a -> PersistValue
toPersistValue (Int32
2 :: Int32)
  fromPersistValue :: PersistValue -> Either Text RepoType
fromPersistValue PersistValue
v = do
    Int32
i <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case Int32
i :: Int32 of
      Int32
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoType
RepoGit
      Int32
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoType
RepoHg
      Int32
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid RepoType: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int32
i

instance PersistFieldSql RepoType where
  sqlType :: Proxy RepoType -> SqlType
sqlType Proxy RepoType
_ = SqlType
SqlInt32

-- | Information on packages stored in a source control repository.

--

-- @since 0.1.0.0

data Repo = Repo
  { Repo -> Text
repoUrl :: !Text
    -- ^ Location of the repo

    --

    -- @since 0.1.0.0

  , Repo -> Text
repoCommit :: !Text
    -- ^ Commit to use from the repo. It's strongly recommended to use

    -- a hash instead of a tag or branch name.

    --

    -- @since 0.1.0.0

  , Repo -> RepoType
repoType :: !RepoType
    -- ^ The type of the repo

    --

    -- @since 0.1.0.0

  , Repo -> Text
repoSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.

    --

    -- @since 0.1.0.0

  }
  deriving (forall x. Rep Repo x -> Repo
forall x. Repo -> Rep Repo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Repo x -> Repo
$cfrom :: forall x. Repo -> Rep Repo x
Generic, Repo -> Repo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Repo -> Repo -> Bool
$c/= :: Repo -> Repo -> Bool
== :: Repo -> Repo -> Bool
$c== :: Repo -> Repo -> Bool
Eq, Eq Repo
Repo -> Repo -> Bool
Repo -> Repo -> Ordering
Repo -> Repo -> Repo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Repo -> Repo -> Repo
$cmin :: Repo -> Repo -> Repo
max :: Repo -> Repo -> Repo
$cmax :: Repo -> Repo -> Repo
>= :: Repo -> Repo -> Bool
$c>= :: Repo -> Repo -> Bool
> :: Repo -> Repo -> Bool
$c> :: Repo -> Repo -> Bool
<= :: Repo -> Repo -> Bool
$c<= :: Repo -> Repo -> Bool
< :: Repo -> Repo -> Bool
$c< :: Repo -> Repo -> Bool
compare :: Repo -> Repo -> Ordering
$ccompare :: Repo -> Repo -> Ordering
Ord, Typeable)

instance NFData Repo

instance Show Repo where
  show :: Repo -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance Display Repo where
  display :: Repo -> Utf8Builder
display (Repo Text
url Text
commit RepoType
typ Text
subdir) =
    (case RepoType
typ of
       RepoType
RepoGit -> Utf8Builder
"Git"
       RepoType
RepoHg -> Utf8Builder
"Mercurial") forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
" repo at " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
commit forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null Text
subdir
      then forall a. Monoid a => a
mempty
      else Utf8Builder
" in subdirectory " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
subdir)

rToSimpleRepo :: Repo -> SimpleRepo
rToSimpleRepo :: Repo -> SimpleRepo
rToSimpleRepo Repo {Text
RepoType
repoSubdir :: Text
repoType :: RepoType
repoCommit :: Text
repoUrl :: Text
repoType :: Repo -> RepoType
repoSubdir :: Repo -> Text
repoCommit :: Repo -> Text
repoUrl :: Repo -> Text
..} = SimpleRepo
  { sRepoUrl :: Text
sRepoUrl = Text
repoUrl
  , sRepoCommit :: Text
sRepoCommit = Text
repoCommit
  , sRepoType :: RepoType
sRepoType = RepoType
repoType
  }

data AggregateRepo = AggregateRepo
  { AggregateRepo -> SimpleRepo
aRepo :: !SimpleRepo
  , AggregateRepo -> [(Text, RawPackageMetadata)]
aRepoSubdirs :: [(Text, RawPackageMetadata)]
  }
  deriving (Int -> AggregateRepo -> ShowS
[AggregateRepo] -> ShowS
AggregateRepo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AggregateRepo] -> ShowS
$cshowList :: [AggregateRepo] -> ShowS
show :: AggregateRepo -> [Char]
$cshow :: AggregateRepo -> [Char]
showsPrec :: Int -> AggregateRepo -> ShowS
$cshowsPrec :: Int -> AggregateRepo -> ShowS
Show, forall x. Rep AggregateRepo x -> AggregateRepo
forall x. AggregateRepo -> Rep AggregateRepo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AggregateRepo x -> AggregateRepo
$cfrom :: forall x. AggregateRepo -> Rep AggregateRepo x
Generic, AggregateRepo -> AggregateRepo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AggregateRepo -> AggregateRepo -> Bool
$c/= :: AggregateRepo -> AggregateRepo -> Bool
== :: AggregateRepo -> AggregateRepo -> Bool
$c== :: AggregateRepo -> AggregateRepo -> Bool
Eq, Eq AggregateRepo
AggregateRepo -> AggregateRepo -> Bool
AggregateRepo -> AggregateRepo -> Ordering
AggregateRepo -> AggregateRepo -> AggregateRepo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AggregateRepo -> AggregateRepo -> AggregateRepo
$cmin :: AggregateRepo -> AggregateRepo -> AggregateRepo
max :: AggregateRepo -> AggregateRepo -> AggregateRepo
$cmax :: AggregateRepo -> AggregateRepo -> AggregateRepo
>= :: AggregateRepo -> AggregateRepo -> Bool
$c>= :: AggregateRepo -> AggregateRepo -> Bool
> :: AggregateRepo -> AggregateRepo -> Bool
$c> :: AggregateRepo -> AggregateRepo -> Bool
<= :: AggregateRepo -> AggregateRepo -> Bool
$c<= :: AggregateRepo -> AggregateRepo -> Bool
< :: AggregateRepo -> AggregateRepo -> Bool
$c< :: AggregateRepo -> AggregateRepo -> Bool
compare :: AggregateRepo -> AggregateRepo -> Ordering
$ccompare :: AggregateRepo -> AggregateRepo -> Ordering
Ord, Typeable)

-- | Group input repositories by non-subdir values.

toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
toAggregateRepo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy forall {b} {b}. (Repo, b) -> (Repo, b) -> Bool
matchRepoExclSubdir
 where
  toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
  toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
toAggregateRepo [] = forall a. Maybe a
Nothing
  toAggregateRepo xs :: [(Repo, RawPackageMetadata)]
xs@((Repo
repo, RawPackageMetadata
_):[(Repo, RawPackageMetadata)]
_) =
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SimpleRepo -> [(Text, RawPackageMetadata)] -> AggregateRepo
AggregateRepo (Repo -> SimpleRepo
rToSimpleRepo Repo
repo) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Repo -> Text
repoSubdir) [(Repo, RawPackageMetadata)]
xs)

  matchRepoExclSubdir :: (Repo, b) -> (Repo, b) -> Bool
matchRepoExclSubdir (Repo, b)
x1 (Repo, b)
x2 =
    let (Repo Text
url1 Text
commit1 RepoType
type1 Text
_, b
_) = (Repo, b)
x1
        (Repo Text
url2 Text
commit2 RepoType
type2 Text
_, b
_) = (Repo, b)
x2
    in  (Text
url1, Text
commit1, RepoType
type1) forall a. Eq a => a -> a -> Bool
== (Text
url2, Text
commit2, RepoType
type2)

arToSimpleRepo :: AggregateRepo -> SimpleRepo
arToSimpleRepo :: AggregateRepo -> SimpleRepo
arToSimpleRepo AggregateRepo {[(Text, RawPackageMetadata)]
SimpleRepo
aRepoSubdirs :: [(Text, RawPackageMetadata)]
aRepo :: SimpleRepo
aRepoSubdirs :: AggregateRepo -> [(Text, RawPackageMetadata)]
aRepo :: AggregateRepo -> SimpleRepo
..} = SimpleRepo
aRepo

-- | Repository without subdirectory information.

--

-- @since 0.5.3

data SimpleRepo = SimpleRepo
  { SimpleRepo -> Text
sRepoUrl :: !Text
  , SimpleRepo -> Text
sRepoCommit :: !Text
  , SimpleRepo -> RepoType
sRepoType :: !RepoType
  }
  deriving (Int -> SimpleRepo -> ShowS
[SimpleRepo] -> ShowS
SimpleRepo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SimpleRepo] -> ShowS
$cshowList :: [SimpleRepo] -> ShowS
show :: SimpleRepo -> [Char]
$cshow :: SimpleRepo -> [Char]
showsPrec :: Int -> SimpleRepo -> ShowS
$cshowsPrec :: Int -> SimpleRepo -> ShowS
Show, forall x. Rep SimpleRepo x -> SimpleRepo
forall x. SimpleRepo -> Rep SimpleRepo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SimpleRepo x -> SimpleRepo
$cfrom :: forall x. SimpleRepo -> Rep SimpleRepo x
Generic, SimpleRepo -> SimpleRepo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleRepo -> SimpleRepo -> Bool
$c/= :: SimpleRepo -> SimpleRepo -> Bool
== :: SimpleRepo -> SimpleRepo -> Bool
$c== :: SimpleRepo -> SimpleRepo -> Bool
Eq, Eq SimpleRepo
SimpleRepo -> SimpleRepo -> Bool
SimpleRepo -> SimpleRepo -> Ordering
SimpleRepo -> SimpleRepo -> SimpleRepo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SimpleRepo -> SimpleRepo -> SimpleRepo
$cmin :: SimpleRepo -> SimpleRepo -> SimpleRepo
max :: SimpleRepo -> SimpleRepo -> SimpleRepo
$cmax :: SimpleRepo -> SimpleRepo -> SimpleRepo
>= :: SimpleRepo -> SimpleRepo -> Bool
$c>= :: SimpleRepo -> SimpleRepo -> Bool
> :: SimpleRepo -> SimpleRepo -> Bool
$c> :: SimpleRepo -> SimpleRepo -> Bool
<= :: SimpleRepo -> SimpleRepo -> Bool
$c<= :: SimpleRepo -> SimpleRepo -> Bool
< :: SimpleRepo -> SimpleRepo -> Bool
$c< :: SimpleRepo -> SimpleRepo -> Bool
compare :: SimpleRepo -> SimpleRepo -> Ordering
$ccompare :: SimpleRepo -> SimpleRepo -> Ordering
Ord, Typeable)

instance Display SimpleRepo where
  display :: SimpleRepo -> Utf8Builder
display (SimpleRepo Text
url Text
commit RepoType
typ) =
    (case RepoType
typ of
       RepoType
RepoGit -> Utf8Builder
"Git"
       RepoType
RepoHg -> Utf8Builder
"Mercurial") forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
" repo at " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
commit

-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains

-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar".

newtype GitHubRepo = GitHubRepo Text

instance FromJSON GitHubRepo where
  parseJSON :: Value -> Parser GitHubRepo
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"GitHubRepo" forall a b. (a -> b) -> a -> b
$ \Text
s -> do
    case (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
s of
      [Text
x, Text
y] | Bool -> Bool
not (Text -> Bool
T.null Text
x Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
y) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GitHubRepo
GitHubRepo Text
s)
      [Text]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expecting \"user/repo\""

-- | Configuration to securely download package metadata and contents. For most

-- purposes, you'll want to use the default Hackage settings via

-- @defaultPackageIndexConfig@.

--

-- /NOTE/ It's highly recommended to only use the official Hackage

-- server or a mirror. See

-- <https://github.com/commercialhaskell/stack/issues/4137>.

--

-- @since 0.6.0

data PackageIndexConfig = PackageIndexConfig
  { PackageIndexConfig -> Text
picDownloadPrefix :: !Text
  , PackageIndexConfig -> HackageSecurityConfig
picHackageSecurityConfig :: !HackageSecurityConfig
  }
  deriving Int -> PackageIndexConfig -> ShowS
[PackageIndexConfig] -> ShowS
PackageIndexConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageIndexConfig] -> ShowS
$cshowList :: [PackageIndexConfig] -> ShowS
show :: PackageIndexConfig -> [Char]
$cshow :: PackageIndexConfig -> [Char]
showsPrec :: Int -> PackageIndexConfig -> ShowS
$cshowsPrec :: Int -> PackageIndexConfig -> ShowS
Show

-- | If the @hackage-security@ key is absent from the JSON object, assigns

-- default value 'defaultHackageSecurityConfig'.

--

-- @since 0.6.0

instance FromJSON (WithJSONWarnings PackageIndexConfig) where
  parseJSON :: Value -> Parser (WithJSONWarnings PackageIndexConfig)
parseJSON = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"PackageIndexConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
picDownloadPrefix <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"download-prefix"
    HackageSecurityConfig
picHackageSecurityConfig <- forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings forall a b. (a -> b) -> a -> b
$
      Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"hackage-security" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall a. a -> WithJSONWarnings a
noJSONWarnings HackageSecurityConfig
defaultHackageSecurityConfig
    forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig {Text
HackageSecurityConfig
picHackageSecurityConfig :: HackageSecurityConfig
picDownloadPrefix :: Text
picHackageSecurityConfig :: HackageSecurityConfig
picDownloadPrefix :: Text
..}

-- | Default 'HackageSecurityConfig' value using the official Hackage server.

-- The value of the 'hscIgnoreExpiry' field is 'True'.

--

-- @since 0.7.0

defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig = HackageSecurityConfig
  { hscKeyIds :: [Text]
hscKeyIds =
      -- Key owners and public keys are provided as a convenience to readers.

      -- The canonical source for this mapping data is the hackage-root-keys

      -- repository and Hackage's root.json file.

      --

      -- Links:

      --  * https://github.com/haskell-infra/hackage-root-keys

      --  * https://hackage.haskell.org/root.json

      -- Please consult root.json on Hackage to map key IDs to public keys,

      -- and the hackage-root-keys repository to map public keys to their

      -- owners.

      [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)

        Text
"fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
      , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)

        Text
"1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
      , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)

        Text
"0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
      , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)

        Text
"51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
      , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)

        Text
"be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"
      , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)

        Text
"d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"
      ]
  , hscKeyThreshold :: Int
hscKeyThreshold = Int
3
  , hscIgnoreExpiry :: Bool
hscIgnoreExpiry = Bool
True
  }

-- | Configuration for Hackage Security to securely download package metadata

-- and contents. For most purposes, you'll want to use the default Hackage

-- settings via @defaultHackageSecurityConfig@.

--

-- /NOTE/ It's highly recommended to only use the official Hackage

-- server or a mirror. See

-- <https://github.com/commercialhaskell/stack/issues/4137>.

--

-- @since 0.6.0

data HackageSecurityConfig = HackageSecurityConfig
  { HackageSecurityConfig -> [Text]
hscKeyIds :: ![Text]
  , HackageSecurityConfig -> Int
hscKeyThreshold :: !Int
  , HackageSecurityConfig -> Bool
hscIgnoreExpiry :: !Bool
  }
  deriving Int -> HackageSecurityConfig -> ShowS
[HackageSecurityConfig] -> ShowS
HackageSecurityConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HackageSecurityConfig] -> ShowS
$cshowList :: [HackageSecurityConfig] -> ShowS
show :: HackageSecurityConfig -> [Char]
$cshow :: HackageSecurityConfig -> [Char]
showsPrec :: Int -> HackageSecurityConfig -> ShowS
$cshowsPrec :: Int -> HackageSecurityConfig -> ShowS
Show

-- | If the @ignore-expiry@ key is absent from the JSON object, assigns default

-- value 'True'.

--

-- @since 0.1.1.0

instance FromJSON (WithJSONWarnings HackageSecurityConfig) where
  parseJSON :: Value -> Parser (WithJSONWarnings HackageSecurityConfig)
parseJSON = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"HackageSecurityConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    [Text]
hscKeyIds <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"keyids"
    Int
hscKeyThreshold <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"key-threshold"
    Bool
hscIgnoreExpiry <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"ignore-expiry" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Bool
True
    forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageSecurityConfig {Bool
Int
[Text]
hscIgnoreExpiry :: Bool
hscKeyThreshold :: Int
hscKeyIds :: [Text]
hscIgnoreExpiry :: Bool
hscKeyThreshold :: Int
hscKeyIds :: [Text]
..}

-- | An environment which contains a 'PantryConfig'.

--

-- @since 0.1.0.0

class HasPantryConfig env where
  -- | Lens to get or set the 'PantryConfig'

  --

  -- @since 0.1.0.0

  pantryConfigL :: Lens' env PantryConfig


-- | File size in bytes

--

-- @since 0.1.0.0

newtype FileSize = FileSize Word
  deriving ( Int -> FileSize -> ShowS
[FileSize] -> ShowS
FileSize -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FileSize] -> ShowS
$cshowList :: [FileSize] -> ShowS
show :: FileSize -> [Char]
$cshow :: FileSize -> [Char]
showsPrec :: Int -> FileSize -> ShowS
$cshowsPrec :: Int -> FileSize -> ShowS
Show, FileSize -> FileSize -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileSize -> FileSize -> Bool
$c/= :: FileSize -> FileSize -> Bool
== :: FileSize -> FileSize -> Bool
$c== :: FileSize -> FileSize -> Bool
Eq, Eq FileSize
FileSize -> FileSize -> Bool
FileSize -> FileSize -> Ordering
FileSize -> FileSize -> FileSize
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileSize -> FileSize -> FileSize
$cmin :: FileSize -> FileSize -> FileSize
max :: FileSize -> FileSize -> FileSize
$cmax :: FileSize -> FileSize -> FileSize
>= :: FileSize -> FileSize -> Bool
$c>= :: FileSize -> FileSize -> Bool
> :: FileSize -> FileSize -> Bool
$c> :: FileSize -> FileSize -> Bool
<= :: FileSize -> FileSize -> Bool
$c<= :: FileSize -> FileSize -> Bool
< :: FileSize -> FileSize -> Bool
$c< :: FileSize -> FileSize -> Bool
compare :: FileSize -> FileSize -> Ordering
$ccompare :: FileSize -> FileSize -> Ordering
Ord, Typeable, forall x. Rep FileSize x -> FileSize
forall x. FileSize -> Rep FileSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileSize x -> FileSize
$cfrom :: forall x. FileSize -> Rep FileSize x
Generic, FileSize -> Text
FileSize -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: FileSize -> Text
$ctextDisplay :: FileSize -> Text
display :: FileSize -> Utf8Builder
$cdisplay :: FileSize -> Utf8Builder
Display, Eq FileSize
Int -> FileSize -> Int
FileSize -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: FileSize -> Int
$chash :: FileSize -> Int
hashWithSalt :: Int -> FileSize -> Int
$chashWithSalt :: Int -> FileSize -> Int
Hashable, FileSize -> ()
forall a. (a -> ()) -> NFData a
rnf :: FileSize -> ()
$crnf :: FileSize -> ()
NFData
           , PersistValue -> Either Text FileSize
FileSize -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text FileSize
$cfromPersistValue :: PersistValue -> Either Text FileSize
toPersistValue :: FileSize -> PersistValue
$ctoPersistValue :: FileSize -> PersistValue
PersistField, PersistField FileSize
Proxy FileSize -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy FileSize -> SqlType
$csqlType :: Proxy FileSize -> SqlType
PersistFieldSql, [FileSize] -> Encoding
[FileSize] -> Value
FileSize -> Encoding
FileSize -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FileSize] -> Encoding
$ctoEncodingList :: [FileSize] -> Encoding
toJSONList :: [FileSize] -> Value
$ctoJSONList :: [FileSize] -> Value
toEncoding :: FileSize -> Encoding
$ctoEncoding :: FileSize -> Encoding
toJSON :: FileSize -> Value
$ctoJSON :: FileSize -> Value
ToJSON, Value -> Parser [FileSize]
Value -> Parser FileSize
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FileSize]
$cparseJSONList :: Value -> Parser [FileSize]
parseJSON :: Value -> Parser FileSize
$cparseJSON :: Value -> Parser FileSize
FromJSON
           )

-- | A key for looking up a blob, which combines the SHA256 hash of the contents

-- and the file size.

--

-- The file size may seem redundant with the hash. However, it is necessary for

-- safely downloading blobs from an untrusted source. See

-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>.

--

-- @since 0.1.0.0

data BlobKey = BlobKey !SHA256 !FileSize
  deriving (BlobKey -> BlobKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlobKey -> BlobKey -> Bool
$c/= :: BlobKey -> BlobKey -> Bool
== :: BlobKey -> BlobKey -> Bool
$c== :: BlobKey -> BlobKey -> Bool
Eq, Eq BlobKey
BlobKey -> BlobKey -> Bool
BlobKey -> BlobKey -> Ordering
BlobKey -> BlobKey -> BlobKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlobKey -> BlobKey -> BlobKey
$cmin :: BlobKey -> BlobKey -> BlobKey
max :: BlobKey -> BlobKey -> BlobKey
$cmax :: BlobKey -> BlobKey -> BlobKey
>= :: BlobKey -> BlobKey -> Bool
$c>= :: BlobKey -> BlobKey -> Bool
> :: BlobKey -> BlobKey -> Bool
$c> :: BlobKey -> BlobKey -> Bool
<= :: BlobKey -> BlobKey -> Bool
$c<= :: BlobKey -> BlobKey -> Bool
< :: BlobKey -> BlobKey -> Bool
$c< :: BlobKey -> BlobKey -> Bool
compare :: BlobKey -> BlobKey -> Ordering
$ccompare :: BlobKey -> BlobKey -> Ordering
Ord, Typeable, forall x. Rep BlobKey x -> BlobKey
forall x. BlobKey -> Rep BlobKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlobKey x -> BlobKey
$cfrom :: forall x. BlobKey -> Rep BlobKey x
Generic)

instance NFData BlobKey

instance Show BlobKey where
  show :: BlobKey -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance Display BlobKey where
  display :: BlobKey -> Utf8Builder
display (BlobKey SHA256
sha FileSize
size') = forall a. Display a => a -> Utf8Builder
display SHA256
sha forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"," forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
size'

blobKeyPairs :: BlobKey -> [(AesonKey, Value)]
blobKeyPairs :: BlobKey -> [(AesonKey, Value)]
blobKeyPairs (BlobKey SHA256
sha FileSize
size') =
  [ AesonKey
"sha256" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SHA256
sha
  , AesonKey
"size" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= FileSize
size'
  ]

instance ToJSON BlobKey where
  toJSON :: BlobKey -> Value
toJSON = [(AesonKey, Value)] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlobKey -> [(AesonKey, Value)]
blobKeyPairs

instance FromJSON BlobKey where
  parseJSON :: Value -> Parser BlobKey
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"BlobKey" forall a b. (a -> b) -> a -> b
$ \Object
o -> SHA256 -> FileSize -> BlobKey
BlobKey
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"sha256"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"size"

newtype PackageNameP = PackageNameP { PackageNameP -> PackageName
unPackageNameP :: PackageName }
  deriving (PackageNameP -> PackageNameP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageNameP -> PackageNameP -> Bool
$c/= :: PackageNameP -> PackageNameP -> Bool
== :: PackageNameP -> PackageNameP -> Bool
$c== :: PackageNameP -> PackageNameP -> Bool
Eq, Eq PackageNameP
PackageNameP -> PackageNameP -> Bool
PackageNameP -> PackageNameP -> Ordering
PackageNameP -> PackageNameP -> PackageNameP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageNameP -> PackageNameP -> PackageNameP
$cmin :: PackageNameP -> PackageNameP -> PackageNameP
max :: PackageNameP -> PackageNameP -> PackageNameP
$cmax :: PackageNameP -> PackageNameP -> PackageNameP
>= :: PackageNameP -> PackageNameP -> Bool
$c>= :: PackageNameP -> PackageNameP -> Bool
> :: PackageNameP -> PackageNameP -> Bool
$c> :: PackageNameP -> PackageNameP -> Bool
<= :: PackageNameP -> PackageNameP -> Bool
$c<= :: PackageNameP -> PackageNameP -> Bool
< :: PackageNameP -> PackageNameP -> Bool
$c< :: PackageNameP -> PackageNameP -> Bool
compare :: PackageNameP -> PackageNameP -> Ordering
$ccompare :: PackageNameP -> PackageNameP -> Ordering
Ord, Int -> PackageNameP -> ShowS
[PackageNameP] -> ShowS
PackageNameP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageNameP] -> ShowS
$cshowList :: [PackageNameP] -> ShowS
show :: PackageNameP -> [Char]
$cshow :: PackageNameP -> [Char]
showsPrec :: Int -> PackageNameP -> ShowS
$cshowsPrec :: Int -> PackageNameP -> ShowS
Show, ReadPrec [PackageNameP]
ReadPrec PackageNameP
Int -> ReadS PackageNameP
ReadS [PackageNameP]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PackageNameP]
$creadListPrec :: ReadPrec [PackageNameP]
readPrec :: ReadPrec PackageNameP
$creadPrec :: ReadPrec PackageNameP
readList :: ReadS [PackageNameP]
$creadList :: ReadS [PackageNameP]
readsPrec :: Int -> ReadS PackageNameP
$creadsPrec :: Int -> ReadS PackageNameP
Read, PackageNameP -> ()
forall a. (a -> ()) -> NFData a
rnf :: PackageNameP -> ()
$crnf :: PackageNameP -> ()
NFData)

instance Display PackageNameP where
  display :: PackageNameP -> Utf8Builder
display = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageNameP -> PackageName
unPackageNameP

instance PersistField PackageNameP where
  toPersistValue :: PackageNameP -> PersistValue
toPersistValue (PackageNameP PackageName
pn) = Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pn
  fromPersistValue :: PersistValue -> Either Text PackageNameP
fromPersistValue PersistValue
v = do
    [Char]
str <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case [Char] -> Maybe PackageName
parsePackageName [Char]
str of
      Maybe PackageName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid package name: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
str
      Just PackageName
pn -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PackageName -> PackageNameP
PackageNameP PackageName
pn

instance PersistFieldSql PackageNameP where
  sqlType :: Proxy PackageNameP -> SqlType
sqlType Proxy PackageNameP
_ = SqlType
SqlString

instance ToJSON PackageNameP where
  toJSON :: PackageNameP -> Value
toJSON (PackageNameP PackageName
pn) = Text -> Value
String forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pn

instance FromJSON PackageNameP where
  parseJSON :: Value -> Parser PackageNameP
parseJSON =
    forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"PackageNameP" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> PackageNameP
PackageNameP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PackageName
mkPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

instance ToJSONKey PackageNameP where
  toJSONKey :: ToJSONKeyFunction PackageNameP
toJSONKey =
    forall a.
(a -> AesonKey) -> (a -> Encoding' AesonKey) -> ToJSONKeyFunction a
ToJSONKeyText
      (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageNameP -> PackageName
unPackageNameP)
      (forall a. Builder -> Encoding' a
unsafeToEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Builder
getUtf8Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)

instance FromJSONKey PackageNameP where
  fromJSONKey :: FromJSONKeyFunction PackageNameP
fromJSONKey = forall a. (Text -> a) -> FromJSONKeyFunction a
FromJSONKeyText forall a b. (a -> b) -> a -> b
$ PackageName -> PackageNameP
PackageNameP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PackageName
mkPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

newtype VersionP = VersionP { VersionP -> Version
unVersionP :: Version }
  deriving (VersionP -> VersionP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VersionP -> VersionP -> Bool
$c/= :: VersionP -> VersionP -> Bool
== :: VersionP -> VersionP -> Bool
$c== :: VersionP -> VersionP -> Bool
Eq, Eq VersionP
VersionP -> VersionP -> Bool
VersionP -> VersionP -> Ordering
VersionP -> VersionP -> VersionP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VersionP -> VersionP -> VersionP
$cmin :: VersionP -> VersionP -> VersionP
max :: VersionP -> VersionP -> VersionP
$cmax :: VersionP -> VersionP -> VersionP
>= :: VersionP -> VersionP -> Bool
$c>= :: VersionP -> VersionP -> Bool
> :: VersionP -> VersionP -> Bool
$c> :: VersionP -> VersionP -> Bool
<= :: VersionP -> VersionP -> Bool
$c<= :: VersionP -> VersionP -> Bool
< :: VersionP -> VersionP -> Bool
$c< :: VersionP -> VersionP -> Bool
compare :: VersionP -> VersionP -> Ordering
$ccompare :: VersionP -> VersionP -> Ordering
Ord, Int -> VersionP -> ShowS
[VersionP] -> ShowS
VersionP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VersionP] -> ShowS
$cshowList :: [VersionP] -> ShowS
show :: VersionP -> [Char]
$cshow :: VersionP -> [Char]
showsPrec :: Int -> VersionP -> ShowS
$cshowsPrec :: Int -> VersionP -> ShowS
Show, ReadPrec [VersionP]
ReadPrec VersionP
Int -> ReadS VersionP
ReadS [VersionP]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [VersionP]
$creadListPrec :: ReadPrec [VersionP]
readPrec :: ReadPrec VersionP
$creadPrec :: ReadPrec VersionP
readList :: ReadS [VersionP]
$creadList :: ReadS [VersionP]
readsPrec :: Int -> ReadS VersionP
$creadsPrec :: Int -> ReadS VersionP
Read, VersionP -> ()
forall a. (a -> ()) -> NFData a
rnf :: VersionP -> ()
$crnf :: VersionP -> ()
NFData)

instance PersistField VersionP where
  toPersistValue :: VersionP -> PersistValue
toPersistValue (VersionP Version
v) = Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
v
  fromPersistValue :: PersistValue -> Either Text VersionP
fromPersistValue PersistValue
v = do
    [Char]
str <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case [Char] -> Maybe Version
parseVersion [Char]
str of
      Maybe Version
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid version number: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
str
      Just Version
ver -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Version -> VersionP
VersionP Version
ver

instance PersistFieldSql VersionP where
  sqlType :: Proxy VersionP -> SqlType
sqlType Proxy VersionP
_ = SqlType
SqlString

instance Display VersionP where
  display :: VersionP -> Utf8Builder
display (VersionP Version
v) = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
v

instance ToJSON VersionP where
  toJSON :: VersionP -> Value
toJSON (VersionP Version
v) = Text -> Value
String forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
v

instance FromJSON VersionP where
  parseJSON :: Value -> Parser VersionP
parseJSON =
    forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"VersionP" forall a b. (a -> b) -> a -> b
$
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> [Char]
displayException) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> VersionP
VersionP) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

newtype ModuleNameP = ModuleNameP
  { ModuleNameP -> ModuleName
unModuleNameP :: ModuleName
  }
  deriving (ModuleNameP -> ModuleNameP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleNameP -> ModuleNameP -> Bool
$c/= :: ModuleNameP -> ModuleNameP -> Bool
== :: ModuleNameP -> ModuleNameP -> Bool
$c== :: ModuleNameP -> ModuleNameP -> Bool
Eq, Eq ModuleNameP
ModuleNameP -> ModuleNameP -> Bool
ModuleNameP -> ModuleNameP -> Ordering
ModuleNameP -> ModuleNameP -> ModuleNameP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModuleNameP -> ModuleNameP -> ModuleNameP
$cmin :: ModuleNameP -> ModuleNameP -> ModuleNameP
max :: ModuleNameP -> ModuleNameP -> ModuleNameP
$cmax :: ModuleNameP -> ModuleNameP -> ModuleNameP
>= :: ModuleNameP -> ModuleNameP -> Bool
$c>= :: ModuleNameP -> ModuleNameP -> Bool
> :: ModuleNameP -> ModuleNameP -> Bool
$c> :: ModuleNameP -> ModuleNameP -> Bool
<= :: ModuleNameP -> ModuleNameP -> Bool
$c<= :: ModuleNameP -> ModuleNameP -> Bool
< :: ModuleNameP -> ModuleNameP -> Bool
$c< :: ModuleNameP -> ModuleNameP -> Bool
compare :: ModuleNameP -> ModuleNameP -> Ordering
$ccompare :: ModuleNameP -> ModuleNameP -> Ordering
Ord, Int -> ModuleNameP -> ShowS
[ModuleNameP] -> ShowS
ModuleNameP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ModuleNameP] -> ShowS
$cshowList :: [ModuleNameP] -> ShowS
show :: ModuleNameP -> [Char]
$cshow :: ModuleNameP -> [Char]
showsPrec :: Int -> ModuleNameP -> ShowS
$cshowsPrec :: Int -> ModuleNameP -> ShowS
Show, ModuleNameP -> ()
forall a. (a -> ()) -> NFData a
rnf :: ModuleNameP -> ()
$crnf :: ModuleNameP -> ()
NFData)

instance Display ModuleNameP where
  display :: ModuleNameP -> Utf8Builder
display = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameP -> ModuleName
unModuleNameP

instance PersistField ModuleNameP where
  toPersistValue :: ModuleNameP -> PersistValue
toPersistValue (ModuleNameP ModuleName
mn) = Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString ModuleName
mn
  fromPersistValue :: PersistValue -> Either Text ModuleNameP
fromPersistValue PersistValue
v = do
    [Char]
str <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case [Char] -> Maybe ModuleName
parseModuleName [Char]
str of
      Maybe ModuleName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid module name: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
str
      Just ModuleName
pn -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleNameP
ModuleNameP ModuleName
pn

instance PersistFieldSql ModuleNameP where
  sqlType :: Proxy ModuleNameP -> SqlType
sqlType Proxy ModuleNameP
_ = SqlType
SqlString

-- | How to choose a cabal file for a package from Hackage. This is to work with

-- Hackage cabal file revisions, which makes @PackageIdentifier@ insufficient

-- for specifying a package from Hackage.

--

-- @since 0.1.0.0

data CabalFileInfo
  = CFILatest
    -- ^ Take the latest revision of the cabal file available. This

    -- isn't reproducible at all, but the running assumption (not

    -- necessarily true) is that cabal file revisions do not change

    -- semantics of the build.

    --

    -- @since 0.1.0.0

  | CFIHash !SHA256 !(Maybe FileSize)
    -- ^ Identify by contents of the cabal file itself. Only reason for

    -- @Maybe@ on @FileSize@ is for compatibility with input that

    -- doesn't include the file size.

    --

    -- @since 0.1.0.0

  | CFIRevision !Revision
    -- ^ Identify by revision number, with 0 being the original and

    -- counting upward. This relies on Hackage providing consistent

    -- versioning. @CFIHash@ should be preferred wherever possible for

    -- reproducibility.

    --

    -- @since 0.1.0.0

  deriving (forall x. Rep CabalFileInfo x -> CabalFileInfo
forall x. CabalFileInfo -> Rep CabalFileInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CabalFileInfo x -> CabalFileInfo
$cfrom :: forall x. CabalFileInfo -> Rep CabalFileInfo x
Generic, Int -> CabalFileInfo -> ShowS
[CabalFileInfo] -> ShowS
CabalFileInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CabalFileInfo] -> ShowS
$cshowList :: [CabalFileInfo] -> ShowS
show :: CabalFileInfo -> [Char]
$cshow :: CabalFileInfo -> [Char]
showsPrec :: Int -> CabalFileInfo -> ShowS
$cshowsPrec :: Int -> CabalFileInfo -> ShowS
Show, CabalFileInfo -> CabalFileInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CabalFileInfo -> CabalFileInfo -> Bool
$c/= :: CabalFileInfo -> CabalFileInfo -> Bool
== :: CabalFileInfo -> CabalFileInfo -> Bool
$c== :: CabalFileInfo -> CabalFileInfo -> Bool
Eq, Eq CabalFileInfo
CabalFileInfo -> CabalFileInfo -> Bool
CabalFileInfo -> CabalFileInfo -> Ordering
CabalFileInfo -> CabalFileInfo -> CabalFileInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
$cmin :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
max :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
$cmax :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
>= :: CabalFileInfo -> CabalFileInfo -> Bool
$c>= :: CabalFileInfo -> CabalFileInfo -> Bool
> :: CabalFileInfo -> CabalFileInfo -> Bool
$c> :: CabalFileInfo -> CabalFileInfo -> Bool
<= :: CabalFileInfo -> CabalFileInfo -> Bool
$c<= :: CabalFileInfo -> CabalFileInfo -> Bool
< :: CabalFileInfo -> CabalFileInfo -> Bool
$c< :: CabalFileInfo -> CabalFileInfo -> Bool
compare :: CabalFileInfo -> CabalFileInfo -> Ordering
$ccompare :: CabalFileInfo -> CabalFileInfo -> Ordering
Ord, Typeable)

instance NFData CabalFileInfo

instance Hashable CabalFileInfo

instance Display CabalFileInfo where
  display :: CabalFileInfo -> Utf8Builder
display CabalFileInfo
CFILatest = forall a. Monoid a => a
mempty
  display (CFIHash SHA256
hash' Maybe FileSize
msize) =
    Utf8Builder
"@sha256:" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
hash' forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\FileSize
i -> Utf8Builder
"," forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
i) Maybe FileSize
msize
  display (CFIRevision Revision
rev) = Utf8Builder
"@rev:" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Revision
rev

-- | A full specification for a package from Hackage, including the package

-- name, version, and how to load up the correct cabal file revision.

--

-- @since 0.1.0.0

data PackageIdentifierRevision
  = PackageIdentifierRevision !PackageName !Version !CabalFileInfo
  deriving (forall x.
Rep PackageIdentifierRevision x -> PackageIdentifierRevision
forall x.
PackageIdentifierRevision -> Rep PackageIdentifierRevision x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep PackageIdentifierRevision x -> PackageIdentifierRevision
$cfrom :: forall x.
PackageIdentifierRevision -> Rep PackageIdentifierRevision x
Generic, PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c/= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
== :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c== :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
Eq, Eq PackageIdentifierRevision
PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
PackageIdentifierRevision -> PackageIdentifierRevision -> Ordering
PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
$cmin :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
max :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
$cmax :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
>= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c>= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
> :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c> :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
<= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c<= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
< :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c< :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
compare :: PackageIdentifierRevision -> PackageIdentifierRevision -> Ordering
$ccompare :: PackageIdentifierRevision -> PackageIdentifierRevision -> Ordering
Ord, Typeable)

instance NFData PackageIdentifierRevision

instance Show PackageIdentifierRevision where
  show :: PackageIdentifierRevision -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance Display PackageIdentifierRevision where
  display :: PackageIdentifierRevision -> Utf8Builder
display (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi) =
       forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"-"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
version)
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display CabalFileInfo
cfi

instance ToJSON PackageIdentifierRevision where
  toJSON :: PackageIdentifierRevision -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance FromJSON PackageIdentifierRevision where
  parseJSON :: Value -> Parser PackageIdentifierRevision
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"PackageIdentifierRevision" forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t of
      Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PantryException
e
      Right PackageIdentifierRevision
pir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifierRevision
pir

-- | Parse a hackage text.

--

-- @since 0.1.0.0

parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText Text
t =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\[Char]
x -> forall a. HasCallStack => [Char] -> a
error (forall a. Show a => a -> [Char]
show [Char]
x) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageIdentifierRevisionParseFail Text
t) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
  forall a. ParsecParser a -> [Char] -> Either [Char] a
explicitEitherParsec (ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Parsing m => m ()
Parse.eof) forall a b. (a -> b) -> a -> b
$
  Text -> [Char]
T.unpack Text
t

hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec = do
  PackageIdentifier
ident <- ParsecParser PackageIdentifier
packageIdentifierParsec
  [Char]
_ <- forall (m :: * -> *). CharParsing m => [Char] -> m [Char]
Parse.string [Char]
"@sha256:"

  [Char]
shaT <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m [Char]
Parse.munch (forall a. Eq a => a -> a -> Bool
/= Char
',')
  SHA256
sha <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall (m :: * -> *) a. MonadPlus m => m a
mzero) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Either SHA256Exception SHA256
SHA256.fromHexText forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString [Char]
shaT

  Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
Parse.char Char
','
  Word
size' <- forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier
ident, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha (Word -> FileSize
FileSize Word
size'))

splitColon :: Text -> Maybe (Text, Text)
splitColon :: Text -> Maybe (Text, Text)
splitColon Text
t' =
  let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
t'
  in  (Text
x, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
y

-- | Parse a 'PackageIdentifierRevision'

--

-- @since 0.1.0.0

parsePackageIdentifierRevision ::
     Text
  -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageIdentifierRevisionParseFail Text
t) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ do
    let (Text
identT, Text
cfiT) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'@') Text
t
    PackageIdentifier PackageName
name Version
version <- [Char] -> Maybe PackageIdentifier
parsePackageIdentifier forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
identT
    CabalFileInfo
cfi <-
      case Text -> Maybe (Text, Text)
splitColon Text
cfiT of
        Just (Text
"@sha256", Text
shaSizeT) -> do
          let (Text
shaT, Text
sizeT) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
',') Text
shaSizeT
          SHA256
sha <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Either SHA256Exception SHA256
SHA256.fromHexText Text
shaT
          Maybe FileSize
msize <-
            case Text -> Text -> Maybe Text
T.stripPrefix Text
"," Text
sizeT of
              Maybe Text
Nothing -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
              Just Text
sizeT' ->
                case forall a. Integral a => Reader a
decimal Text
sizeT' of
                  Right (Word
size', Text
"") -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word -> FileSize
FileSize Word
size'
                  Either [Char] (Word, Text)
_ -> forall a. Maybe a
Nothing
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha Maybe FileSize
msize
        Just (Text
"@rev", Text
revT) ->
          case forall a. Integral a => Reader a
decimal Text
revT of
            Right (Word
rev, Text
"") -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Revision -> CabalFileInfo
CFIRevision forall a b. (a -> b) -> a -> b
$ Word -> Revision
Revision Word
rev
            Either [Char] (Word, Text)
_ -> forall a. Maybe a
Nothing
        Maybe (Text, Text)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalFileInfo
CFILatest
        Maybe (Text, Text)
_ -> forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi

data Mismatch a = Mismatch
  { forall a. Mismatch a -> a
mismatchExpected :: !a
  , forall a. Mismatch a -> a
mismatchActual :: !a
  }

-- | Things that can go wrong in pantry. Note two things:

--

-- * Many other exception types may be thrown from underlying libraries. Pantry

--   does not attempt to wrap these underlying exceptions.

--

-- * We may add more constructors to this data type in minor version bumps of

--   pantry. This technically breaks the PVP. You should not be writing pattern

--   matches against this type that expect total matching.

--

-- @since 0.1.0.0

data PantryException
  = PackageIdentifierRevisionParseFail !Text
  | InvalidCabalFile
      !(Either RawPackageLocationImmutable (Path Abs File))
      !(Maybe Version)
      ![PError]
      ![PWarning]
  | TreeWithoutCabalFile !RawPackageLocationImmutable
  | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath]
  | MismatchedCabalName !(Path Abs File) !PackageName
  | NoLocalPackageDirFound !(Path Abs Dir)
  | NoCabalFileFound !(Path Abs Dir)
  | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File]
  | InvalidWantedCompiler !Text
  | InvalidSnapshotLocation !(Path Abs Dir) !Text
  | InvalidOverrideCompiler !WantedCompiler !WantedCompiler
  | InvalidFilePathSnapshot !Text
  | InvalidSnapshot !RawSnapshotLocation !SomeException
  | MismatchedPackageMetadata
      !RawPackageLocationImmutable
      !RawPackageMetadata
      !(Maybe TreeKey)
      !PackageIdentifier
  | Non200ResponseStatus !Status
  | InvalidBlobKey !(Mismatch BlobKey)
  | Couldn'tParseSnapshot !RawSnapshotLocation !String
  | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName
  | DownloadInvalidSHA256 !Text !(Mismatch SHA256)
  | DownloadInvalidSize !Text !(Mismatch FileSize)
  | DownloadTooLarge !Text !(Mismatch FileSize)
  -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is

  -- a lower bound on the size from the server.

  | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256)
  | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize)
  | UnknownArchiveType !ArchiveLocation
  | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType
  | UnsupportedTarball !ArchiveLocation !Text
  | NoHackageCryptographicHash !PackageIdentifier
  | FailedToCloneRepo !SimpleRepo
  | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey
  | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata
  | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32)
  | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults
  | CannotCompleteRepoNonSHA1 !Repo
  | MutablePackageLocationFromUrl !Text
  | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier)
  | PackageNameParseFail !Text
  | PackageVersionParseFail !Text
  | InvalidCabalFilePath !(Path Abs File)
  | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])]
  | MigrationFailure !Text !(Path Abs File) !SomeException
  | NoCasaConfig
  | InvalidTreeFromCasa !BlobKey !ByteString
  | ParseSnapNameException !Text
  | HpackLibraryException !(Path Abs File) !String
  | HpackExeException !FilePath !(Path Abs Dir) !SomeException
  deriving Typeable

instance Exception PantryException where

instance Show PantryException where
  show :: PantryException -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

-- To support the Haskell Foundation's

-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry

-- error messages generated by Pantry itself begin with an unique code in the

-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999.

-- The numbers are selected at random, not in sequence.

--

-- Prettier versions of these error messages are also provided. See the instance

-- of Pretty.

instance Display PantryException where
  display :: PantryException -> Utf8Builder
display PantryException
NoCasaConfig =
    Utf8Builder
"Error: [S-889]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The Pantry configuration has no Casa configuration."
  display (InvalidTreeFromCasa BlobKey
blobKey ByteString
_bs) =
    Utf8Builder
"Error: [S-258]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid tree from casa: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blobKey
  display (PackageIdentifierRevisionParseFail Text
text) =
    Utf8Builder
"Error: [S-360]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid package identifier (with optional revision): "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
text
  display (InvalidCabalFile Either RawPackageLocationImmutable (Path Abs File)
loc Maybe Version
mversion [PError]
errs [PWarning]
warnings) =
    Utf8Builder
"Error: [S-242]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unable to parse cabal file from package "
    forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Display a => a -> Utf8Builder
display (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath) Either RawPackageLocationImmutable (Path Abs File)
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n\n"
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PError Position
pos [Char]
msg) ->
                 Utf8Builder
"- "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Position -> [Char]
showPos Position
pos)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
msg
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
         )
         [PError]
errs
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PWarning PWarnType
_ Position
pos [Char]
msg) ->
                 Utf8Builder
"- "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Position -> [Char]
showPos Position
pos)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
msg
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
         )
         [PWarning]
warnings
    forall a. Semigroup a => a -> a -> a
<> ( case Maybe Version
mversion of
           Just Version
version
             | Version
version forall a. Ord a => a -> a -> Bool
> Version
cabalSpecLatestVersion ->
                    Utf8Builder
"\n\nThe cabal file uses the cabal specification version "
                 forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
version)
                 forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but we only support up to version "
                 forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalSpecLatestVersion)
                 forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)."
           Maybe Version
_ -> forall a. Monoid a => a
mempty
       )
  display (TreeWithoutCabalFile RawPackageLocationImmutable
pl) =
    Utf8Builder
"Error: [S-654]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"No cabal file found for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
  display (TreeWithMultipleCabalFiles RawPackageLocationImmutable
pl [SafeFilePath]
sfps) =
    Utf8Builder
"Error: [S-500]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Multiple cabal files found for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Display a => a -> Utf8Builder
display [SafeFilePath]
sfps))
  display (MismatchedCabalName Path Abs File
fp PackageName
name) =
    Utf8Builder
"Error: [S-910]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The Cabal file:\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nis not named after the package that it defines.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Please rename the file to: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".cabal\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Hackage rejects packages where the first part of the Cabal file name "
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"is not the package name."
  display (NoLocalPackageDirFound Path Abs Dir
dir) =
    Utf8Builder
"Error: [S-395]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Stack looks for packages in the directories configured in\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"the 'packages' and 'extra-deps' fields defined in your stack.yaml\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The current entry points to "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
",\nbut no such directory could be found. If, alternatively, a package\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"in the package index was intended, its name and version must be\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"specified as an extra-dep."
  display (NoCabalFileFound Path Abs Dir
dir) =
    Utf8Builder
"Error: [S-636]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Stack looks for packages in the directories configured in\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"the 'packages' and 'extra-deps' fields defined in your stack.yaml\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The current entry points to "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
",\nbut no .cabal or package.yaml file could be found there."
  display (MultipleCabalFilesFound Path Abs Dir
dir [Path Abs File]
files) =
    Utf8Builder
"Error: [S-368]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Multiple .cabal files found in directory "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\n"
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
         ( forall a. a -> [a] -> [a]
intersperse
             Utf8Builder
"\n"
             (forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs File
x -> Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
x))) [Path Abs File]
files)
         )
  display (InvalidWantedCompiler Text
t) =
    Utf8Builder
"Error: [S-204]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid wanted compiler: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (InvalidSnapshotLocation Path Abs Dir
dir Text
t) =
    Utf8Builder
"Error: [S-935]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid snapshot location "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
t
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" relative to directory "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
  display (InvalidOverrideCompiler WantedCompiler
x WantedCompiler
y) =
    Utf8Builder
"Error: [S-287]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Specified compiler for a resolver ("
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display WantedCompiler
x
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"), but also specified an override compiler ("
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display WantedCompiler
y
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
  display (InvalidFilePathSnapshot Text
t) =
    Utf8Builder
"Error: [S-617]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Specified snapshot as file path with "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
t
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but not reading from a local file"
  display (InvalidSnapshot RawSnapshotLocation
loc SomeException
err) =
    Utf8Builder
"Error: [S-775]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Exception while reading snapshot from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
  display (MismatchedPackageMetadata RawPackageLocationImmutable
loc RawPackageMetadata
pm Maybe TreeKey
mtreeKey PackageIdentifier
foundIdent) =
    Utf8Builder
"Error: [S-427]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched package metadata for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nFound: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
foundIdent)
    forall a. Semigroup a => a -> a -> a
<> ( case Maybe TreeKey
mtreeKey of
           Maybe TreeKey
Nothing -> forall a. Monoid a => a
mempty
           Just TreeKey
treeKey -> Utf8Builder
" with tree " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display TreeKey
treeKey
       )
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageMetadata
pm
  display (Non200ResponseStatus Status
status) =
    Utf8Builder
"Error: [S-571]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unexpected non-200 HTTP status code: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (Status -> Int
statusCode Status
status)
  display (InvalidBlobKey Mismatch{BlobKey
mismatchActual :: BlobKey
mismatchExpected :: BlobKey
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-236]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid blob key found, expected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", actual: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
mismatchActual
  display (Couldn'tParseSnapshot RawSnapshotLocation
sl [Char]
err) =
    Utf8Builder
"Error: [S-645]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Couldn't parse snapshot from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
sl
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
err
  display (WrongCabalFileName RawPackageLocationImmutable
pl SafeFilePath
sfp PackageName
name) =
    Utf8Builder
"Error: [S-575]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Wrong cabal file name for package "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nThe cabal file is named "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SafeFilePath
sfp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but package name is "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nFor more information, see:\n  - https://github.com/commercialhaskell/stack/issues/317\n  -https://github.com/commercialhaskell/stack/issues/895"
  display (DownloadInvalidSHA256 Text
url Mismatch {SHA256
mismatchActual :: SHA256
mismatchExpected :: SHA256
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-394]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched SHA256 hash from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchActual
  display (DownloadInvalidSize Text
url Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-401]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched download size from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchActual
  display (DownloadTooLarge Text
url Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-113]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Download from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was too large.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Expected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", stopped after receiving: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchActual
  display (LocalInvalidSHA256 Path Abs File
path Mismatch {SHA256
mismatchActual :: SHA256
mismatchExpected :: SHA256
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-834]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched SHA256 hash from "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
path)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchActual
  display (LocalInvalidSize Path Abs File
path Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-713]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched file size from "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
path)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchActual
  display (UnknownArchiveType ArchiveLocation
loc) =
    Utf8Builder
"Error: [S-372]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unable to determine archive type of: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
  display (InvalidTarFileType ArchiveLocation
loc [Char]
fp FileType
x) =
    Utf8Builder
"Error: [S-950]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unsupported tar file type in archive "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" at file "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
fp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow FileType
x
  display (UnsupportedTarball ArchiveLocation
loc Text
err) =
    Utf8Builder
"Error: [S-760]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unsupported tarball from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
err
  display (NoHackageCryptographicHash PackageIdentifier
ident) =
    Utf8Builder
"Error: [S-922]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"No cryptographic hash found for Hackage package "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident)
  display (FailedToCloneRepo SimpleRepo
repo) =
    Utf8Builder
"Error: [S-109]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Failed to clone repo "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SimpleRepo
repo
  display (TreeReferencesMissingBlob RawPackageLocationImmutable
loc SafeFilePath
sfp BlobKey
key) =
    Utf8Builder
"Error: [S-237]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The package "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" needs blob "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
key
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" for file path "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SafeFilePath
sfp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but the blob is not available"
  display (CompletePackageMetadataMismatch RawPackageLocationImmutable
loc PackageMetadata
pm) =
    Utf8Builder
"Error: [S-984]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"When completing package metadata for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", some values changed in the new package metadata: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageMetadata
pm
  display (CRC32Mismatch ArchiveLocation
loc [Char]
fp Mismatch {Word32
mismatchActual :: Word32
mismatchExpected :: Word32
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-607]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"CRC32 mismatch in ZIP file from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" on internal file "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
fp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Word32
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Word32
mismatchActual
  display (UnknownHackagePackage PackageIdentifierRevision
pir FuzzyResults
fuzzy) =
    Utf8Builder
"Error: [S-476]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Could not find "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" on Hackage"
    forall a. Semigroup a => a -> a -> a
<> FuzzyResults -> Utf8Builder
displayFuzzy FuzzyResults
fuzzy
  display (CannotCompleteRepoNonSHA1 Repo
repo) =
    Utf8Builder
"Error: [S-112]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Cannot complete repo information for a non SHA1 commit due to non-reproducibility: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Repo
repo
  display (MutablePackageLocationFromUrl Text
t) =
    Utf8Builder
"Error: [S-321]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Cannot refer to a mutable package location from a URL: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (MismatchedCabalFileForHackage PackageIdentifierRevision
pir Mismatch{PackageIdentifier
mismatchActual :: PackageIdentifier
mismatchExpected :: PackageIdentifier
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-377]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"When processing cabal file for Hackage package "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\nMismatched package identifier."
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
mismatchExpected)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
mismatchActual)
  display (PackageNameParseFail Text
t) =
    Utf8Builder
"Error: [S-580]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid package name: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (PackageVersionParseFail Text
t) =
    Utf8Builder
"Error: [S-479]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid version: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (InvalidCabalFilePath Path Abs File
fp) =
    Utf8Builder
"Error: [S-824]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"File path contains a name which is not a valid package name: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
  display (DuplicatePackageNames Utf8Builder
source [(PackageName, [RawPackageLocationImmutable])]
pairs') =
    Utf8Builder
"Error: [S-674]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Duplicate package names ("
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
source
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"):\n"
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PackageName
name, [RawPackageLocationImmutable]
locs) ->
                forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
             forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\n"
             forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\RawPackageLocationImmutable
loc -> Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n") [RawPackageLocationImmutable]
locs
         )
         [(PackageName, [RawPackageLocationImmutable])]
pairs'
  display (MigrationFailure Text
desc Path Abs File
fp SomeException
err) =
    Utf8Builder
"Error: [S-536]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Encountered error while migrating database "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
desc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nlocated at "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n    "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
  display (ParseSnapNameException Text
t) =
    Utf8Builder
"Error: [S-994]\n"
     forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid snapshot name: "
     forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (HpackLibraryException Path Abs File
file [Char]
err) =
    Utf8Builder
"Error: [S-305]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Failed to generate a Cabal file using the Hpack library on file:\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
file)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The error encountered was:\n\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
err
  display (HpackExeException [Char]
fp Path Abs Dir
dir SomeException
err) =
    Utf8Builder
"Error: [S-720]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Failed to generate a Cabal file using the Hpack executable:\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
fp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"in directory: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The error encountered was:\n\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show SomeException
err)

-- See also the instance of Display. Although prettier, these messages are

-- intended to be substantively the same as the corresponding 'black and white'

-- versions.

instance Pretty PantryException where
  pretty :: PantryException -> StyleDoc
pretty PantryException
NoCasaConfig =
    StyleDoc
"[S-889]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"The Pantry configuration has no Casa configuration."
  pretty (InvalidTreeFromCasa BlobKey
blobKey ByteString
_bs) =
    StyleDoc
"[S-258]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid tree from casa:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay BlobKey
blobKey
         ]
  pretty (PackageIdentifierRevisionParseFail Text
text) =
    StyleDoc
"[S-360]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid package identifier (with optional revision):"
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
text
         ]
  pretty (InvalidCabalFile Either RawPackageLocationImmutable (Path Abs File)
loc Maybe Version
mversion [PError]
errs [PWarning]
warnings) =
    StyleDoc
"[S-242]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Unable to parse Cabal file from package"
         , forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> StyleDoc
pretty forall a. Pretty a => a -> StyleDoc
pretty Either RawPackageLocationImmutable (Path Abs File)
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
         ( forall a b. (a -> b) -> [a] -> [b]
map (\(PError Position
pos [Char]
msg) -> [StyleDoc] -> StyleDoc
fillSep
             [ forall a. IsString a => [Char] -> a
fromString (Position -> [Char]
showPos Position
pos) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             , forall a. IsString a => [Char] -> a
fromString [Char]
msg
             ])
             [PError]
errs
         )
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
         ( forall a b. (a -> b) -> [a] -> [b]
map (\(PWarning PWarnType
_ Position
pos [Char]
msg) -> [StyleDoc] -> StyleDoc
fillSep
             [ forall a. IsString a => [Char] -> a
fromString (Position -> [Char]
showPos Position
pos) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             , forall a. IsString a => [Char] -> a
fromString [Char]
msg
             ])
             [PWarning]
warnings
         )
    forall a. Semigroup a => a -> a -> a
<> ( case Maybe Version
mversion of
           Just Version
version | Version
version forall a. Ord a => a -> a -> Bool
> Version
cabalSpecLatestVersion ->
                StyleDoc
line
             forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                  [ [Char] -> StyleDoc
flow [Char]
"The Cabal file uses the Cabal specification version"
                  , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
version) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
                  , [Char] -> StyleDoc
flow [Char]
"but we only support up to version"
                  , forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalSpecLatestVersion) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  , [Char] -> StyleDoc
flow [Char]
"Recommended action: upgrade your build tool"
                  , StyleDoc -> StyleDoc
parens ([StyleDoc] -> StyleDoc
fillSep
                      [ StyleDoc
"e.g."
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
flow [Char]
"stack upgrade")
                      ]) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
           Maybe Version
_ -> forall a. Monoid a => a
mempty
       )
  pretty (TreeWithoutCabalFile RawPackageLocationImmutable
loc) =
    StyleDoc
"[S-654]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"No Cabal file found for"
         , forall a. Pretty a => a -> StyleDoc
pretty RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (TreeWithMultipleCabalFiles RawPackageLocationImmutable
loc [SafeFilePath]
sfps) =
    StyleDoc
"[S-500]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         ( [Char] -> StyleDoc
flow [Char]
"Multiple Cabal files found for"
         forall a. a -> [a] -> [a]
: (forall a. Pretty a => a -> StyleDoc
pretty RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
         forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
File) Bool
False
             (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Text
textDisplay) [SafeFilePath]
sfps :: [StyleDoc])
         )
  pretty (MismatchedCabalName Path Abs File
fp PackageName
name) =
    StyleDoc
"[S-910]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"The Cabal file"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
         , [Char] -> StyleDoc
flow [Char]
"is not named after the package that it defines. Please rename"
         , [Char] -> StyleDoc
flow [Char]
"the file to"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name forall a. Semigroup a => a -> a -> a
<> [Char]
".cabal") forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"Hackage rejects packages where the first part of the Cabal"
         , [Char] -> StyleDoc
flow [Char]
"file name is not the package name."
         ]
  pretty (NoLocalPackageDirFound Path Abs Dir
dir) =
    StyleDoc
"[S-395]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Stack looks for packages in the directories configured in the"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"packages"
         , StyleDoc
"and"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps"
         , [Char] -> StyleDoc
flow [Char]
"fields defined in your"
         , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"stack.yaml" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"The current entry points to"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dir
         , [Char] -> StyleDoc
flow [Char]
"but no such directory could be found. If, alternatively, a"
         , [Char] -> StyleDoc
flow [Char]
"package in the package index was intended, its name and"
         , [Char] -> StyleDoc
flow [Char]
"version must be specified as an extra-dep."
         ]
  pretty (NoCabalFileFound Path Abs Dir
dir) =
    StyleDoc
"[S-636]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Stack looks for packages in the directories configured in the"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"packages"
         , StyleDoc
"and"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps"
         , [Char] -> StyleDoc
flow [Char]
"fields defined in your"
         , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"stack.yaml" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"The current entry points to"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dir
         , [Char] -> StyleDoc
flow [Char]
"but no Cabal file or"
         , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"package.yaml"
         , [Char] -> StyleDoc
flow [Char]
"could be found there."
         ]
  pretty (MultipleCabalFilesFound Path Abs Dir
dir [Path Abs File]
files) =
    StyleDoc
"[S-368]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         ( [Char] -> StyleDoc
flow [Char]
"Multiple Cabal files found in directory"
         forall a. a -> [a] -> [a]
: (forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dir forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
         forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
File) Bool
False
             (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> StyleDoc
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files)
         )
  pretty (InvalidWantedCompiler Text
t) =
    StyleDoc
"[S-204]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid wanted compiler:"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (InvalidSnapshotLocation Path Abs Dir
dir Text
t) =
    StyleDoc
"[S-935]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid snapshot location"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t)
         , [Char] -> StyleDoc
flow [Char]
"relative to directory"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dir forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (InvalidOverrideCompiler WantedCompiler
x WantedCompiler
y) =
    StyleDoc
"[S-287]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Specified compiler for a resolver"
         , StyleDoc -> StyleDoc
parens (Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay WantedCompiler
x))
         , [Char] -> StyleDoc
flow [Char]
"but also specified an override compiler"
         , StyleDoc -> StyleDoc
parens (Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay WantedCompiler
y)) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (InvalidFilePathSnapshot Text
t) =
    StyleDoc
"[S-617]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Specified snapshot as file path with"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , [Char] -> StyleDoc
flow [Char]
"but not reading from a local file."
         ]
  pretty (InvalidSnapshot RawSnapshotLocation
loc SomeException
err) =
    StyleDoc
"[S-775]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Exception while reading snapshot from"
         , forall a. Pretty a => a -> StyleDoc
pretty RawSnapshotLocation
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (forall e. Exception e => e -> [Char]
displayException SomeException
err)
  pretty (MismatchedPackageMetadata RawPackageLocationImmutable
loc RawPackageMetadata
pm Maybe TreeKey
mtreeKey PackageIdentifier
foundIdent) =
    StyleDoc
"[S-427]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Mismatched package metadata for"
         , forall a. Pretty a => a -> StyleDoc
pretty RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , let t :: Text
t = forall a. Display a => a -> Text
textDisplay RawPackageMetadata
pm
           in  if Text -> Bool
T.null Text
t
                 then StyleDoc
"nothing."
                 else forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. Semigroup a => a -> a -> a
<> [Char]
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Found:   "
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
foundIdent forall a. Semigroup a => a -> a -> a
<> case Maybe TreeKey
mtreeKey of
             Maybe TreeKey
Nothing -> [Char]
"."
             Maybe TreeKey
_ -> forall a. Monoid a => a
mempty
         , case Maybe TreeKey
mtreeKey of
             Maybe TreeKey
Nothing -> forall a. Monoid a => a
mempty
             Just TreeKey
treeKey -> [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"with tree"
               , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay TreeKey
treeKey forall a. Semigroup a => a -> a -> a
<> Text
"."
               ]
         ])
  pretty (Non200ResponseStatus Status
status) =
    StyleDoc
"[S-571]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Unexpected non-200 HTTP status code:"
         , (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode Status
status) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (InvalidBlobKey Mismatch{BlobKey
mismatchActual :: BlobKey
mismatchExpected :: BlobKey
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-236]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid blob key found, expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay BlobKey
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
","
         , StyleDoc
"actual:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay BlobKey
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ]
  pretty (Couldn'tParseSnapshot RawSnapshotLocation
sl [Char]
err) =
    StyleDoc
"[S-645]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Couldn't parse snapshot from"
         , forall a. Pretty a => a -> StyleDoc
pretty RawSnapshotLocation
sl forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string [Char]
err
  pretty (WrongCabalFileName RawPackageLocationImmutable
loc SafeFilePath
sfp PackageName
name) =
    StyleDoc
"[S-575]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Wrong Cabal file name for package"
         , forall a. Pretty a => a -> StyleDoc
pretty RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"The Cabal file is named"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SafeFilePath
sfp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , [Char] -> StyleDoc
flow [Char]
"but package name is"
         , forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"For more information, see"
         , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/317"
         , StyleDoc
"and"
         , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/895" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (DownloadInvalidSHA256 Text
url Mismatch {SHA256
mismatchActual :: SHA256
mismatchExpected :: SHA256
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-394]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Mismatched SHA256 hash from"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SHA256
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Actual:  "
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SHA256
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
  pretty (DownloadInvalidSize Text
url Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-401]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Mismatched download size from"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay FileSize
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Actual:  "
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay FileSize
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
  pretty (DownloadTooLarge Text
url Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-113]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Download from"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url)
         , [Char] -> StyleDoc
flow [Char]
"was too large. Expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay FileSize
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
","
         , [Char] -> StyleDoc
flow [Char]
"stopped after receiving:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay FileSize
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ]
  pretty (LocalInvalidSHA256 Path Abs File
path Mismatch {SHA256
mismatchActual :: SHA256
mismatchExpected :: SHA256
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-834]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Mismatched SHA256 hash from"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
path forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SHA256
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Actual:  "
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SHA256
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
  pretty (LocalInvalidSize Path Abs File
path Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-713]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Mismatched file size from"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
path forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay FileSize
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Actual:  "
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay FileSize
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
  pretty (UnknownArchiveType ArchiveLocation
loc) =
    StyleDoc
"[S-372]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Unable to determine archive type of:"
         , forall a. Pretty a => a -> StyleDoc
pretty ArchiveLocation
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (InvalidTarFileType ArchiveLocation
loc [Char]
fp FileType
x) =
    StyleDoc
"[S-950]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Unsupported tar file type in archive"
         , forall a. Pretty a => a -> StyleDoc
pretty ArchiveLocation
loc
         , [Char] -> StyleDoc
flow [Char]
"at file"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString [Char]
fp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show FileType
x forall a. Semigroup a => a -> a -> a
<> [Char]
"."
         ]
  pretty (UnsupportedTarball ArchiveLocation
loc Text
err) =
    StyleDoc
"[S-760]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Unsupported tarball from"
         , forall a. Pretty a => a -> StyleDoc
pretty ArchiveLocation
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (Text -> [Char]
T.unpack Text
err)
  pretty (NoHackageCryptographicHash PackageIdentifier
ident) =
    StyleDoc
"[S-922]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"No cryptographic hash found for Hackage package"
         , forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (FailedToCloneRepo SimpleRepo
repo) =
    StyleDoc
"[S-109]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Failed to clone repository"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SimpleRepo
repo
         ]
  pretty (TreeReferencesMissingBlob RawPackageLocationImmutable
loc SafeFilePath
sfp BlobKey
key) =
    StyleDoc
"[S-237]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"The package"
         , forall a. Pretty a => a -> StyleDoc
pretty RawPackageLocationImmutable
loc
         , [Char] -> StyleDoc
flow [Char]
"needs blob"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay BlobKey
key
         , [Char] -> StyleDoc
flow [Char]
"for file path"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SafeFilePath
sfp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , [Char] -> StyleDoc
flow [Char]
"but the blob is not available."
         ]
  pretty (CompletePackageMetadataMismatch RawPackageLocationImmutable
loc PackageMetadata
pm) =
    StyleDoc
"[S-984]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"When completing package metadata for"
         , forall a. Pretty a => a -> StyleDoc
pretty RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , [Char] -> StyleDoc
flow [Char]
"some values changed in the new package metadata:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageMetadata
pm forall a. Semigroup a => a -> a -> a
<> Text
"."
         ]
  pretty (CRC32Mismatch ArchiveLocation
loc [Char]
fp Mismatch {Word32
mismatchActual :: Word32
mismatchExpected :: Word32
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-607]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"CRC32 mismatch in Zip file from"
         , forall a. Pretty a => a -> StyleDoc
pretty ArchiveLocation
loc
         , [Char] -> StyleDoc
flow [Char]
"on internal file"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString [Char]
fp)
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay Word32
mismatchExpected forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Actual:  "
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay Word32
mismatchActual forall a. Semigroup a => a -> a -> a
<> Text
"."
         ])
  pretty (UnknownHackagePackage PackageIdentifierRevision
pir FuzzyResults
fuzzy) =
    StyleDoc
"[S-476]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Could not find"
         , Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageIdentifierRevision
pir)
         , [Char] -> StyleDoc
flow [Char]
"on Hackage."
         ]
    forall a. Semigroup a => a -> a -> a
<> FuzzyResults -> StyleDoc
prettyFuzzy FuzzyResults
fuzzy
  pretty (CannotCompleteRepoNonSHA1 Repo
repo) =
    StyleDoc
"[S-112]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Cannot complete repo information for a non SHA1 commit due to"
         , StyleDoc
"non-reproducibility:"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay Repo
repo forall a. Semigroup a => a -> a -> a
<> Text
"."
         ]
  pretty (MutablePackageLocationFromUrl Text
t) =
    StyleDoc
"[S-321]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Cannot refer to a mutable package location from a URL:"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (MismatchedCabalFileForHackage PackageIdentifierRevision
pir Mismatch{PackageIdentifier
mismatchActual :: PackageIdentifier
mismatchExpected :: PackageIdentifier
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    StyleDoc
"[S-377]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"When processing Cabal file for Hackage package"
         , forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageIdentifierRevision
pir forall a. Semigroup a => a -> a -> a
<> Text
","
         , [Char] -> StyleDoc
flow [Char]
"mismatched package identifier."
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Expected:"
         , forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
mismatchExpected) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ])
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
hang Int
10 ([StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Actual:  "
         , forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
mismatchActual) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ])
  pretty (PackageNameParseFail Text
t) =
    StyleDoc
"[S-580]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid package name:"
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. Semigroup a => a -> a -> a
<> [Char]
"."
         ]
  pretty (PackageVersionParseFail Text
t) =
    StyleDoc
"[S-479]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid version:"
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. Semigroup a => a -> a -> a
<> [Char]
"."
         ]
  pretty (InvalidCabalFilePath Path Abs File
fp) =
    StyleDoc
"[S-824]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"File path contains a name which is not a valid package name:"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (DuplicatePackageNames Utf8Builder
source [(PackageName, [RawPackageLocationImmutable])]
pairs') =
    StyleDoc
"[S-674]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Duplicate package names"
         , StyleDoc -> StyleDoc
parens (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay Utf8Builder
source) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PackageName
name, [RawPackageLocationImmutable]
locs) ->
                forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
             forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> StyleDoc
pretty [RawPackageLocationImmutable]
locs)
             forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
         )
         [(PackageName, [RawPackageLocationImmutable])]
pairs'
  pretty (MigrationFailure Text
desc Path Abs File
fp SomeException
err) =
    StyleDoc
"[S-536]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Encountered error while migrating database"
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
desc
         , [Char] -> StyleDoc
flow [Char]
"located at"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (forall e. Exception e => e -> [Char]
displayException SomeException
err)
  pretty (ParseSnapNameException Text
t) =
    StyleDoc
"[S-994]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Invalid snapshot name:"
         , forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. Semigroup a => a -> a -> a
<> [Char]
"."
         ]
  pretty (HpackLibraryException Path Abs File
file [Char]
err) =
    StyleDoc
"[S-305]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Failed to generate a Cabal file using the Hpack library on"
         , StyleDoc
"file:"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
file forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"The error encountered was:"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string [Char]
err
  pretty (HpackExeException [Char]
fp Path Abs Dir
dir SomeException
err) =
    StyleDoc
"[S-720]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Failed to generate a Cabal file using the Hpack executable:"
         , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString [Char]
fp)
         , [Char] -> StyleDoc
flow [Char]
"in directory:"
         , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dir forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         , [Char] -> StyleDoc
flow [Char]
"The error encountered was:"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (forall e. Exception e => e -> [Char]
displayException SomeException
err)

blankLine :: StyleDoc
blankLine :: StyleDoc
blankLine = StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

data FuzzyResults
  = FRNameNotFound ![PackageName]
  | FRVersionNotFound !(NonEmpty PackageIdentifierRevision)
  | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision)

displayFuzzy :: FuzzyResults -> Utf8Builder
displayFuzzy :: FuzzyResults -> Utf8Builder
displayFuzzy (FRNameNotFound [PackageName]
names) =
  case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageName]
names of
    Maybe (NonEmpty PackageName)
Nothing -> Utf8Builder
""
    Just NonEmpty PackageName
names' ->
      Utf8Builder
"\nPerhaps you meant " forall a. Semigroup a => a -> a -> a
<>
      NonEmpty Utf8Builder -> Utf8Builder
orSeparated (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) NonEmpty PackageName
names') forall a. Semigroup a => a -> a -> a
<>
      Utf8Builder
"?"
displayFuzzy (FRVersionNotFound NonEmpty PackageIdentifierRevision
pirs) =
  Utf8Builder
"\nPossible candidates: " forall a. Semigroup a => a -> a -> a
<>
  NonEmpty Utf8Builder -> Utf8Builder
commaSeparated (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a. Display a => a -> Utf8Builder
display NonEmpty PackageIdentifierRevision
pirs) forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"."
displayFuzzy (FRRevisionNotFound NonEmpty PackageIdentifierRevision
pirs) =
  Utf8Builder
"\nThe specified revision was not found.\nPossible candidates: " forall a. Semigroup a => a -> a -> a
<>
  NonEmpty Utf8Builder -> Utf8Builder
commaSeparated (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a. Display a => a -> Utf8Builder
display NonEmpty PackageIdentifierRevision
pirs) forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"."

prettyFuzzy :: FuzzyResults -> StyleDoc
prettyFuzzy :: FuzzyResults -> StyleDoc
prettyFuzzy (FRNameNotFound [PackageName]
names) =
  case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageName]
names of
    Maybe (NonEmpty PackageName)
Nothing -> forall a. Monoid a => a
mempty
    Just NonEmpty PackageName
names' ->
         StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
           ( [Char] -> StyleDoc
flow [Char]
"Perhaps you meant one of"
           forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList forall a. Maybe a
Nothing Bool
False
               (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) NonEmpty PackageName
names' :: [StyleDoc])
           )
prettyFuzzy (FRVersionNotFound NonEmpty PackageIdentifierRevision
pirs) =
     StyleDoc
line
  forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
       ( [Char] -> StyleDoc
flow [Char]
"Possible candidates:"
       forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList forall a. Maybe a
Nothing Bool
False
           (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Text
textDisplay) NonEmpty PackageIdentifierRevision
pirs :: [StyleDoc])
       )
prettyFuzzy (FRRevisionNotFound NonEmpty PackageIdentifierRevision
pirs) =
     StyleDoc
line
  forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
       ( [Char] -> StyleDoc
flow [Char]
"The specified revision was not found. Possible candidates:"
       forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList forall a. Maybe a
Nothing Bool
False
           (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Text
textDisplay) NonEmpty PackageIdentifierRevision
pirs :: [StyleDoc])
       )

orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
orSeparated NonEmpty Utf8Builder
xs
  | forall a. NonEmpty a -> Int
NE.length NonEmpty Utf8Builder
xs forall a. Eq a => a -> a -> Bool
== Int
1 = forall a. NonEmpty a -> a
NE.head NonEmpty Utf8Builder
xs
  | forall a. NonEmpty a -> Int
NE.length NonEmpty Utf8Builder
xs forall a. Eq a => a -> a -> Bool
== Int
2 = forall a. NonEmpty a -> a
NE.head NonEmpty Utf8Builder
xs forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" or " forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> a
NE.last NonEmpty Utf8Builder
xs
  | Bool
otherwise = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a. NonEmpty a -> [a]
NE.init NonEmpty Utf8Builder
xs)) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", or " forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> a
NE.last NonEmpty Utf8Builder
xs

commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder
commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder
commaSeparated = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse Utf8Builder
", "

cabalSpecLatestVersion :: Version
cabalSpecLatestVersion :: Version
cabalSpecLatestVersion = [Int] -> Version
mkVersion forall a b. (a -> b) -> a -> b
$ CabalSpecVersion -> [Int]
cabalSpecToVersionDigits CabalSpecVersion
cabalSpecLatest

#if !MIN_VERSION_Cabal(3,4,0)
cabalSpecToVersionDigits :: CabalSpecVersion -> [Int]
cabalSpecToVersionDigits CabalSpecV3_0   = [3,0]
cabalSpecToVersionDigits CabalSpecV2_4   = [2,4]
cabalSpecToVersionDigits CabalSpecV2_2   = [2,2]
cabalSpecToVersionDigits CabalSpecV2_0   = [2,0]
cabalSpecToVersionDigits CabalSpecV1_24  = [1,24]
cabalSpecToVersionDigits CabalSpecV1_22  = [1,22]
cabalSpecToVersionDigits CabalSpecV1_20  = [1,20]
cabalSpecToVersionDigits CabalSpecV1_18  = [1,18]
cabalSpecToVersionDigits CabalSpecV1_12  = [1,12]
cabalSpecToVersionDigits CabalSpecV1_10  = [1,10]
cabalSpecToVersionDigits CabalSpecV1_8   = [1,8]
cabalSpecToVersionDigits CabalSpecV1_6   = [1,6]
cabalSpecToVersionDigits CabalSpecV1_4   = [1,4]
cabalSpecToVersionDigits CabalSpecV1_2   = [1,2]
cabalSpecToVersionDigits CabalSpecV1_0   = [1,0]
#endif

data BuildFile
  = BFCabal !SafeFilePath !TreeEntry
  | BFHpack !TreeEntry
    -- We don't need SafeFilePath for Hpack since it has to be package.yaml file

  deriving (Int -> BuildFile -> ShowS
[BuildFile] -> ShowS
BuildFile -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BuildFile] -> ShowS
$cshowList :: [BuildFile] -> ShowS
show :: BuildFile -> [Char]
$cshow :: BuildFile -> [Char]
showsPrec :: Int -> BuildFile -> ShowS
$cshowsPrec :: Int -> BuildFile -> ShowS
Show, BuildFile -> BuildFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildFile -> BuildFile -> Bool
$c/= :: BuildFile -> BuildFile -> Bool
== :: BuildFile -> BuildFile -> Bool
$c== :: BuildFile -> BuildFile -> Bool
Eq)

data FileType = FTNormal | FTExecutable
  deriving (Int -> FileType -> ShowS
[FileType] -> ShowS
FileType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FileType] -> ShowS
$cshowList :: [FileType] -> ShowS
show :: FileType -> [Char]
$cshow :: FileType -> [Char]
showsPrec :: Int -> FileType -> ShowS
$cshowsPrec :: Int -> FileType -> ShowS
Show, FileType -> FileType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileType -> FileType -> Bool
$c/= :: FileType -> FileType -> Bool
== :: FileType -> FileType -> Bool
$c== :: FileType -> FileType -> Bool
Eq, Int -> FileType
FileType -> Int
FileType -> [FileType]
FileType -> FileType
FileType -> FileType -> [FileType]
FileType -> FileType -> FileType -> [FileType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: FileType -> FileType -> FileType -> [FileType]
$cenumFromThenTo :: FileType -> FileType -> FileType -> [FileType]
enumFromTo :: FileType -> FileType -> [FileType]
$cenumFromTo :: FileType -> FileType -> [FileType]
enumFromThen :: FileType -> FileType -> [FileType]
$cenumFromThen :: FileType -> FileType -> [FileType]
enumFrom :: FileType -> [FileType]
$cenumFrom :: FileType -> [FileType]
fromEnum :: FileType -> Int
$cfromEnum :: FileType -> Int
toEnum :: Int -> FileType
$ctoEnum :: Int -> FileType
pred :: FileType -> FileType
$cpred :: FileType -> FileType
succ :: FileType -> FileType
$csucc :: FileType -> FileType
Enum, FileType
forall a. a -> a -> Bounded a
maxBound :: FileType
$cmaxBound :: FileType
minBound :: FileType
$cminBound :: FileType
Bounded, Eq FileType
FileType -> FileType -> Bool
FileType -> FileType -> Ordering
FileType -> FileType -> FileType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileType -> FileType -> FileType
$cmin :: FileType -> FileType -> FileType
max :: FileType -> FileType -> FileType
$cmax :: FileType -> FileType -> FileType
>= :: FileType -> FileType -> Bool
$c>= :: FileType -> FileType -> Bool
> :: FileType -> FileType -> Bool
$c> :: FileType -> FileType -> Bool
<= :: FileType -> FileType -> Bool
$c<= :: FileType -> FileType -> Bool
< :: FileType -> FileType -> Bool
$c< :: FileType -> FileType -> Bool
compare :: FileType -> FileType -> Ordering
$ccompare :: FileType -> FileType -> Ordering
Ord)

instance PersistField FileType where
  toPersistValue :: FileType -> PersistValue
toPersistValue FileType
FTNormal = Int64 -> PersistValue
PersistInt64 Int64
1
  toPersistValue FileType
FTExecutable = Int64 -> PersistValue
PersistInt64 Int64
2

  fromPersistValue :: PersistValue -> Either Text FileType
fromPersistValue PersistValue
v = do
    Int64
i <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case Int64
i :: Int64 of
      Int64
1 -> forall a b. b -> Either a b
Right FileType
FTNormal
      Int64
2 -> forall a b. b -> Either a b
Right FileType
FTExecutable
      Int64
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid FileType: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int64
i

instance PersistFieldSql FileType where
  sqlType :: Proxy FileType -> SqlType
sqlType Proxy FileType
_ = SqlType
SqlInt32

data TreeEntry = TreeEntry
  { TreeEntry -> BlobKey
teBlob :: !BlobKey
  , TreeEntry -> FileType
teType :: !FileType
  }
  deriving (Int -> TreeEntry -> ShowS
[TreeEntry] -> ShowS
TreeEntry -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TreeEntry] -> ShowS
$cshowList :: [TreeEntry] -> ShowS
show :: TreeEntry -> [Char]
$cshow :: TreeEntry -> [Char]
showsPrec :: Int -> TreeEntry -> ShowS
$cshowsPrec :: Int -> TreeEntry -> ShowS
Show, TreeEntry -> TreeEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeEntry -> TreeEntry -> Bool
$c/= :: TreeEntry -> TreeEntry -> Bool
== :: TreeEntry -> TreeEntry -> Bool
$c== :: TreeEntry -> TreeEntry -> Bool
Eq, Eq TreeEntry
TreeEntry -> TreeEntry -> Bool
TreeEntry -> TreeEntry -> Ordering
TreeEntry -> TreeEntry -> TreeEntry
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TreeEntry -> TreeEntry -> TreeEntry
$cmin :: TreeEntry -> TreeEntry -> TreeEntry
max :: TreeEntry -> TreeEntry -> TreeEntry
$cmax :: TreeEntry -> TreeEntry -> TreeEntry
>= :: TreeEntry -> TreeEntry -> Bool
$c>= :: TreeEntry -> TreeEntry -> Bool
> :: TreeEntry -> TreeEntry -> Bool
$c> :: TreeEntry -> TreeEntry -> Bool
<= :: TreeEntry -> TreeEntry -> Bool
$c<= :: TreeEntry -> TreeEntry -> Bool
< :: TreeEntry -> TreeEntry -> Bool
$c< :: TreeEntry -> TreeEntry -> Bool
compare :: TreeEntry -> TreeEntry -> Ordering
$ccompare :: TreeEntry -> TreeEntry -> Ordering
Ord)

newtype SafeFilePath = SafeFilePath Text
  deriving (Int -> SafeFilePath -> ShowS
[SafeFilePath] -> ShowS
SafeFilePath -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SafeFilePath] -> ShowS
$cshowList :: [SafeFilePath] -> ShowS
show :: SafeFilePath -> [Char]
$cshow :: SafeFilePath -> [Char]
showsPrec :: Int -> SafeFilePath -> ShowS
$cshowsPrec :: Int -> SafeFilePath -> ShowS
Show, SafeFilePath -> SafeFilePath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SafeFilePath -> SafeFilePath -> Bool
$c/= :: SafeFilePath -> SafeFilePath -> Bool
== :: SafeFilePath -> SafeFilePath -> Bool
$c== :: SafeFilePath -> SafeFilePath -> Bool
Eq, Eq SafeFilePath
SafeFilePath -> SafeFilePath -> Bool
SafeFilePath -> SafeFilePath -> Ordering
SafeFilePath -> SafeFilePath -> SafeFilePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SafeFilePath -> SafeFilePath -> SafeFilePath
$cmin :: SafeFilePath -> SafeFilePath -> SafeFilePath
max :: SafeFilePath -> SafeFilePath -> SafeFilePath
$cmax :: SafeFilePath -> SafeFilePath -> SafeFilePath
>= :: SafeFilePath -> SafeFilePath -> Bool
$c>= :: SafeFilePath -> SafeFilePath -> Bool
> :: SafeFilePath -> SafeFilePath -> Bool
$c> :: SafeFilePath -> SafeFilePath -> Bool
<= :: SafeFilePath -> SafeFilePath -> Bool
$c<= :: SafeFilePath -> SafeFilePath -> Bool
< :: SafeFilePath -> SafeFilePath -> Bool
$c< :: SafeFilePath -> SafeFilePath -> Bool
compare :: SafeFilePath -> SafeFilePath -> Ordering
$ccompare :: SafeFilePath -> SafeFilePath -> Ordering
Ord, SafeFilePath -> Text
SafeFilePath -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: SafeFilePath -> Text
$ctextDisplay :: SafeFilePath -> Text
display :: SafeFilePath -> Utf8Builder
$cdisplay :: SafeFilePath -> Utf8Builder
Display)

instance PersistField SafeFilePath where
  toPersistValue :: SafeFilePath -> PersistValue
toPersistValue = forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeFilePath -> Text
unSafeFilePath
  fromPersistValue :: PersistValue -> Either Text SafeFilePath
fromPersistValue PersistValue
v = do
    Text
t <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid SafeFilePath: " forall a. Semigroup a => a -> a -> a
<> Text
t) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Maybe SafeFilePath
mkSafeFilePath Text
t

instance PersistFieldSql SafeFilePath where
  sqlType :: Proxy SafeFilePath -> SqlType
sqlType Proxy SafeFilePath
_ = SqlType
SqlString

unSafeFilePath :: SafeFilePath -> Text
unSafeFilePath :: SafeFilePath -> Text
unSafeFilePath (SafeFilePath Text
t) = Text
t

safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File)
safeFilePathToPath :: forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> SafeFilePath -> m (Path Abs File)
safeFilePathToPath Path Abs Dir
dir (SafeFilePath Text
path) = do
  Path Rel File
fpath <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile (Text -> [Char]
T.unpack Text
path)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fpath

mkSafeFilePath :: Text -> Maybe SafeFilePath
mkSafeFilePath :: Text -> Maybe SafeFilePath
mkSafeFilePath Text
t = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"\\" Text -> Text -> Bool
`T.isInfixOf` Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"//" Text -> Text -> Bool
`T.isInfixOf` Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"\n" Text -> Text -> Bool
`T.isInfixOf` Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"\0" Text -> Text -> Bool
`T.isInfixOf` Text
t

  (Char
c, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Char
c forall a. Eq a => a -> a -> Bool
/= Char
'/'

  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Char -> Bool) -> Text -> Bool
T.all (forall a. Eq a => a -> a -> Bool
== Char
'.'))) forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
t

  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> SafeFilePath
SafeFilePath Text
t

-- | SafeFilePath for `package.yaml` file.

hpackSafeFilePath :: SafeFilePath
hpackSafeFilePath :: SafeFilePath
hpackSafeFilePath =
    let fpath :: Maybe SafeFilePath
fpath = Text -> Maybe SafeFilePath
mkSafeFilePath ([Char] -> Text
T.pack [Char]
Hpack.packageConfig)
    in case Maybe SafeFilePath
fpath of
         Maybe SafeFilePath
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
           [Char]
"hpackSafeFilePath: Not able to encode " forall a. Semigroup a => a -> a -> a
<> [Char]
Hpack.packageConfig
         Just SafeFilePath
sfp -> SafeFilePath
sfp

-- | The hash of the binary representation of a 'Tree'.

--

-- @since 0.1.0.0

newtype TreeKey = TreeKey BlobKey
  deriving (Int -> TreeKey -> ShowS
[TreeKey] -> ShowS
TreeKey -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TreeKey] -> ShowS
$cshowList :: [TreeKey] -> ShowS
show :: TreeKey -> [Char]
$cshow :: TreeKey -> [Char]
showsPrec :: Int -> TreeKey -> ShowS
$cshowsPrec :: Int -> TreeKey -> ShowS
Show, TreeKey -> TreeKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeKey -> TreeKey -> Bool
$c/= :: TreeKey -> TreeKey -> Bool
== :: TreeKey -> TreeKey -> Bool
$c== :: TreeKey -> TreeKey -> Bool
Eq, Eq TreeKey
TreeKey -> TreeKey -> Bool
TreeKey -> TreeKey -> Ordering
TreeKey -> TreeKey -> TreeKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TreeKey -> TreeKey -> TreeKey
$cmin :: TreeKey -> TreeKey -> TreeKey
max :: TreeKey -> TreeKey -> TreeKey
$cmax :: TreeKey -> TreeKey -> TreeKey
>= :: TreeKey -> TreeKey -> Bool
$c>= :: TreeKey -> TreeKey -> Bool
> :: TreeKey -> TreeKey -> Bool
$c> :: TreeKey -> TreeKey -> Bool
<= :: TreeKey -> TreeKey -> Bool
$c<= :: TreeKey -> TreeKey -> Bool
< :: TreeKey -> TreeKey -> Bool
$c< :: TreeKey -> TreeKey -> Bool
compare :: TreeKey -> TreeKey -> Ordering
$ccompare :: TreeKey -> TreeKey -> Ordering
Ord, forall x. Rep TreeKey x -> TreeKey
forall x. TreeKey -> Rep TreeKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TreeKey x -> TreeKey
$cfrom :: forall x. TreeKey -> Rep TreeKey x
Generic, Typeable, [TreeKey] -> Encoding
[TreeKey] -> Value
TreeKey -> Encoding
TreeKey -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TreeKey] -> Encoding
$ctoEncodingList :: [TreeKey] -> Encoding
toJSONList :: [TreeKey] -> Value
$ctoJSONList :: [TreeKey] -> Value
toEncoding :: TreeKey -> Encoding
$ctoEncoding :: TreeKey -> Encoding
toJSON :: TreeKey -> Value
$ctoJSON :: TreeKey -> Value
ToJSON, Value -> Parser [TreeKey]
Value -> Parser TreeKey
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TreeKey]
$cparseJSONList :: Value -> Parser [TreeKey]
parseJSON :: Value -> Parser TreeKey
$cparseJSON :: Value -> Parser TreeKey
FromJSON, TreeKey -> ()
forall a. (a -> ()) -> NFData a
rnf :: TreeKey -> ()
$crnf :: TreeKey -> ()
NFData, TreeKey -> Text
TreeKey -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: TreeKey -> Text
$ctextDisplay :: TreeKey -> Text
display :: TreeKey -> Utf8Builder
$cdisplay :: TreeKey -> Utf8Builder
Display)

-- | Represents the contents of a tree, which is a mapping from

-- relative file paths to 'TreeEntry's.

--

-- @since 0.1.0.0

newtype Tree
  = TreeMap (Map SafeFilePath TreeEntry)
  -- In the future, consider allowing more lax parsing

  -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys

  -- TreeTarball !PackageTarball

  deriving (Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Tree] -> ShowS
$cshowList :: [Tree] -> ShowS
show :: Tree -> [Char]
$cshow :: Tree -> [Char]
showsPrec :: Int -> Tree -> ShowS
$cshowsPrec :: Int -> Tree -> ShowS
Show, Tree -> Tree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c== :: Tree -> Tree -> Bool
Eq, Eq Tree
Tree -> Tree -> Bool
Tree -> Tree -> Ordering
Tree -> Tree -> Tree
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tree -> Tree -> Tree
$cmin :: Tree -> Tree -> Tree
max :: Tree -> Tree -> Tree
$cmax :: Tree -> Tree -> Tree
>= :: Tree -> Tree -> Bool
$c>= :: Tree -> Tree -> Bool
> :: Tree -> Tree -> Bool
$c> :: Tree -> Tree -> Bool
<= :: Tree -> Tree -> Bool
$c<= :: Tree -> Tree -> Bool
< :: Tree -> Tree -> Bool
$c< :: Tree -> Tree -> Bool
compare :: Tree -> Tree -> Ordering
$ccompare :: Tree -> Tree -> Ordering
Ord)

renderTree :: Tree -> ByteString
renderTree :: Tree -> ByteString
renderTree = ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Builder
go
 where
  go :: Tree -> Builder
  go :: Tree -> Builder
go (TreeMap Map SafeFilePath TreeEntry
m) = Builder
"map:" forall a. Semigroup a => a -> a -> a
<> forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey SafeFilePath -> TreeEntry -> Builder
goEntry Map SafeFilePath TreeEntry
m

  goEntry :: SafeFilePath -> TreeEntry -> Builder
goEntry SafeFilePath
sfp (TreeEntry (BlobKey SHA256
sha (FileSize Word
size')) FileType
ft) =
    Text -> Builder
netstring (SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp) forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
byteString (SHA256 -> ByteString
SHA256.toRaw SHA256
sha) forall a. Semigroup a => a -> a -> a
<>
    Word -> Builder
netword Word
size' forall a. Semigroup a => a -> a -> a
<>
    (case FileType
ft of
      FileType
FTNormal -> Builder
"N"
      FileType
FTExecutable -> Builder
"X")

netstring :: Text -> Builder
netstring :: Text -> Builder
netstring Text
t =
  let bs :: ByteString
bs = Text -> ByteString
encodeUtf8 Text
t
  in  Word -> Builder
netword (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
bs

netword :: Word -> Builder
netword :: Word -> Builder
netword Word
w = Word -> Builder
wordDec Word
w forall a. Semigroup a => a -> a -> a
<> Builder
":"

parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM :: forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM (BlobKey
blobKey, ByteString
blob) =
  case ByteString -> Maybe Tree
parseTree ByteString
blob of
    Maybe Tree
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BlobKey -> ByteString -> PantryException
InvalidTreeFromCasa BlobKey
blobKey ByteString
blob)
    Just Tree
tree -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobKey -> TreeKey
TreeKey BlobKey
blobKey, Tree
tree)

parseTree :: ByteString -> Maybe Tree
parseTree :: ByteString -> Maybe Tree
parseTree ByteString
bs1 = do
  Tree
tree <- ByteString -> Maybe Tree
parseTree' ByteString
bs1
  let bs2 :: ByteString
bs2 = Tree -> ByteString
renderTree Tree
tree
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ByteString
bs1 forall a. Eq a => a -> a -> Bool
== ByteString
bs2
  forall a. a -> Maybe a
Just Tree
tree

parseTree' :: ByteString -> Maybe Tree
parseTree' :: ByteString -> Maybe Tree
parseTree' ByteString
bs0 = do
  ByteString
entriesBS <- ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"map:" ByteString
bs0
  Map SafeFilePath TreeEntry -> Tree
TreeMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map SafeFilePath TreeEntry
-> ByteString -> Maybe (Map SafeFilePath TreeEntry)
loop forall k a. Map k a
Map.empty ByteString
entriesBS
 where
  loop :: Map SafeFilePath TreeEntry
-> ByteString -> Maybe (Map SafeFilePath TreeEntry)
loop !Map SafeFilePath TreeEntry
m ByteString
bs1
    | ByteString -> Bool
B.null ByteString
bs1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Map SafeFilePath TreeEntry
m
    | Bool
otherwise = do
        (ByteString
sfpBS, ByteString
bs2) <- ByteString -> Maybe (ByteString, ByteString)
takeNetstring ByteString
bs1
        SafeFilePath
sfp <-
          case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
sfpBS of
            Left UnicodeException
_ -> forall a. Maybe a
Nothing
            Right Text
sfpT -> Text -> Maybe SafeFilePath
mkSafeFilePath Text
sfpT
        (SHA256
sha, ByteString
bs3) <- ByteString -> Maybe (SHA256, ByteString)
takeSha ByteString
bs2
        (Int
size', ByteString
bs4) <- ByteString -> Maybe (Int, ByteString)
takeNetword ByteString
bs3
        (Word8
typeW, ByteString
bs5) <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs4
        FileType
ft <-
          case Word8
typeW of
            Word8
78 -> forall a. a -> Maybe a
Just FileType
FTNormal -- 'N'

            Word8
88 -> forall a. a -> Maybe a
Just FileType
FTExecutable -- 'X'

            Word8
_ -> forall a. Maybe a
Nothing
        let entry :: TreeEntry
entry = BlobKey -> FileType -> TreeEntry
TreeEntry (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha (Word -> FileSize
FileSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size'))) FileType
ft
        Map SafeFilePath TreeEntry
-> ByteString -> Maybe (Map SafeFilePath TreeEntry)
loop (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SafeFilePath
sfp TreeEntry
entry Map SafeFilePath TreeEntry
m) ByteString
bs5

  takeNetstring :: ByteString -> Maybe (ByteString, ByteString)
takeNetstring ByteString
bs1 = do
    (Int
size', ByteString
bs2) <- ByteString -> Maybe (Int, ByteString)
takeNetword ByteString
bs1
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
bs2 forall a. Ord a => a -> a -> Bool
>= Int
size'
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
size' ByteString
bs2

  takeSha :: ByteString -> Maybe (SHA256, ByteString)
takeSha ByteString
bs = do
    let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
32 ByteString
bs
    SHA256
x' <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just (ByteString -> Either SHA256Exception SHA256
SHA256.fromRaw ByteString
x)
    forall a. a -> Maybe a
Just (SHA256
x', ByteString
y)

  takeNetword :: ByteString -> Maybe (Int, ByteString)
takeNetword =
    forall {t}. Num t => t -> ByteString -> Maybe (t, ByteString)
go Int
0
   where
    go :: t -> ByteString -> Maybe (t, ByteString)
go !t
accum ByteString
bs = do
      (Word8
next, ByteString
rest) <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs
      if
        | Word8
next forall a. Eq a => a -> a -> Bool
== Word8
58 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
accum, ByteString
rest) -- ':'

        | Word8
next forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
next forall a. Ord a => a -> a -> Bool
<= Word8
57 ->
            t -> ByteString -> Maybe (t, ByteString)
go
              (t
accum forall a. Num a => a -> a -> a
* t
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
next forall a. Num a => a -> a -> a
- Word8
48))
              ByteString
rest
        | Bool
otherwise -> forall a. Maybe a
Nothing

    {-
data PackageTarball = PackageTarball
  { ptBlob :: !BlobKey
  -- ^ Contains the tarball itself
  , ptCabal :: !BlobKey
  -- ^ Contains the cabal file contents
  , ptSubdir :: !FilePath
  -- ^ Subdir containing the files we want for this package.
  --
  -- There must be precisely one file with a @.cabal@ file extension
  -- located there. Thanks to Hackage revisions, its contents will be
  -- overwritten by the value of @ptCabal@.
  }
  deriving Show
    -}

-- | This is almost a copy of Cabal's parser for package identifiers,

-- the main difference is in the fact that Stack requires version to be

-- present while Cabal uses "null version" as a default value

--

-- @since 0.1.0.0

parsePackageIdentifier :: String -> Maybe PackageIdentifier
parsePackageIdentifier :: [Char] -> Maybe PackageIdentifier
parsePackageIdentifier = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParsecParser a -> [Char] -> Either [Char] a
explicitEitherParsec (ParsecParser PackageIdentifier
packageIdentifierParsec forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Parsing m => m ()
Parse.eof)

packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec = do
  ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
_ Version
v) <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec

  -- version is a required component of a package identifier for Stack

  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Version
v forall a. Eq a => a -> a -> Bool
/= Version
nullVersion)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
ident

-- | Parse a package name from a 'String'.

--

-- @since 0.1.0.0

parsePackageName :: String -> Maybe PackageName
parsePackageName :: [Char] -> Maybe PackageName
parsePackageName = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a package name from a 'String' throwing on failure

--

-- @since 0.1.0.0

parsePackageNameThrowing :: MonadThrow m => String -> m PackageName
parsePackageNameThrowing :: forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing [Char]
str =
  case [Char] -> Maybe PackageName
parsePackageName [Char]
str of
    Maybe PackageName
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageNameParseFail forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
str
    Just PackageName
pn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageName
pn

-- | Parse a version from a 'String'.

--

-- @since 0.1.0.0

parseVersion :: String -> Maybe Version
parseVersion :: [Char] -> Maybe Version
parseVersion = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a package version from a 'String' throwing on failure

--

-- @since 0.1.0.0

parseVersionThrowing :: MonadThrow m => String -> m Version
parseVersionThrowing :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing [Char]
str =
  case [Char] -> Maybe Version
parseVersion [Char]
str of
    Maybe Version
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageVersionParseFail forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
str
    Just Version
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
v

-- | Parse a version range from a 'String'.

--

-- @since 0.1.0.0

parseVersionRange :: String -> Maybe VersionRange
parseVersionRange :: [Char] -> Maybe VersionRange
parseVersionRange = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a module name from a 'String'.

--

-- @since 0.1.0.0

parseModuleName :: String -> Maybe ModuleName
parseModuleName :: [Char] -> Maybe ModuleName
parseModuleName = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a flag name from a 'String'.

--

-- @since 0.1.0.0

parseFlagName :: String -> Maybe FlagName
parseFlagName :: [Char] -> Maybe FlagName
parseFlagName = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Render a package name as a 'String'.

--

-- @since 0.1.0.0

packageNameString :: PackageName -> String
packageNameString :: PackageName -> [Char]
packageNameString = PackageName -> [Char]
unPackageName

-- | Render a package identifier as a 'String'.

--

-- @since 0.1.0.0

packageIdentifierString :: PackageIdentifier -> String
packageIdentifierString :: PackageIdentifier -> [Char]
packageIdentifierString = forall a. Pretty a => a -> [Char]
Distribution.Text.display

-- | Render a version as a 'String'.

--

-- @since 0.1.0.0

versionString :: Version -> String
versionString :: Version -> [Char]
versionString = forall a. Pretty a => a -> [Char]
Distribution.Text.display

-- | Render a flag name as a 'String'.

--

-- @since 0.1.0.0

flagNameString :: FlagName -> String
flagNameString :: FlagName -> [Char]
flagNameString = FlagName -> [Char]
unFlagName

-- | Render a module name as a 'String'.

--

-- @since 0.1.0.0

moduleNameString :: ModuleName -> String
moduleNameString :: ModuleName -> [Char]
moduleNameString = forall a. Pretty a => a -> [Char]
Distribution.Text.display

data OptionalSubdirs
  = OSSubdirs !(NonEmpty Text)
  | OSPackageMetadata !Text !RawPackageMetadata
  -- ^ subdirectory and package metadata

  deriving (Int -> OptionalSubdirs -> ShowS
[OptionalSubdirs] -> ShowS
OptionalSubdirs -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [OptionalSubdirs] -> ShowS
$cshowList :: [OptionalSubdirs] -> ShowS
show :: OptionalSubdirs -> [Char]
$cshow :: OptionalSubdirs -> [Char]
showsPrec :: Int -> OptionalSubdirs -> ShowS
$cshowsPrec :: Int -> OptionalSubdirs -> ShowS
Show, OptionalSubdirs -> OptionalSubdirs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OptionalSubdirs -> OptionalSubdirs -> Bool
$c/= :: OptionalSubdirs -> OptionalSubdirs -> Bool
== :: OptionalSubdirs -> OptionalSubdirs -> Bool
$c== :: OptionalSubdirs -> OptionalSubdirs -> Bool
Eq, forall x. Rep OptionalSubdirs x -> OptionalSubdirs
forall x. OptionalSubdirs -> Rep OptionalSubdirs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OptionalSubdirs x -> OptionalSubdirs
$cfrom :: forall x. OptionalSubdirs -> Rep OptionalSubdirs x
Generic)

instance NFData OptionalSubdirs

-- | Metadata provided by a config file for archives and repos. This information

-- can be used for optimized lookups of information like package identifiers, or

-- for validating that the user configuration has the expected information.

--

-- @since 0.1.0.0

data RawPackageMetadata = RawPackageMetadata
  { RawPackageMetadata -> Maybe PackageName
rpmName :: !(Maybe PackageName)
    -- ^ Package name in the cabal file

    --

    -- @since 0.1.0.0

  , RawPackageMetadata -> Maybe Version
rpmVersion :: !(Maybe Version)
    -- ^ Package version in the cabal file

    --

    -- @since 0.1.0.0

  , RawPackageMetadata -> Maybe TreeKey
rpmTreeKey :: !(Maybe TreeKey)
    -- ^ Tree key of the loaded up package

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> RawPackageMetadata -> ShowS
[RawPackageMetadata] -> ShowS
RawPackageMetadata -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawPackageMetadata] -> ShowS
$cshowList :: [RawPackageMetadata] -> ShowS
show :: RawPackageMetadata -> [Char]
$cshow :: RawPackageMetadata -> [Char]
showsPrec :: Int -> RawPackageMetadata -> ShowS
$cshowsPrec :: Int -> RawPackageMetadata -> ShowS
Show, RawPackageMetadata -> RawPackageMetadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c/= :: RawPackageMetadata -> RawPackageMetadata -> Bool
== :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c== :: RawPackageMetadata -> RawPackageMetadata -> Bool
Eq, Eq RawPackageMetadata
RawPackageMetadata -> RawPackageMetadata -> Bool
RawPackageMetadata -> RawPackageMetadata -> Ordering
RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
$cmin :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
max :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
$cmax :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
>= :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c>= :: RawPackageMetadata -> RawPackageMetadata -> Bool
> :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c> :: RawPackageMetadata -> RawPackageMetadata -> Bool
<= :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c<= :: RawPackageMetadata -> RawPackageMetadata -> Bool
< :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c< :: RawPackageMetadata -> RawPackageMetadata -> Bool
compare :: RawPackageMetadata -> RawPackageMetadata -> Ordering
$ccompare :: RawPackageMetadata -> RawPackageMetadata -> Ordering
Ord, forall x. Rep RawPackageMetadata x -> RawPackageMetadata
forall x. RawPackageMetadata -> Rep RawPackageMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawPackageMetadata x -> RawPackageMetadata
$cfrom :: forall x. RawPackageMetadata -> Rep RawPackageMetadata x
Generic, Typeable)

instance NFData RawPackageMetadata

instance Display RawPackageMetadata where
  display :: RawPackageMetadata -> Utf8Builder
display RawPackageMetadata
rpm = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
    [ (\PackageName
name -> Utf8Builder
"name == " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm
    , (\Version
version -> Utf8Builder
"version == " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
version)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm
    , (\TreeKey
tree -> Utf8Builder
"tree == " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display TreeKey
tree) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm
    ]

-- | Exact metadata specifying concrete package

--

-- @since 0.1.0.0

data PackageMetadata = PackageMetadata
  { PackageMetadata -> PackageIdentifier
pmIdent :: !PackageIdentifier
    -- ^ Package identifier in the cabal file

    --

    -- @since 0.1.0.0

  , PackageMetadata -> TreeKey
pmTreeKey :: !TreeKey
    -- ^ Tree key of the loaded up package

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> PackageMetadata -> ShowS
[PackageMetadata] -> ShowS
PackageMetadata -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageMetadata] -> ShowS
$cshowList :: [PackageMetadata] -> ShowS
show :: PackageMetadata -> [Char]
$cshow :: PackageMetadata -> [Char]
showsPrec :: Int -> PackageMetadata -> ShowS
$cshowsPrec :: Int -> PackageMetadata -> ShowS
Show, PackageMetadata -> PackageMetadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageMetadata -> PackageMetadata -> Bool
$c/= :: PackageMetadata -> PackageMetadata -> Bool
== :: PackageMetadata -> PackageMetadata -> Bool
$c== :: PackageMetadata -> PackageMetadata -> Bool
Eq, Eq PackageMetadata
PackageMetadata -> PackageMetadata -> Bool
PackageMetadata -> PackageMetadata -> Ordering
PackageMetadata -> PackageMetadata -> PackageMetadata
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageMetadata -> PackageMetadata -> PackageMetadata
$cmin :: PackageMetadata -> PackageMetadata -> PackageMetadata
max :: PackageMetadata -> PackageMetadata -> PackageMetadata
$cmax :: PackageMetadata -> PackageMetadata -> PackageMetadata
>= :: PackageMetadata -> PackageMetadata -> Bool
$c>= :: PackageMetadata -> PackageMetadata -> Bool
> :: PackageMetadata -> PackageMetadata -> Bool
$c> :: PackageMetadata -> PackageMetadata -> Bool
<= :: PackageMetadata -> PackageMetadata -> Bool
$c<= :: PackageMetadata -> PackageMetadata -> Bool
< :: PackageMetadata -> PackageMetadata -> Bool
$c< :: PackageMetadata -> PackageMetadata -> Bool
compare :: PackageMetadata -> PackageMetadata -> Ordering
$ccompare :: PackageMetadata -> PackageMetadata -> Ordering
Ord, forall x. Rep PackageMetadata x -> PackageMetadata
forall x. PackageMetadata -> Rep PackageMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageMetadata x -> PackageMetadata
$cfrom :: forall x. PackageMetadata -> Rep PackageMetadata x
Generic, Typeable)

-- i PackageMetadata

instance NFData PackageMetadata

instance Display PackageMetadata where
  display :: PackageMetadata -> Utf8Builder
display PackageMetadata
pm = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Utf8Builder
", "
    [ Utf8Builder
"ident == " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)
    , Utf8Builder
"tree == " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm)
    ]

parsePackageMetadata :: Object -> WarningParser PackageMetadata
parsePackageMetadata :: Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o = do
  Maybe BlobKey
_oldCabalFile :: Maybe BlobKey <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"cabal-file"
  BlobKey
pantryTree :: BlobKey <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"pantry-tree"
  CabalString PackageName
pkgName <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"name"
  CabalString Version
pkgVersion <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"version"
  let pmTreeKey :: TreeKey
pmTreeKey = BlobKey -> TreeKey
TreeKey BlobKey
pantryTree
      pmIdent :: PackageIdentifier
pmIdent = PackageIdentifier {PackageName
Version
pkgVersion :: Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageName
..}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageMetadata {PackageIdentifier
TreeKey
pmIdent :: PackageIdentifier
pmTreeKey :: TreeKey
pmTreeKey :: TreeKey
pmIdent :: PackageIdentifier
..}


-- | Convert package metadata to its "raw" equivalent.

--

-- @since 0.1.0.0

toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm = Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata (forall a. a -> Maybe a
Just PackageName
name) (forall a. a -> Maybe a
Just Version
version) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm)
 where
  PackageIdentifier PackageName
name Version
version = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm

-- | File path relative to the configuration file it was parsed from

--

-- @since 0.1.0.0

newtype RelFilePath = RelFilePath Text
  deriving (Int -> RelFilePath -> ShowS
[RelFilePath] -> ShowS
RelFilePath -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RelFilePath] -> ShowS
$cshowList :: [RelFilePath] -> ShowS
show :: RelFilePath -> [Char]
$cshow :: RelFilePath -> [Char]
showsPrec :: Int -> RelFilePath -> ShowS
$cshowsPrec :: Int -> RelFilePath -> ShowS
Show, [RelFilePath] -> Encoding
[RelFilePath] -> Value
RelFilePath -> Encoding
RelFilePath -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RelFilePath] -> Encoding
$ctoEncodingList :: [RelFilePath] -> Encoding
toJSONList :: [RelFilePath] -> Value
$ctoJSONList :: [RelFilePath] -> Value
toEncoding :: RelFilePath -> Encoding
$ctoEncoding :: RelFilePath -> Encoding
toJSON :: RelFilePath -> Value
$ctoJSON :: RelFilePath -> Value
ToJSON, Value -> Parser [RelFilePath]
Value -> Parser RelFilePath
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RelFilePath]
$cparseJSONList :: Value -> Parser [RelFilePath]
parseJSON :: Value -> Parser RelFilePath
$cparseJSON :: Value -> Parser RelFilePath
FromJSON, RelFilePath -> RelFilePath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelFilePath -> RelFilePath -> Bool
$c/= :: RelFilePath -> RelFilePath -> Bool
== :: RelFilePath -> RelFilePath -> Bool
$c== :: RelFilePath -> RelFilePath -> Bool
Eq, Eq RelFilePath
RelFilePath -> RelFilePath -> Bool
RelFilePath -> RelFilePath -> Ordering
RelFilePath -> RelFilePath -> RelFilePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RelFilePath -> RelFilePath -> RelFilePath
$cmin :: RelFilePath -> RelFilePath -> RelFilePath
max :: RelFilePath -> RelFilePath -> RelFilePath
$cmax :: RelFilePath -> RelFilePath -> RelFilePath
>= :: RelFilePath -> RelFilePath -> Bool
$c>= :: RelFilePath -> RelFilePath -> Bool
> :: RelFilePath -> RelFilePath -> Bool
$c> :: RelFilePath -> RelFilePath -> Bool
<= :: RelFilePath -> RelFilePath -> Bool
$c<= :: RelFilePath -> RelFilePath -> Bool
< :: RelFilePath -> RelFilePath -> Bool
$c< :: RelFilePath -> RelFilePath -> Bool
compare :: RelFilePath -> RelFilePath -> Ordering
$ccompare :: RelFilePath -> RelFilePath -> Ordering
Ord, forall x. Rep RelFilePath x -> RelFilePath
forall x. RelFilePath -> Rep RelFilePath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelFilePath x -> RelFilePath
$cfrom :: forall x. RelFilePath -> Rep RelFilePath x
Generic, Typeable, RelFilePath -> ()
forall a. (a -> ()) -> NFData a
rnf :: RelFilePath -> ()
$crnf :: RelFilePath -> ()
NFData, RelFilePath -> Text
RelFilePath -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: RelFilePath -> Text
$ctextDisplay :: RelFilePath -> Text
display :: RelFilePath -> Utf8Builder
$cdisplay :: RelFilePath -> Utf8Builder
Display)

-- | Location that an archive is stored at

--

-- @since 0.1.0.0

data ArchiveLocation
  = ALUrl !Text
    -- ^ Archive stored at an HTTP(S) URL

    --

    -- @since 0.1.0.0

  | ALFilePath !(ResolvedPath File)
    -- ^ Archive stored at a local file path

    --

    -- @since 0.1.0.0

  deriving (Int -> ArchiveLocation -> ShowS
[ArchiveLocation] -> ShowS
ArchiveLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ArchiveLocation] -> ShowS
$cshowList :: [ArchiveLocation] -> ShowS
show :: ArchiveLocation -> [Char]
$cshow :: ArchiveLocation -> [Char]
showsPrec :: Int -> ArchiveLocation -> ShowS
$cshowsPrec :: Int -> ArchiveLocation -> ShowS
Show, ArchiveLocation -> ArchiveLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArchiveLocation -> ArchiveLocation -> Bool
$c/= :: ArchiveLocation -> ArchiveLocation -> Bool
== :: ArchiveLocation -> ArchiveLocation -> Bool
$c== :: ArchiveLocation -> ArchiveLocation -> Bool
Eq, Eq ArchiveLocation
ArchiveLocation -> ArchiveLocation -> Bool
ArchiveLocation -> ArchiveLocation -> Ordering
ArchiveLocation -> ArchiveLocation -> ArchiveLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
$cmin :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
max :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
$cmax :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
>= :: ArchiveLocation -> ArchiveLocation -> Bool
$c>= :: ArchiveLocation -> ArchiveLocation -> Bool
> :: ArchiveLocation -> ArchiveLocation -> Bool
$c> :: ArchiveLocation -> ArchiveLocation -> Bool
<= :: ArchiveLocation -> ArchiveLocation -> Bool
$c<= :: ArchiveLocation -> ArchiveLocation -> Bool
< :: ArchiveLocation -> ArchiveLocation -> Bool
$c< :: ArchiveLocation -> ArchiveLocation -> Bool
compare :: ArchiveLocation -> ArchiveLocation -> Ordering
$ccompare :: ArchiveLocation -> ArchiveLocation -> Ordering
Ord, forall x. Rep ArchiveLocation x -> ArchiveLocation
forall x. ArchiveLocation -> Rep ArchiveLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ArchiveLocation x -> ArchiveLocation
$cfrom :: forall x. ArchiveLocation -> Rep ArchiveLocation x
Generic, Typeable)

instance NFData ArchiveLocation

instance Display ArchiveLocation where
  display :: ArchiveLocation -> Utf8Builder
display (ALUrl Text
url) = forall a. Display a => a -> Utf8Builder
display Text
url
  display (ALFilePath ResolvedPath File
resolved) =
    forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
resolved

instance Pretty ArchiveLocation where
  pretty :: ArchiveLocation -> StyleDoc
pretty (ALUrl Text
url) = Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url)
  pretty (ALFilePath ResolvedPath File
resolved) = forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
resolved

parseArchiveLocationObject ::
     Object
  -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject Object
o =
      ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"url") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
validateUrl)
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"filepath") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath)
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"archive") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText)
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"location") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText)

parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText Text
t =
  case Text -> Either Text (Unresolved ArchiveLocation)
validateUrl Text
t of
    Left Text
e1 ->
      case Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath Text
t of
        Left Text
e2 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
          [ Text
"Invalid archive location, neither a URL nor a file path"
          , Text
"  URL error: " forall a. Semigroup a => a -> a -> a
<> Text
e1
          , Text
"  File path error: " forall a. Semigroup a => a -> a -> a
<> Text
e2
          ]
        Right Unresolved ArchiveLocation
x -> forall a b. b -> Either a b
Right Unresolved ArchiveLocation
x
    Right Unresolved ArchiveLocation
x -> forall a b. b -> Either a b
Right Unresolved ArchiveLocation
x

validateUrl :: Text -> Either Text (Unresolved ArchiveLocation)
validateUrl :: Text -> Either Text (Unresolved ArchiveLocation)
validateUrl Text
t =
  case forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
    Left SomeException
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse URL: " forall a. Semigroup a => a -> a -> a
<> Text
t
    Right Request
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ArchiveLocation
ALUrl Text
t

validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath Text
t =
  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isSuffixOf` Text
t) (Text -> [Text]
T.words Text
".zip .tar .tar.gz")
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \case
      Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidFilePathSnapshot Text
t
      Just Path Abs Dir
dir -> do
        Path Abs File
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
dir forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> ArchiveLocation
ALFilePath forall a b. (a -> b) -> a -> b
$ forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
t) Path Abs File
abs'
    else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Does not have an archive file extension: " forall a. Semigroup a => a -> a -> a
<> Text
t

instance ToJSON RawPackageLocation where
  toJSON :: RawPackageLocation -> Value
toJSON (RPLImmutable RawPackageLocationImmutable
rpli) = forall a. ToJSON a => a -> Value
toJSON RawPackageLocationImmutable
rpli
  toJSON (RPLMutable ResolvedPath Dir
resolved) = forall a. ToJSON a => a -> Value
toJSON (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath Dir
resolved)

instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where
  parseJSON :: Value
-> Parser
     (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation)))
parseJSON Value
v =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable (forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    (forall a. a -> WithJSONWarnings a
noJSONWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Unresolved (NonEmpty RawPackageLocation)
mkMutable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
   where
    mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation)
    mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation)
mkMutable Text
t = forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
      case Maybe (Path Abs Dir)
mdir of
        Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
MutablePackageLocationFromUrl Text
t
        Just Path Abs Dir
dir -> do
          Path Abs Dir
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs Dir)
resolveDir Path Abs Dir
dir forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> RawPackageLocation
RPLMutable forall a b. (a -> b) -> a -> b
$ forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
t) Path Abs Dir
abs'

instance ToJSON RawPackageLocationImmutable where
  toJSON :: RawPackageLocationImmutable -> Value
toJSON (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtree) = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$
    (AesonKey
"hackage" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= PackageIdentifierRevision
pir) forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\TreeKey
tree -> [AesonKey
"pantry-tree" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= TreeKey
tree]) Maybe TreeKey
mtree
  toJSON (RPLIArchive (RawArchive ArchiveLocation
loc Maybe SHA256
msha Maybe FileSize
msize Text
subdir) RawPackageMetadata
rpm) = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ case ArchiveLocation
loc of
        ALUrl Text
url -> [AesonKey
"url" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
url]
        ALFilePath ResolvedPath File
resolved -> [AesonKey
"filepath" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\SHA256
sha -> [AesonKey
"sha256" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SHA256
sha]) Maybe SHA256
msha
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FileSize
size' -> [AesonKey
"size" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= FileSize
size']) Maybe FileSize
msize
    , [ AesonKey
"subdir" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
subdir | Bool -> Bool
not (Text -> Bool
T.null Text
subdir) ]
    , RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs RawPackageMetadata
rpm
    ]
  toJSON (RPLIRepo (Repo Text
url Text
commit RepoType
typ Text
subdir) RawPackageMetadata
rpm) = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ AesonKey
urlKey forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
url
      , AesonKey
"commit" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
commit
      ]
    , [AesonKey
"subdir" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
subdir | Bool -> Bool
not (Text -> Bool
T.null Text
subdir) ]
    , RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs RawPackageMetadata
rpm
    ]
   where
    urlKey :: AesonKey
urlKey =
      case RepoType
typ of
        RepoType
RepoGit -> AesonKey
"git"
        RepoType
RepoHg  -> AesonKey
"hg"

rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs (RawPackageMetadata Maybe PackageName
mname Maybe Version
mversion Maybe TreeKey
mtree) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\PackageName
name -> [AesonKey
"name" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a. a -> CabalString a
CabalString PackageName
name]) Maybe PackageName
mname
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Version
version -> [AesonKey
"version" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a. a -> CabalString a
CabalString Version
version]) Maybe Version
mversion
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\TreeKey
tree -> [AesonKey
"pantry-tree" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= TreeKey
tree]) Maybe TreeKey
mtree
  ]

instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where
  parseJSON :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
parseJSON Value
v =
        Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
repoObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
archiveObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
hackageObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
github Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Could not parse a UnresolvedPackageLocationImmutable from: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
v)
   where
    repoObject ::
         Value
      -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
    repoObject :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
repoObject =
      forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.PLIRepo" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        PackageMetadata
pm <- Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o
        Text
repoSubdir <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
""
        Text
repoCommit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
        (RepoType
repoType, Text
repoUrl) <-
            (Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"git" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
url -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoType
RepoGit, Text
url)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
            (Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hg" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
url -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoType
RepoHg, Text
url))
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo {Text
RepoType
repoUrl :: Text
repoType :: RepoType
repoCommit :: Text
repoSubdir :: Text
repoType :: RepoType
repoSubdir :: Text
repoCommit :: Text
repoUrl :: Text
..} PackageMetadata
pm

    archiveObject :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
archiveObject =
      forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.PLIArchive" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        PackageMetadata
pm <- Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o
        Unresolved Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation <- Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject Object
o
        SHA256
archiveHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"sha256"
        FileSize
archiveSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"size"
        Text
archiveSubdir <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
""
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
          ArchiveLocation
archiveLocation <- Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation Maybe (Path Abs Dir)
mdir
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive Archive {Text
SHA256
ArchiveLocation
FileSize
archiveLocation :: ArchiveLocation
archiveSubdir :: Text
archiveSize :: FileSize
archiveHash :: SHA256
archiveSize :: FileSize
archiveHash :: SHA256
archiveSubdir :: Text
archiveLocation :: ArchiveLocation
..} PackageMetadata
pm

    hackageObject :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
hackageObject =
      forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackagelocationimmutable.PLIHackage (Object)" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        BlobKey
treeKey <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"pantry-tree"
        Text
htxt <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hackage"
        case Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText Text
htxt of
          Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PantryException
e
          Right (PackageIdentifier
pkgIdentifier, BlobKey
blobKey) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage PackageIdentifier
pkgIdentifier BlobKey
blobKey (BlobKey -> TreeKey
TreeKey BlobKey
treeKey)

    github :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
github =
      forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackagelocationimmutable.PLIArchive:github" (\Object
o -> do
        PackageMetadata
pm <- Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o
        GitHubRepo Text
ghRepo <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"github"
        Text
commit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
        let archiveLocation :: ArchiveLocation
archiveLocation = Text -> ArchiveLocation
ALUrl forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
              [ Text
"https://github.com/"
              , Text
ghRepo
              , Text
"/archive/"
              , Text
commit
              , Text
".tar.gz"
              ]
        SHA256
archiveHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"sha256"
        FileSize
archiveSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"size"
        Text
archiveSubdir <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
""
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive Archive {Text
SHA256
ArchiveLocation
FileSize
archiveSubdir :: Text
archiveSize :: FileSize
archiveHash :: SHA256
archiveLocation :: ArchiveLocation
archiveSize :: FileSize
archiveHash :: SHA256
archiveSubdir :: Text
archiveLocation :: ArchiveLocation
..} PackageMetadata
pm)

instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where
  parseJSON :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
parseJSON Value
v =
        Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
http Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageText Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
repo Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
archiveObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
github Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Could not parse a UnresolvedRawPackageLocationImmutable from: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
v)
   where
    http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable)))
    http :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
http = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"UnresolvedPackageLocationImmutable.RPLIArchive (Text)" forall a b. (a -> b) -> a -> b
$ \Text
t ->
      case Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText Text
t of
        Left Text
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid archive location: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
        Right (Unresolved Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> WithJSONWarnings a
noJSONWarnings forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
            ArchiveLocation
raLocation <- Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation Maybe (Path Abs Dir)
mdir
            let raHash :: Maybe a
raHash = forall a. Maybe a
Nothing
                raSize :: Maybe a
raSize = forall a. Maybe a
Nothing
                raSubdir :: Text
raSubdir = Text
T.empty
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive {Text
ArchiveLocation
forall a. Maybe a
raSubdir :: Text
raSize :: forall a. Maybe a
raHash :: forall a. Maybe a
raLocation :: ArchiveLocation
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSubdir :: Text
raLocation :: ArchiveLocation
..} RawPackageMetadata
rpmEmpty

    hackageText :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageText = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"UnresolvedPackageLocationImmutable.UPLIHackage (Text)" forall a b. (a -> b) -> a -> b
$ \Text
t ->
      case Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t of
        Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PantryException
e
        Right PackageIdentifierRevision
pir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> WithJSONWarnings a
noJSONWarnings forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir forall a. Maybe a
Nothing

    hackageObject :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageObject = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.UPLIHackage" forall a b. (a -> b) -> a -> b
$ \Object
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hackage"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"pantry-tree")

    optionalSubdirs :: Object -> WarningParser OptionalSubdirs
    optionalSubdirs :: Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o =
      -- if subdirs exists, it needs to be valid

      case forall v. AesonKey -> KeyMap v -> Maybe v
HM.lookup AesonKey
"subdirs" Object
o of
        Just Value
v' -> do
          Text -> WarningParser ()
tellJSONField Text
"subdirs"
          [Text]
subdirs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON Value
v'
          case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
subdirs of
            Maybe (NonEmpty Text)
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid empty subdirs"
            Just NonEmpty Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> OptionalSubdirs
OSSubdirs NonEmpty Text
x
        Maybe Value
Nothing -> Text -> RawPackageMetadata -> OptionalSubdirs
OSPackageMetadata
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
T.empty
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (   Maybe PackageName
-> Maybe Version
-> Maybe TreeKey
-> Maybe BlobKey
-> RawPackageMetadata
rawPackageMetadataHelper
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. CabalString a -> a
unCabalString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"name"))
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. CabalString a -> a
unCabalString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"version"))
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"pantry-tree"
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"cabal-file"
              )

    rawPackageMetadataHelper ::
         Maybe PackageName
      -> Maybe Version
      -> Maybe TreeKey
      -> Maybe BlobKey
      -> RawPackageMetadata
    rawPackageMetadataHelper :: Maybe PackageName
-> Maybe Version
-> Maybe TreeKey
-> Maybe BlobKey
-> RawPackageMetadata
rawPackageMetadataHelper Maybe PackageName
name Maybe Version
version Maybe TreeKey
pantryTree Maybe BlobKey
_ignoredCabalFile =
      Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata Maybe PackageName
name Maybe Version
version Maybe TreeKey
pantryTree

    repo :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
repo = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.UPLIRepo" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      (RepoType
repoType, Text
repoUrl) <-
        ((RepoType
RepoGit, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"git") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        ((RepoType
RepoHg, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hg")
      Text
repoCommit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
      OptionalSubdirs
os <- Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(Text
repoSubdir, RawPackageMetadata
pm) -> Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo Repo {Text
RepoType
repoSubdir :: Text
repoCommit :: Text
repoUrl :: Text
repoType :: RepoType
repoType :: RepoType
repoSubdir :: Text
repoCommit :: Text
repoUrl :: Text
..} RawPackageMetadata
pm) (OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms OptionalSubdirs
os)

    archiveObject :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
archiveObject = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.RPLIArchive" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      Unresolved Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation <- Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject Object
o
      Maybe SHA256
raHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"sha256"
      Maybe FileSize
raSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"size"
      OptionalSubdirs
os <- Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
        ArchiveLocation
raLocation <- Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation Maybe (Path Abs Dir)
mdir
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(Text
raSubdir, RawPackageMetadata
pm) -> RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive {Maybe SHA256
Maybe FileSize
Text
ArchiveLocation
raSubdir :: Text
raLocation :: ArchiveLocation
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSubdir :: Text
raLocation :: ArchiveLocation
..} RawPackageMetadata
pm) (OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms OptionalSubdirs
os)

    github :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
github = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"PLArchive:github" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      GitHubRepo Text
ghRepo <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"github"
      Text
commit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
      let raLocation :: ArchiveLocation
raLocation = Text -> ArchiveLocation
ALUrl forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ Text
"https://github.com/"
            , Text
ghRepo
            , Text
"/archive/"
            , Text
commit
            , Text
".tar.gz"
            ]
      Maybe SHA256
raHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"sha256"
      Maybe FileSize
raSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"size"
      OptionalSubdirs
os <- Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(Text
raSubdir, RawPackageMetadata
pm) -> RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive {Maybe SHA256
Maybe FileSize
Text
ArchiveLocation
raSubdir :: Text
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raLocation :: ArchiveLocation
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSubdir :: Text
raLocation :: ArchiveLocation
..} RawPackageMetadata
pm) (OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms OptionalSubdirs
os)

-- | Returns pairs of subdirectory and 'PackageMetadata'.

osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms (OSSubdirs NonEmpty Text
subdirs) = forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (, RawPackageMetadata
rpmEmpty) NonEmpty Text
subdirs
osToRpms (OSPackageMetadata Text
subdir RawPackageMetadata
rpm) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
subdir, RawPackageMetadata
rpm)

rpmEmpty :: RawPackageMetadata
rpmEmpty :: RawPackageMetadata
rpmEmpty = Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing

-- | Newtype wrapper for easier JSON integration with Cabal types.

--

-- @since 0.1.0.0

newtype CabalString a = CabalString { forall a. CabalString a -> a
unCabalString :: a }
  deriving (Int -> CabalString a -> ShowS
forall a. Show a => Int -> CabalString a -> ShowS
forall a. Show a => [CabalString a] -> ShowS
forall a. Show a => CabalString a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CabalString a] -> ShowS
$cshowList :: forall a. Show a => [CabalString a] -> ShowS
show :: CabalString a -> [Char]
$cshow :: forall a. Show a => CabalString a -> [Char]
showsPrec :: Int -> CabalString a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CabalString a -> ShowS
Show, CabalString a -> CabalString a -> Bool
forall a. Eq a => CabalString a -> CabalString a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CabalString a -> CabalString a -> Bool
$c/= :: forall a. Eq a => CabalString a -> CabalString a -> Bool
== :: CabalString a -> CabalString a -> Bool
$c== :: forall a. Eq a => CabalString a -> CabalString a -> Bool
Eq, CabalString a -> CabalString a -> Bool
CabalString a -> CabalString a -> Ordering
CabalString a -> CabalString a -> CabalString a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (CabalString a)
forall a. Ord a => CabalString a -> CabalString a -> Bool
forall a. Ord a => CabalString a -> CabalString a -> Ordering
forall a. Ord a => CabalString a -> CabalString a -> CabalString a
min :: CabalString a -> CabalString a -> CabalString a
$cmin :: forall a. Ord a => CabalString a -> CabalString a -> CabalString a
max :: CabalString a -> CabalString a -> CabalString a
$cmax :: forall a. Ord a => CabalString a -> CabalString a -> CabalString a
>= :: CabalString a -> CabalString a -> Bool
$c>= :: forall a. Ord a => CabalString a -> CabalString a -> Bool
> :: CabalString a -> CabalString a -> Bool
$c> :: forall a. Ord a => CabalString a -> CabalString a -> Bool
<= :: CabalString a -> CabalString a -> Bool
$c<= :: forall a. Ord a => CabalString a -> CabalString a -> Bool
< :: CabalString a -> CabalString a -> Bool
$c< :: forall a. Ord a => CabalString a -> CabalString a -> Bool
compare :: CabalString a -> CabalString a -> Ordering
$ccompare :: forall a. Ord a => CabalString a -> CabalString a -> Ordering
Ord, Typeable)

-- I'd like to use coerce here, but can't due to roles. unsafeCoerce

-- could work, but let's avoid unsafe code.


-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON'

-- instance.

--

-- @since 0.1.0.0

toCabalStringMap :: Map a v -> Map (CabalString a) v
toCabalStringMap :: forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap = forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic forall a. a -> CabalString a
CabalString

-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a

-- 'FromJSON' instance.

--

-- @since 0.1.0.0

unCabalStringMap :: Map (CabalString a) v -> Map a v
unCabalStringMap :: forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap = forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic forall a. CabalString a -> a
unCabalString

instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where
  toJSON :: CabalString a -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
Distribution.Text.display forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CabalString a -> a
unCabalString

instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where
  toJSONKey :: ToJSONKeyFunction (CabalString a)
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
Distribution.Text.display forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CabalString a -> a
unCabalString

instance forall a. IsCabalString a => FromJSON (CabalString a) where
  parseJSON :: Value -> Parser (CabalString a)
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
name forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case forall a. IsCabalString a => [Char] -> Maybe a
cabalStringParser forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
      Maybe a
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
      Just a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> CabalString a
CabalString a
x
   where
    name :: [Char]
name = forall a (proxy :: * -> *). IsCabalString a => proxy a -> [Char]
cabalStringName (forall a. Maybe a
Nothing :: Maybe a)

instance forall a. IsCabalString a => FromJSONKey (CabalString a) where
  fromJSONKey :: FromJSONKeyFunction (CabalString a)
fromJSONKey =
    forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case forall a. IsCabalString a => [Char] -> Maybe a
cabalStringParser forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
      Maybe a
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
      Just a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> CabalString a
CabalString a
x
   where
    name :: [Char]
name = forall a (proxy :: * -> *). IsCabalString a => proxy a -> [Char]
cabalStringName (forall a. Maybe a
Nothing :: Maybe a)

class IsCabalString a where
  cabalStringName :: proxy a -> String
  cabalStringParser :: String -> Maybe a

instance IsCabalString PackageName where
  cabalStringName :: forall (proxy :: * -> *). proxy PackageName -> [Char]
cabalStringName proxy PackageName
_ = [Char]
"package name"
  cabalStringParser :: [Char] -> Maybe PackageName
cabalStringParser = [Char] -> Maybe PackageName
parsePackageName

instance IsCabalString Version where
  cabalStringName :: forall (proxy :: * -> *). proxy Version -> [Char]
cabalStringName proxy Version
_ = [Char]
"version"
  cabalStringParser :: [Char] -> Maybe Version
cabalStringParser = [Char] -> Maybe Version
parseVersion

instance IsCabalString VersionRange where
  cabalStringName :: forall (proxy :: * -> *). proxy VersionRange -> [Char]
cabalStringName proxy VersionRange
_ = [Char]
"version range"
  cabalStringParser :: [Char] -> Maybe VersionRange
cabalStringParser = [Char] -> Maybe VersionRange
parseVersionRange

instance IsCabalString PackageIdentifier where
  cabalStringName :: forall (proxy :: * -> *). proxy PackageIdentifier -> [Char]
cabalStringName proxy PackageIdentifier
_ = [Char]
"package identifier"
  cabalStringParser :: [Char] -> Maybe PackageIdentifier
cabalStringParser = [Char] -> Maybe PackageIdentifier
parsePackageIdentifier

instance IsCabalString FlagName where
  cabalStringName :: forall (proxy :: * -> *). proxy FlagName -> [Char]
cabalStringName proxy FlagName
_ = [Char]
"flag name"
  cabalStringParser :: [Char] -> Maybe FlagName
cabalStringParser = [Char] -> Maybe FlagName
parseFlagName

-- | What to use for running hpack

--

-- @since 0.1.0.0

data HpackExecutable
  = HpackBundled
    -- ^ Compiled in library

  | HpackCommand !FilePath
    -- ^ Executable at the provided path

  deriving (Int -> HpackExecutable -> ShowS
[HpackExecutable] -> ShowS
HpackExecutable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HpackExecutable] -> ShowS
$cshowList :: [HpackExecutable] -> ShowS
show :: HpackExecutable -> [Char]
$cshow :: HpackExecutable -> [Char]
showsPrec :: Int -> HpackExecutable -> ShowS
$cshowsPrec :: Int -> HpackExecutable -> ShowS
Show, ReadPrec [HpackExecutable]
ReadPrec HpackExecutable
Int -> ReadS HpackExecutable
ReadS [HpackExecutable]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HpackExecutable]
$creadListPrec :: ReadPrec [HpackExecutable]
readPrec :: ReadPrec HpackExecutable
$creadPrec :: ReadPrec HpackExecutable
readList :: ReadS [HpackExecutable]
$creadList :: ReadS [HpackExecutable]
readsPrec :: Int -> ReadS HpackExecutable
$creadsPrec :: Int -> ReadS HpackExecutable
Read, HpackExecutable -> HpackExecutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HpackExecutable -> HpackExecutable -> Bool
$c/= :: HpackExecutable -> HpackExecutable -> Bool
== :: HpackExecutable -> HpackExecutable -> Bool
$c== :: HpackExecutable -> HpackExecutable -> Bool
Eq, Eq HpackExecutable
HpackExecutable -> HpackExecutable -> Bool
HpackExecutable -> HpackExecutable -> Ordering
HpackExecutable -> HpackExecutable -> HpackExecutable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HpackExecutable -> HpackExecutable -> HpackExecutable
$cmin :: HpackExecutable -> HpackExecutable -> HpackExecutable
max :: HpackExecutable -> HpackExecutable -> HpackExecutable
$cmax :: HpackExecutable -> HpackExecutable -> HpackExecutable
>= :: HpackExecutable -> HpackExecutable -> Bool
$c>= :: HpackExecutable -> HpackExecutable -> Bool
> :: HpackExecutable -> HpackExecutable -> Bool
$c> :: HpackExecutable -> HpackExecutable -> Bool
<= :: HpackExecutable -> HpackExecutable -> Bool
$c<= :: HpackExecutable -> HpackExecutable -> Bool
< :: HpackExecutable -> HpackExecutable -> Bool
$c< :: HpackExecutable -> HpackExecutable -> Bool
compare :: HpackExecutable -> HpackExecutable -> Ordering
$ccompare :: HpackExecutable -> HpackExecutable -> Ordering
Ord)


-- | Which compiler a snapshot wants to use. The build tool may elect to do some

-- fuzzy matching of versions (e.g., allowing different patch versions).

--

-- @since 0.1.0.0

data WantedCompiler
  = WCGhc !Version
  | WCGhcGit !Text !Text
  | WCGhcjs
      !Version
      !Version
    -- ^ GHCJS version followed by GHC version

  deriving (Int -> WantedCompiler -> ShowS
[WantedCompiler] -> ShowS
WantedCompiler -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WantedCompiler] -> ShowS
$cshowList :: [WantedCompiler] -> ShowS
show :: WantedCompiler -> [Char]
$cshow :: WantedCompiler -> [Char]
showsPrec :: Int -> WantedCompiler -> ShowS
$cshowsPrec :: Int -> WantedCompiler -> ShowS
Show, WantedCompiler -> WantedCompiler -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WantedCompiler -> WantedCompiler -> Bool
$c/= :: WantedCompiler -> WantedCompiler -> Bool
== :: WantedCompiler -> WantedCompiler -> Bool
$c== :: WantedCompiler -> WantedCompiler -> Bool
Eq, Eq WantedCompiler
WantedCompiler -> WantedCompiler -> Bool
WantedCompiler -> WantedCompiler -> Ordering
WantedCompiler -> WantedCompiler -> WantedCompiler
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WantedCompiler -> WantedCompiler -> WantedCompiler
$cmin :: WantedCompiler -> WantedCompiler -> WantedCompiler
max :: WantedCompiler -> WantedCompiler -> WantedCompiler
$cmax :: WantedCompiler -> WantedCompiler -> WantedCompiler
>= :: WantedCompiler -> WantedCompiler -> Bool
$c>= :: WantedCompiler -> WantedCompiler -> Bool
> :: WantedCompiler -> WantedCompiler -> Bool
$c> :: WantedCompiler -> WantedCompiler -> Bool
<= :: WantedCompiler -> WantedCompiler -> Bool
$c<= :: WantedCompiler -> WantedCompiler -> Bool
< :: WantedCompiler -> WantedCompiler -> Bool
$c< :: WantedCompiler -> WantedCompiler -> Bool
compare :: WantedCompiler -> WantedCompiler -> Ordering
$ccompare :: WantedCompiler -> WantedCompiler -> Ordering
Ord, forall x. Rep WantedCompiler x -> WantedCompiler
forall x. WantedCompiler -> Rep WantedCompiler x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WantedCompiler x -> WantedCompiler
$cfrom :: forall x. WantedCompiler -> Rep WantedCompiler x
Generic)

instance NFData WantedCompiler

instance Display WantedCompiler where
  display :: WantedCompiler -> Utf8Builder
display (WCGhc Version
vghc) = Utf8Builder
"ghc-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
vghc)
  display (WCGhcjs Version
vghcjs Version
vghc) =
       Utf8Builder
"ghcjs-"
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
vghcjs)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"_ghc-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
vghc)
  display (WCGhcGit Text
commit Text
flavour) =
    Utf8Builder
"ghc-git-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
commit forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
flavour

instance ToJSON WantedCompiler where
  toJSON :: WantedCompiler -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance FromJSON WantedCompiler where
  parseJSON :: Value -> Parser WantedCompiler
parseJSON =
    forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"WantedCompiler" forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either PantryException WantedCompiler
parseWantedCompiler

instance FromJSONKey WantedCompiler where
  fromJSONKey :: FromJSONKeyFunction WantedCompiler
fromJSONKey =
    forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Either PantryException WantedCompiler
parseWantedCompiler Text
t of
      Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid WantedCompiler " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PantryException
e
      Right WantedCompiler
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure WantedCompiler
x

-- | Parse a 'Text' into a 'WantedCompiler' value.

--

-- @since 0.1.0.0

parseWantedCompiler :: Text -> Either PantryException WantedCompiler
parseWantedCompiler :: Text -> Either PantryException WantedCompiler
parseWantedCompiler Text
t0 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidWantedCompiler Text
t0) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
  case Text -> Text -> Maybe Text
T.stripPrefix Text
"ghcjs-" Text
t0 of
    Just Text
t1 -> Text -> Maybe WantedCompiler
parseGhcjs Text
t1
    Maybe Text
Nothing -> case Text -> Text -> Maybe Text
T.stripPrefix Text
"ghc-git-" Text
t0 of
       Just Text
t1 -> forall {f :: * -> *}. Applicative f => Text -> f WantedCompiler
parseGhcGit Text
t1
       Maybe Text
Nothing -> Text -> Text -> Maybe Text
T.stripPrefix Text
"ghc-" Text
t0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe WantedCompiler
parseGhc
 where
  parseGhcjs :: Text -> Maybe WantedCompiler
parseGhcjs Text
t1 = do
    let (Text
ghcjsVT, Text
t2) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'_') Text
t1
    Version
ghcjsV <- [Char] -> Maybe Version
parseVersion forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
ghcjsVT
    Text
ghcVT <- Text -> Text -> Maybe Text
T.stripPrefix Text
"_ghc-" Text
t2
    Version
ghcV <- [Char] -> Maybe Version
parseVersion forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
ghcVT
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Version -> Version -> WantedCompiler
WCGhcjs Version
ghcjsV Version
ghcV
  parseGhcGit :: Text -> f WantedCompiler
parseGhcGit Text
t1 = do
    let (Text
commit, Text
flavour) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'-') Text
t1
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> WantedCompiler
WCGhcGit Text
commit (Int -> Text -> Text
T.drop Int
1 Text
flavour)
  parseGhc :: Text -> Maybe WantedCompiler
parseGhc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> WantedCompiler
WCGhc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Version
parseVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where
  parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
parseJSON Value
v = Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
text Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
obj Value
v
   where
    text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
    text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
text =
      forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"UnresolvedSnapshotLocation (Text)" forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> WithJSONWarnings a
noJSONWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation

    obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
    obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
obj = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedSnapshotLocation (Object)" forall a b. (a -> b) -> a -> b
$ \Object
o ->
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. WantedCompiler -> RawSnapshotLocation
RSLCompiler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"compiler") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      ((\Text
x Maybe BlobKey
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
x Maybe BlobKey
y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"url" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> WarningParser (Maybe BlobKey)
blobKey Object
o) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      (Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"filepath")

    blobKey :: Object -> WarningParser (Maybe BlobKey)
blobKey Object
o = do
      Maybe SHA256
msha <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"sha256"
      Maybe FileSize
msize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"size"
      case (Maybe SHA256
msha, Maybe FileSize
msize) of
        (Maybe SHA256
Nothing, Maybe FileSize
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        (Just SHA256
sha, Just FileSize
size') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size'
        (Just SHA256
_sha, Maybe FileSize
Nothing) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"You must also specify the file size"
        (Maybe SHA256
Nothing, Just FileSize
_) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"You must also specify the file's SHA256"

instance Display SnapshotLocation where
  display :: SnapshotLocation -> Utf8Builder
display (SLCompiler WantedCompiler
compiler) = forall a. Display a => a -> Utf8Builder
display WantedCompiler
compiler
  display (SLUrl Text
url BlobKey
blob) = forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blob forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
  display (SLFilePath ResolvedPath File
resolved) = forall a. Display a => a -> Utf8Builder
display (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved)

-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'.

--

-- @since 0.1.0.0

parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation Text
t0 = forall a. a -> Maybe a -> a
fromMaybe (Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath Text
t0) forall a b. (a -> b) -> a -> b
$
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. WantedCompiler -> RawSnapshotLocation
RSLCompiler) (Text -> Either PantryException WantedCompiler
parseWantedCompiler Text
t0) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapName -> RawSnapshotLocation
RSLSynonym forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t0) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Maybe (Unresolved RawSnapshotLocation)
parseGitHub forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Maybe (Unresolved RawSnapshotLocation)
parseUrl
 where
  parseGitHub :: Maybe (Unresolved RawSnapshotLocation)
parseGitHub = do
    Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"github:" Text
t0
    let (Text
user, Text
t2) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
t1
    Text
t3 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"/" Text
t2
    let (Text
repo, Text
t4) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
t3
    Text
path <- Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t4
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
user Text
repo Text
path

  parseUrl :: Maybe (Unresolved RawSnapshotLocation)
parseUrl = forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest (Text -> [Char]
T.unpack Text
t0) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
t0 forall a. Maybe a
Nothing)

parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath Text
t =
  forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidFilePathSnapshot Text
t
    Just Path Abs Dir
dir -> do
      Path Abs File
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
dir (Text -> [Char]
T.unpack Text
t) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> Text -> PantryException
InvalidSnapshotLocation Path Abs Dir
dir Text
t)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> RawSnapshotLocation
RSLFilePath forall a b. (a -> b) -> a -> b
$ forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
t) Path Abs File
abs'

githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
user Text
repo Text
path =
  let url :: Text
url = [Text] -> Text
T.concat
        [ Text
"https://raw.githubusercontent.com/"
        , Text
user
        , Text
"/"
        , Text
repo
        , Text
"/master/"
        , Text
path
        ]
  in  Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
url forall a. Maybe a
Nothing

defUser :: Text
defUser :: Text
defUser = Text
"commercialhaskell"

defRepo :: Text
defRepo :: Text
defRepo = Text
"stackage-snapshots"

-- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub

-- repository.

--

-- @since 0.5.0.0

defaultSnapshotLocation ::
     SnapName
  -> RawSnapshotLocation
defaultSnapshotLocation :: SnapName -> RawSnapshotLocation
defaultSnapshotLocation (LTS Int
x Int
y) =
  Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
defUser Text
defRepo forall a b. (a -> b) -> a -> b
$
  Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$
  Utf8Builder
"lts/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
defaultSnapshotLocation (Nightly Day
date) =
     Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
defUser Text
defRepo
  forall a b. (a -> b) -> a -> b
$  Utf8Builder -> Text
utf8BuilderToText
  forall a b. (a -> b) -> a -> b
$  Utf8Builder
"nightly/"
  forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Year
year
  forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/"
  forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
month
  forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/"
  forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
day
  forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
 where
  (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date

-- | A snapshot synonym. It is expanded according to the field

-- 'snapshotLocation' of a 'PantryConfig'.

--

-- @ since 0.5.0.0

data SnapName
    = LTS
        !Int -- ^ Major version

        !Int -- ^ Minor version

      -- ^ LTS Haskell snapshot, displayed as @"lts-maj.min"@.

      --

      -- @since 0.5.0.0

    | Nightly !Day
      -- ^ Stackage Nightly snapshot, displayed as @"nighly-YYYY-MM-DD"@.

      --

      -- @since 0.5.0.0

    deriving (SnapName -> SnapName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapName -> SnapName -> Bool
$c/= :: SnapName -> SnapName -> Bool
== :: SnapName -> SnapName -> Bool
$c== :: SnapName -> SnapName -> Bool
Eq, Eq SnapName
SnapName -> SnapName -> Bool
SnapName -> SnapName -> Ordering
SnapName -> SnapName -> SnapName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapName -> SnapName -> SnapName
$cmin :: SnapName -> SnapName -> SnapName
max :: SnapName -> SnapName -> SnapName
$cmax :: SnapName -> SnapName -> SnapName
>= :: SnapName -> SnapName -> Bool
$c>= :: SnapName -> SnapName -> Bool
> :: SnapName -> SnapName -> Bool
$c> :: SnapName -> SnapName -> Bool
<= :: SnapName -> SnapName -> Bool
$c<= :: SnapName -> SnapName -> Bool
< :: SnapName -> SnapName -> Bool
$c< :: SnapName -> SnapName -> Bool
compare :: SnapName -> SnapName -> Ordering
$ccompare :: SnapName -> SnapName -> Ordering
Ord, forall x. Rep SnapName x -> SnapName
forall x. SnapName -> Rep SnapName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SnapName x -> SnapName
$cfrom :: forall x. SnapName -> Rep SnapName x
Generic)

instance NFData SnapName

instance Display SnapName where
  display :: SnapName -> Utf8Builder
display (LTS Int
x Int
y) = Utf8Builder
"lts-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"." forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y
  display (Nightly Day
date) = Utf8Builder
"nightly-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Day
date

instance Show SnapName where
  show :: SnapName -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance ToJSON SnapName where
  toJSON :: SnapName -> Value
toJSON SnapName
syn = Text -> Value
String forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display SnapName
syn

-- | Parse the short representation of a 'SnapName'.

--

-- @since 0.5.0.0

parseSnapName :: MonadThrow m => Text -> m SnapName
parseSnapName :: forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t0 =
  case Maybe SnapName
lts forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe SnapName
nightly of
    Maybe SnapName
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> PantryException
ParseSnapNameException Text
t0
    Just SnapName
sn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapName
sn
 where
  lts :: Maybe SnapName
lts = do
    Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"lts-" Text
t0
    Right (Int
x, Text
t2) <- forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Integral a => Reader a
decimal Text
t1
    Text
t3 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"." Text
t2
    Right (Int
y, Text
"") <- forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Integral a => Reader a
decimal Text
t3
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
  nightly :: Maybe SnapName
nightly = do
    Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"nightly-" Text
t0
    Day -> SnapName
Nightly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
t1)

-- | Where to load a snapshot from in raw form (RSUrl could have a missing

-- BlobKey)

--

-- @since 0.1.0.0

data RawSnapshotLocation
  = RSLCompiler !WantedCompiler
    -- ^ Don't use an actual snapshot, just a version of the compiler with its

    -- shipped packages.

    --

    -- @since 0.1.0.0

  | RSLUrl !Text !(Maybe BlobKey)
    -- ^ Download the snapshot from the given URL. The optional 'BlobKey' is

    -- used for reproducibility.

    --

    -- @since 0.1.0.0

  | RSLFilePath !(ResolvedPath File)
    -- ^ Snapshot at a local file path.

    --

    -- @since 0.1.0.0

  | RSLSynonym !SnapName
    -- ^ Snapshot synonym (LTS/Nightly).

    --

    -- @since 0.5.0.0

  deriving (Int -> RawSnapshotLocation -> ShowS
[RawSnapshotLocation] -> ShowS
RawSnapshotLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawSnapshotLocation] -> ShowS
$cshowList :: [RawSnapshotLocation] -> ShowS
show :: RawSnapshotLocation -> [Char]
$cshow :: RawSnapshotLocation -> [Char]
showsPrec :: Int -> RawSnapshotLocation -> ShowS
$cshowsPrec :: Int -> RawSnapshotLocation -> ShowS
Show, RawSnapshotLocation -> RawSnapshotLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c/= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
== :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c== :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
Eq, Eq RawSnapshotLocation
RawSnapshotLocation -> RawSnapshotLocation -> Bool
RawSnapshotLocation -> RawSnapshotLocation -> Ordering
RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
$cmin :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
max :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
$cmax :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
>= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c>= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
> :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c> :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
<= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c<= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
< :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c< :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
compare :: RawSnapshotLocation -> RawSnapshotLocation -> Ordering
$ccompare :: RawSnapshotLocation -> RawSnapshotLocation -> Ordering
Ord, forall x. Rep RawSnapshotLocation x -> RawSnapshotLocation
forall x. RawSnapshotLocation -> Rep RawSnapshotLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawSnapshotLocation x -> RawSnapshotLocation
$cfrom :: forall x. RawSnapshotLocation -> Rep RawSnapshotLocation x
Generic)

instance NFData RawSnapshotLocation

instance Display RawSnapshotLocation where
  display :: RawSnapshotLocation -> Utf8Builder
display (RSLCompiler WantedCompiler
compiler) = forall a. Display a => a -> Utf8Builder
display WantedCompiler
compiler
  display (RSLUrl Text
url Maybe BlobKey
Nothing) = forall a. Display a => a -> Utf8Builder
display Text
url
  display (RSLUrl Text
url (Just BlobKey
blob)) = forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blob forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
  display (RSLFilePath ResolvedPath File
resolved) = forall a. Display a => a -> Utf8Builder
display (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved)
  display (RSLSynonym SnapName
syn) = forall a. Display a => a -> Utf8Builder
display SnapName
syn

instance Pretty RawSnapshotLocation where
  pretty :: RawSnapshotLocation -> StyleDoc
pretty (RSLCompiler WantedCompiler
compiler) = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay WantedCompiler
compiler
  pretty (RSLUrl Text
url Maybe BlobKey
Nothing) = Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
url)
  pretty (RSLUrl Text
url (Just BlobKey
blob)) = [StyleDoc] -> StyleDoc
fillSep
    [ Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack  Text
url)
    , StyleDoc -> StyleDoc
parens (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay BlobKey
blob)
    ]
  pretty (RSLFilePath ResolvedPath File
resolved) =
    Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved))
  pretty (RSLSynonym SnapName
syn) =
    Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay SnapName
syn)

instance ToJSON RawSnapshotLocation where
  toJSON :: RawSnapshotLocation -> Value
toJSON (RSLCompiler WantedCompiler
compiler) = [(AesonKey, Value)] -> Value
object [AesonKey
"compiler" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= WantedCompiler
compiler]
  toJSON (RSLUrl Text
url Maybe BlobKey
mblob) = [(AesonKey, Value)] -> Value
object
    forall a b. (a -> b) -> a -> b
$ AesonKey
"url" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
url
    forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] BlobKey -> [(AesonKey, Value)]
blobKeyPairs Maybe BlobKey
mblob
  toJSON (RSLFilePath ResolvedPath File
resolved) =
    [(AesonKey, Value)] -> Value
object [AesonKey
"filepath" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved]
  toJSON (RSLSynonym SnapName
syn) = forall a. ToJSON a => a -> Value
toJSON SnapName
syn

-- | Where to load a snapshot from.

--

-- @since 0.1.0.0

data SnapshotLocation
  = SLCompiler !WantedCompiler
    -- ^ Don't use an actual snapshot, just a version of the compiler

    -- with its shipped packages.

    --

    -- @since 0.1.0.0

  | SLUrl !Text !BlobKey
    -- ^ Download the snapshot from the given URL. The optional

    -- 'BlobKey' is used for reproducibility.

    --

    -- @since 0.1.0.0

  | SLFilePath !(ResolvedPath File)
    -- ^ Snapshot at a local file path.

    --

    -- @since 0.1.0.0

  deriving (Int -> SnapshotLocation -> ShowS
[SnapshotLocation] -> ShowS
SnapshotLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotLocation] -> ShowS
$cshowList :: [SnapshotLocation] -> ShowS
show :: SnapshotLocation -> [Char]
$cshow :: SnapshotLocation -> [Char]
showsPrec :: Int -> SnapshotLocation -> ShowS
$cshowsPrec :: Int -> SnapshotLocation -> ShowS
Show, SnapshotLocation -> SnapshotLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotLocation -> SnapshotLocation -> Bool
$c/= :: SnapshotLocation -> SnapshotLocation -> Bool
== :: SnapshotLocation -> SnapshotLocation -> Bool
$c== :: SnapshotLocation -> SnapshotLocation -> Bool
Eq, Eq SnapshotLocation
SnapshotLocation -> SnapshotLocation -> Bool
SnapshotLocation -> SnapshotLocation -> Ordering
SnapshotLocation -> SnapshotLocation -> SnapshotLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
$cmin :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
max :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
$cmax :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
>= :: SnapshotLocation -> SnapshotLocation -> Bool
$c>= :: SnapshotLocation -> SnapshotLocation -> Bool
> :: SnapshotLocation -> SnapshotLocation -> Bool
$c> :: SnapshotLocation -> SnapshotLocation -> Bool
<= :: SnapshotLocation -> SnapshotLocation -> Bool
$c<= :: SnapshotLocation -> SnapshotLocation -> Bool
< :: SnapshotLocation -> SnapshotLocation -> Bool
$c< :: SnapshotLocation -> SnapshotLocation -> Bool
compare :: SnapshotLocation -> SnapshotLocation -> Ordering
$ccompare :: SnapshotLocation -> SnapshotLocation -> Ordering
Ord, forall x. Rep SnapshotLocation x -> SnapshotLocation
forall x. SnapshotLocation -> Rep SnapshotLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SnapshotLocation x -> SnapshotLocation
$cfrom :: forall x. SnapshotLocation -> Rep SnapshotLocation x
Generic)

instance NFData SnapshotLocation

instance ToJSON SnapshotLocation where
  toJSON :: SnapshotLocation -> Value
toJSON SnapshotLocation
sl = forall a. ToJSON a => a -> Value
toJSON (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)

instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where
  parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
parseJSON Value
v = Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
file Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
url Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
compiler Value
v
   where
    file :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
file = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"SLFilepath" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      Text
ufp <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"filepath"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \case
        Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidFilePathSnapshot Text
ufp
        Just Path Abs Dir
dir -> do
          Path Abs File
absolute <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
dir (Text -> [Char]
T.unpack Text
ufp)
          let fp :: ResolvedPath File
fp = forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
ufp) Path Abs File
absolute
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
fp
    url :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
url = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"SLUrl" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      Text
url' <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"url"
      SHA256
sha <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"sha256"
      FileSize
size <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"size"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url' (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
    compiler :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
compiler = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"SLCompiler" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      WantedCompiler
c <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"compiler"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
c

-- | Convert snapshot location to its "raw" equivalent.

--

-- @since 0.1.0.0

toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL (SLCompiler WantedCompiler
c) = WantedCompiler -> RawSnapshotLocation
RSLCompiler WantedCompiler
c
toRawSL (SLUrl Text
url BlobKey
blob) = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
url (forall a. a -> Maybe a
Just BlobKey
blob)
toRawSL (SLFilePath ResolvedPath File
fp) = ResolvedPath File -> RawSnapshotLocation
RSLFilePath ResolvedPath File
fp

-- | A flattened representation of all the layers in a snapshot.

--

-- @since 0.1.0.0

data RawSnapshot = RawSnapshot
  { RawSnapshot -> WantedCompiler
rsCompiler :: !WantedCompiler
    -- ^ The compiler wanted for this snapshot.

  , RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages :: !(Map PackageName RawSnapshotPackage)
    -- ^ Packages available in this snapshot for installation. This will be

    -- applied on top of any globally available packages.

  , RawSnapshot -> Set PackageName
rsDrop :: !(Set PackageName)
    -- ^ Global packages that should be dropped/ignored.

  }

-- | A flattened representation of all the layers in a snapshot.

--

-- @since 0.1.0.0

data Snapshot = Snapshot
  { Snapshot -> WantedCompiler
snapshotCompiler :: !WantedCompiler
    -- ^ The compiler wanted for this snapshot.

  , Snapshot -> Map PackageName SnapshotPackage
snapshotPackages :: !(Map PackageName SnapshotPackage)
    -- ^ Packages available in this snapshot for installation. This will be

    -- applied on top of any globally available packages.

  , Snapshot -> Set PackageName
snapshotDrop :: !(Set PackageName)
    -- ^ Global packages that should be dropped/ignored.

  }

-- | Settings for a package found in a snapshot.

--

-- @since 0.1.0.0

data RawSnapshotPackage = RawSnapshotPackage
  { RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation :: !RawPackageLocationImmutable
    -- ^ Where to get the package from

  , RawSnapshotPackage -> Map FlagName Bool
rspFlags :: !(Map FlagName Bool)
    -- ^ Same as 'slFlags'

  , RawSnapshotPackage -> Bool
rspHidden :: !Bool
    -- ^ Same as 'slHidden'

  , RawSnapshotPackage -> [Text]
rspGhcOptions :: ![Text]
    -- ^ Same as 'slGhcOptions'

  }

-- | Settings for a package found in a snapshot.

--

-- @since 0.1.0.0

data SnapshotPackage = SnapshotPackage
  { SnapshotPackage -> PackageLocationImmutable
spLocation :: !PackageLocationImmutable
    -- ^ Where to get the package from

  , SnapshotPackage -> Map FlagName Bool
spFlags :: !(Map FlagName Bool)
    -- ^ Same as 'slFlags'

  , SnapshotPackage -> Bool
spHidden :: !Bool
    -- ^ Same as 'slHidden'

  , SnapshotPackage -> [Text]
spGhcOptions :: ![Text]
    -- ^ Same as 'slGhcOptions'

  }
  deriving Int -> SnapshotPackage -> ShowS
[SnapshotPackage] -> ShowS
SnapshotPackage -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotPackage] -> ShowS
$cshowList :: [SnapshotPackage] -> ShowS
show :: SnapshotPackage -> [Char]
$cshow :: SnapshotPackage -> [Char]
showsPrec :: Int -> SnapshotPackage -> ShowS
$cshowsPrec :: Int -> SnapshotPackage -> ShowS
Show

-- | A single layer of a snapshot, i.e. a specific YAML configuration file.

--

-- @since 0.1.0.0

data RawSnapshotLayer = RawSnapshotLayer
  { RawSnapshotLayer -> RawSnapshotLocation
rslParent :: !RawSnapshotLocation
    -- ^ The sl to extend from. This is either a specific compiler, or a

    -- @SnapshotLocation@ which gives us more information (like packages).

    -- Ultimately, we'll end up with a @CompilerVersion@.

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler :: !(Maybe WantedCompiler)
    -- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if

    -- using 'SLCompiler'.

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations :: ![RawPackageLocationImmutable]
    -- ^ Where to grab all of the packages from.

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> Set PackageName
rslDropPackages :: !(Set PackageName)
    -- ^ Packages present in the parent which should not be included here.

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags :: !(Map PackageName (Map FlagName Bool))
    -- ^ Flag values to override from the defaults

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> Map PackageName Bool
rslHidden :: !(Map PackageName Bool)
    -- ^ Packages which should be hidden when registering. This will affect, for

    -- example, the import parser in the script command. We use a 'Map' instead

    -- of just a 'Set' to allow overriding the hidden settings in a parent sl.

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions :: !(Map PackageName [Text])
    -- ^ GHC options per package

    --

    -- @since 0.1.0.0

  , RawSnapshotLayer -> Maybe UTCTime
rslPublishTime :: !(Maybe UTCTime)
    -- ^ See 'slPublishTime'

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> RawSnapshotLayer -> ShowS
[RawSnapshotLayer] -> ShowS
RawSnapshotLayer -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawSnapshotLayer] -> ShowS
$cshowList :: [RawSnapshotLayer] -> ShowS
show :: RawSnapshotLayer -> [Char]
$cshow :: RawSnapshotLayer -> [Char]
showsPrec :: Int -> RawSnapshotLayer -> ShowS
$cshowsPrec :: Int -> RawSnapshotLayer -> ShowS
Show, RawSnapshotLayer -> RawSnapshotLayer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
$c/= :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
== :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
$c== :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
Eq, forall x. Rep RawSnapshotLayer x -> RawSnapshotLayer
forall x. RawSnapshotLayer -> Rep RawSnapshotLayer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawSnapshotLayer x -> RawSnapshotLayer
$cfrom :: forall x. RawSnapshotLayer -> Rep RawSnapshotLayer x
Generic)

instance NFData RawSnapshotLayer

instance ToJSON RawSnapshotLayer where
  toJSON :: RawSnapshotLayer -> Value
toJSON RawSnapshotLayer
rsnap = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [AesonKey
"resolver" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsnap]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\WantedCompiler
compiler -> [AesonKey
"compiler" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= WantedCompiler
compiler]) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsnap)
    , [AesonKey
"packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsnap]
    , [ AesonKey
"drop-packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. a -> CabalString a
CabalString (RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsnap)
      | Bool -> Bool
not (forall a. Set a -> Bool
Set.null (RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsnap))
      ]
    , [ AesonKey
"flags" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsnap))
      | Bool -> Bool
not(forall k a. Map k a -> Bool
Map.null (RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsnap))
      ]
    , [ AesonKey
"hidden" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsnap)
      | Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null (RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsnap))
      ]
    , [ AesonKey
"ghc-options" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsnap)
      | Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null (RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsnap))
      ]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\UTCTime
time -> [AesonKey
"publish-time" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= UTCTime
time]) (RawSnapshotLayer -> Maybe UTCTime
rslPublishTime RawSnapshotLayer
rsnap)
    ]

instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where
  parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
parseJSON = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"Snapshot" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Maybe Text
_ :: Maybe Text <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"name" -- avoid warnings for old snapshot format

    Maybe WantedCompiler
mcompiler <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"compiler"
    Maybe (Unresolved RawSnapshotLocation)
mresolver <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
...:? [Text
"snapshot", Text
"resolver"]
    Unresolved (RawSnapshotLocation, Maybe WantedCompiler)
unresolvedSnapshotParent <-
      case (Maybe WantedCompiler
mcompiler, Maybe (Unresolved RawSnapshotLocation)
mresolver) of
        (Maybe WantedCompiler
Nothing, Maybe (Unresolved RawSnapshotLocation)
Nothing) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Snapshot must have either resolver or compiler"
        (Just WantedCompiler
compiler, Maybe (Unresolved RawSnapshotLocation)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (WantedCompiler -> RawSnapshotLocation
RSLCompiler WantedCompiler
compiler, forall a. Maybe a
Nothing)
        (Maybe WantedCompiler
_, Just (Unresolved Maybe (Path Abs Dir) -> IO RawSnapshotLocation
usl)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
          RawSnapshotLocation
sl <- Maybe (Path Abs Dir) -> IO RawSnapshotLocation
usl Maybe (Path Abs Dir)
mdir
          case (RawSnapshotLocation
sl, Maybe WantedCompiler
mcompiler) of
            (RSLCompiler WantedCompiler
c1, Just WantedCompiler
c2) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ WantedCompiler -> WantedCompiler -> PantryException
InvalidOverrideCompiler WantedCompiler
c1 WantedCompiler
c2
            (RawSnapshotLocation, Maybe WantedCompiler)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation
sl, Maybe WantedCompiler
mcompiler)

    [Unresolved (NonEmpty RawPackageLocationImmutable)]
unresolvedLocs <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"packages" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= [])
    Set PackageName
rslDropPackages <- forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. CabalString a -> a
unCabalString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"drop-packages" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall a. Set a
Set.empty)
    Map PackageName (Map FlagName Bool)
rslFlags <- forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"flags" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall k a. Map k a
Map.empty)
    Map PackageName Bool
rslHidden <- forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"hidden" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall k a. Map k a
Map.empty)
    Map PackageName [Text]
rslGhcOptions <- forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"ghc-options" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall k a. Map k a
Map.empty)
    Maybe UTCTime
rslPublishTime <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"publish-time"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\[RawPackageLocationImmutable]
rslLocations (RawSnapshotLocation
rslParent, Maybe WantedCompiler
rslCompiler) -> RawSnapshotLayer {[RawPackageLocationImmutable]
Maybe UTCTime
Maybe WantedCompiler
Set PackageName
Map PackageName Bool
Map PackageName [Text]
Map PackageName (Map FlagName Bool)
RawSnapshotLocation
rslCompiler :: Maybe WantedCompiler
rslParent :: RawSnapshotLocation
rslLocations :: [RawPackageLocationImmutable]
rslPublishTime :: Maybe UTCTime
rslGhcOptions :: Map PackageName [Text]
rslHidden :: Map PackageName Bool
rslFlags :: Map PackageName (Map FlagName Bool)
rslDropPackages :: Set PackageName
rslPublishTime :: Maybe UTCTime
rslGhcOptions :: Map PackageName [Text]
rslHidden :: Map PackageName Bool
rslFlags :: Map PackageName (Map FlagName Bool)
rslDropPackages :: Set PackageName
rslLocations :: [RawPackageLocationImmutable]
rslCompiler :: Maybe WantedCompiler
rslParent :: RawSnapshotLocation
..})
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. NonEmpty a -> [a]
NE.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Unresolved (NonEmpty RawPackageLocationImmutable)]
unresolvedLocs)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Unresolved (RawSnapshotLocation, Maybe WantedCompiler)
unresolvedSnapshotParent

-- | A single layer of a snapshot, i.e. a specific YAML configuration file.

--

-- @since 0.1.0.0

data SnapshotLayer = SnapshotLayer
  { SnapshotLayer -> SnapshotLocation
slParent :: !SnapshotLocation
    -- ^ The sl to extend from. This is either a specific compiler, or a

    -- @SnapshotLocation@ which gives us more information (like packages).

    -- Ultimately, we'll end up with a @CompilerVersion@.

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> Maybe WantedCompiler
slCompiler :: !(Maybe WantedCompiler)
    -- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if

    -- using 'SLCompiler'.

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> [PackageLocationImmutable]
slLocations :: ![PackageLocationImmutable]
    -- ^ Where to grab all of the packages from.

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> Set PackageName
slDropPackages :: !(Set PackageName)
    -- ^ Packages present in the parent which should not be included here.

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags :: !(Map PackageName (Map FlagName Bool))
    -- ^ Flag values to override from the defaults

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> Map PackageName Bool
slHidden :: !(Map PackageName Bool)
    -- ^ Packages which should be hidden when registering. This will affect, for

    -- example, the import parser in the script command. We use a 'Map' instead

    -- of just a 'Set' to allow overriding the hidden settings in a parent sl.

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> Map PackageName [Text]
slGhcOptions :: !(Map PackageName [Text])
    -- ^ GHC options per package

    --

    -- @since 0.1.0.0

  , SnapshotLayer -> Maybe UTCTime
slPublishTime :: !(Maybe UTCTime)
    -- ^ Publication timestamp for this snapshot. This field is optional, and is

    -- for informational purposes only.

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> SnapshotLayer -> ShowS
[SnapshotLayer] -> ShowS
SnapshotLayer -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotLayer] -> ShowS
$cshowList :: [SnapshotLayer] -> ShowS
show :: SnapshotLayer -> [Char]
$cshow :: SnapshotLayer -> [Char]
showsPrec :: Int -> SnapshotLayer -> ShowS
$cshowsPrec :: Int -> SnapshotLayer -> ShowS
Show, SnapshotLayer -> SnapshotLayer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotLayer -> SnapshotLayer -> Bool
$c/= :: SnapshotLayer -> SnapshotLayer -> Bool
== :: SnapshotLayer -> SnapshotLayer -> Bool
$c== :: SnapshotLayer -> SnapshotLayer -> Bool
Eq, forall x. Rep SnapshotLayer x -> SnapshotLayer
forall x. SnapshotLayer -> Rep SnapshotLayer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SnapshotLayer x -> SnapshotLayer
$cfrom :: forall x. SnapshotLayer -> Rep SnapshotLayer x
Generic)

instance ToJSON SnapshotLayer where
  toJSON :: SnapshotLayer -> Value
toJSON SnapshotLayer
snap = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [AesonKey
"resolver" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SnapshotLayer -> SnapshotLocation
slParent SnapshotLayer
snap]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\WantedCompiler
compiler -> [AesonKey
"compiler" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= WantedCompiler
compiler]) (SnapshotLayer -> Maybe WantedCompiler
slCompiler SnapshotLayer
snap)
    , [AesonKey
"packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SnapshotLayer -> [PackageLocationImmutable]
slLocations SnapshotLayer
snap]
    , [ AesonKey
"drop-packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. a -> CabalString a
CabalString (SnapshotLayer -> Set PackageName
slDropPackages SnapshotLayer
snap)
      | Bool -> Bool
not (forall a. Set a -> Bool
Set.null (SnapshotLayer -> Set PackageName
slDropPackages SnapshotLayer
snap))
      ]
    , [ AesonKey
"flags" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags SnapshotLayer
snap))
      | Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null (SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags SnapshotLayer
snap))
      ]
    , [ AesonKey
"hidden" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (SnapshotLayer -> Map PackageName Bool
slHidden SnapshotLayer
snap)
      | Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null (SnapshotLayer -> Map PackageName Bool
slHidden SnapshotLayer
snap))
      ]
    , [ AesonKey
"ghc-options" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (SnapshotLayer -> Map PackageName [Text]
slGhcOptions SnapshotLayer
snap)
      | Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null (SnapshotLayer -> Map PackageName [Text]
slGhcOptions SnapshotLayer
snap))
      ]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\UTCTime
time -> [AesonKey
"publish-time" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= UTCTime
time]) (SnapshotLayer -> Maybe UTCTime
slPublishTime SnapshotLayer
snap)
    ]

-- | Convert snapshot layer into its "raw" equivalent.

--

-- @since 0.1.0.0

toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer
toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer
toRawSnapshotLayer SnapshotLayer
sl = RawSnapshotLayer
  { rslParent :: RawSnapshotLocation
rslParent = SnapshotLocation -> RawSnapshotLocation
toRawSL (SnapshotLayer -> SnapshotLocation
slParent SnapshotLayer
sl)
  , rslCompiler :: Maybe WantedCompiler
rslCompiler = SnapshotLayer -> Maybe WantedCompiler
slCompiler SnapshotLayer
sl
  , rslLocations :: [RawPackageLocationImmutable]
rslLocations = forall a b. (a -> b) -> [a] -> [b]
map PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (SnapshotLayer -> [PackageLocationImmutable]
slLocations SnapshotLayer
sl)
  , rslDropPackages :: Set PackageName
rslDropPackages = SnapshotLayer -> Set PackageName
slDropPackages SnapshotLayer
sl
  , rslFlags :: Map PackageName (Map FlagName Bool)
rslFlags = SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags SnapshotLayer
sl
  , rslHidden :: Map PackageName Bool
rslHidden = SnapshotLayer -> Map PackageName Bool
slHidden SnapshotLayer
sl
  , rslGhcOptions :: Map PackageName [Text]
rslGhcOptions = SnapshotLayer -> Map PackageName [Text]
slGhcOptions SnapshotLayer
sl
  , rslPublishTime :: Maybe UTCTime
rslPublishTime = SnapshotLayer -> Maybe UTCTime
slPublishTime SnapshotLayer
sl
  }

-- | An arbitrary hash for a snapshot, used for finding module names in a

-- snapshot. Mostly intended for Stack's usage.

--

-- @since 0.1.0.0

newtype SnapshotCacheHash = SnapshotCacheHash { SnapshotCacheHash -> SHA256
unSnapshotCacheHash :: SHA256}
  deriving (Int -> SnapshotCacheHash -> ShowS
[SnapshotCacheHash] -> ShowS
SnapshotCacheHash -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotCacheHash] -> ShowS
$cshowList :: [SnapshotCacheHash] -> ShowS
show :: SnapshotCacheHash -> [Char]
$cshow :: SnapshotCacheHash -> [Char]
showsPrec :: Int -> SnapshotCacheHash -> ShowS
$cshowsPrec :: Int -> SnapshotCacheHash -> ShowS
Show)

-- | Get the path to the global hints cache file

getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile :: forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile = do
  Path Abs Dir
root <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Path Abs Dir
pcRootDir
  Path Rel File
globalHintsRelFile <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
"global-hints-cache.yaml"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
globalHintsRelFile

-- | Creates BlobKey for an input ByteString

--

-- @since 0.1.0.0

bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey ByteString
bs =
  SHA256 -> FileSize -> BlobKey
BlobKey (ByteString -> SHA256
SHA256.hashBytes ByteString
bs) (Word -> FileSize
FileSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)))

-- | Warn if the package uses 'PCHpack'.

--

-- @since 0.4.0.0

warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile :: forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
loc =
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"DEPRECATED: The package at "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" does not include a cabal file.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Instead, it includes an hpack package.yaml file for generating a cabal file.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"This usage is deprecated; please see "
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"https://github.com/commercialhaskell/stack/issues/5210.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Support for this workflow will be removed in the future.\n"