{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Stack.Types.Resolver
( AbstractResolver (..)
, readAbstractResolver
, Snapshots (..)
) where
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Text as T
import Data.Text.Read ( decimal )
import Data.Time ( Day )
import Options.Applicative ( ReadM )
import qualified Options.Applicative.Types as OA
import Pantry.Internal.AesonExtended
( FromJSON, parseJSON, withObject, (.:), withText )
import Stack.Prelude
data TypesResolverException
= ParseResolverException !Text
| FilepathInDownloadedSnapshot !Text
deriving (Int -> TypesResolverException -> ShowS
[TypesResolverException] -> ShowS
TypesResolverException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypesResolverException] -> ShowS
$cshowList :: [TypesResolverException] -> ShowS
show :: TypesResolverException -> String
$cshow :: TypesResolverException -> String
showsPrec :: Int -> TypesResolverException -> ShowS
$cshowsPrec :: Int -> TypesResolverException -> ShowS
Show, Typeable)
instance Exception TypesResolverException where
displayException :: TypesResolverException -> String
displayException (ParseResolverException Text
t) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Error: [S-8787]\n"
, String
"Invalid resolver value: "
, Text -> String
T.unpack Text
t
, String
". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, \
\ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. See \
\https://www.stackage.org/snapshots for a complete list."
]
displayException (FilepathInDownloadedSnapshot Text
url) = [String] -> String
unlines
[ String
"Error: [S-4865]"
, String
"Downloaded snapshot specified a 'resolver: { location: filepath }' "
, String
"field, but filepaths are not allowed in downloaded snapshots.\n"
, String
"Filepath specified: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
url
]
data AbstractResolver
= ARLatestNightly
| ARLatestLTS
| ARLatestLTSMajor !Int
| ARResolver !RawSnapshotLocation
| ARGlobal
instance Show AbstractResolver where
show :: AbstractResolver -> String
show = Text -> String
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 AbstractResolver where
display :: AbstractResolver -> Utf8Builder
display AbstractResolver
ARLatestNightly = Utf8Builder
"nightly"
display AbstractResolver
ARLatestLTS = Utf8Builder
"lts"
display (ARLatestLTSMajor Int
x) = Utf8Builder
"lts-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x
display (ARResolver RawSnapshotLocation
usl) = forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
usl
display AbstractResolver
ARGlobal = Utf8Builder
"global"
readAbstractResolver :: ReadM (Unresolved AbstractResolver)
readAbstractResolver :: ReadM (Unresolved AbstractResolver)
readAbstractResolver = do
String
s <- ReadM String
OA.readerAsk
case String
s of
String
"global" -> 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 AbstractResolver
ARGlobal
String
"nightly" -> 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 AbstractResolver
ARLatestNightly
String
"lts" -> 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 AbstractResolver
ARLatestLTS
Char
'l':Char
't':Char
's':Char
'-':String
x | Right (Int
x', Text
"") <- forall a. Integral a => Reader a
decimal forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
x ->
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
$ Int -> AbstractResolver
ARLatestLTSMajor Int
x'
String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> AbstractResolver
ARResolver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation (String -> Text
T.pack String
s)
data Snapshots = Snapshots
{ Snapshots -> Day
snapshotsNightly :: !Day
, Snapshots -> IntMap Int
snapshotsLts :: !(IntMap Int)
}
deriving Int -> Snapshots -> ShowS
[Snapshots] -> ShowS
Snapshots -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Snapshots] -> ShowS
$cshowList :: [Snapshots] -> ShowS
show :: Snapshots -> String
$cshow :: Snapshots -> String
showsPrec :: Int -> Snapshots -> ShowS
$cshowsPrec :: Int -> Snapshots -> ShowS
Show
instance FromJSON Snapshots where
parseJSON :: Value -> Parser Snapshots
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Snapshots" forall a b. (a -> b) -> a -> b
$ \Object
o -> Day -> IntMap Int -> Snapshots
Snapshots
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"nightly" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadFail m => Text -> m Day
parseNightly)
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 (f :: * -> *) a. Foldable f => f (IntMap a) -> IntMap a
IntMap.unions (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Value -> Parser (IntMap Int)
parseLTS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Bool
isLTS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o)
where
parseNightly :: Text -> m Day
parseNightly Text
t =
case forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t of
Left SomeException
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e
Right (LTS Int
_ Int
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected LTS value"
Right (Nightly Day
d) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
d
isLTS :: Text -> Bool
isLTS = (Text
"lts-" `T.isPrefixOf`)
parseLTS :: Value -> Parser (IntMap Int)
parseLTS = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"LTS" forall a b. (a -> b) -> a -> b
$ \Text
t ->
case forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t of
Left SomeException
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e
Right (LTS Int
x Int
y) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> IntMap a
IntMap.singleton Int
x Int
y
Right (Nightly Day
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected nightly value"