{-# 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           Data.Aeson.Types
                   ( FromJSON, parseJSON, withObject, withText )
import           Data.Aeson.WarningParser ( (.:) )
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           Stack.Prelude

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Types.Resolver" module.

data TypesResolverException
  = ParseResolverException !Text
  | FilepathInDownloadedSnapshot !Text
  deriving (Int -> TypesResolverException -> ShowS
[TypesResolverException] -> ShowS
TypesResolverException -> String
(Int -> TypesResolverException -> ShowS)
-> (TypesResolverException -> String)
-> ([TypesResolverException] -> ShowS)
-> Show TypesResolverException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypesResolverException -> ShowS
showsPrec :: Int -> TypesResolverException -> ShowS
$cshow :: TypesResolverException -> String
show :: TypesResolverException -> String
$cshowList :: [TypesResolverException] -> ShowS
showList :: [TypesResolverException] -> ShowS
Show, Typeable)

instance Exception TypesResolverException where
  displayException :: TypesResolverException -> String
displayException (ParseResolverException Text
t) = [String] -> String
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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
url
    ]

-- | Either an actual resolver value, or an abstract description of one (e.g.,

-- latest nightly).

data AbstractResolver
  = ARLatestNightly
  | ARLatestLTS
  | ARLatestLTSMajor !Int
  | ARResolver !RawSnapshotLocation
  | ARGlobal

instance Show AbstractResolver where
  show :: AbstractResolver -> String
show = Text -> String
T.unpack (Text -> String)
-> (AbstractResolver -> Text) -> AbstractResolver -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text)
-> (AbstractResolver -> Utf8Builder) -> AbstractResolver -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractResolver -> Utf8Builder
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-" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
x
  display (ARResolver RawSnapshotLocation
usl) = RawSnapshotLocation -> Utf8Builder
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" -> Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved AbstractResolver
 -> ReadM (Unresolved AbstractResolver))
-> Unresolved AbstractResolver
-> ReadM (Unresolved AbstractResolver)
forall a b. (a -> b) -> a -> b
$ AbstractResolver -> Unresolved AbstractResolver
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractResolver
ARGlobal
    String
"nightly" -> Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved AbstractResolver
 -> ReadM (Unresolved AbstractResolver))
-> Unresolved AbstractResolver
-> ReadM (Unresolved AbstractResolver)
forall a b. (a -> b) -> a -> b
$ AbstractResolver -> Unresolved AbstractResolver
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractResolver
ARLatestNightly
    String
"lts" -> Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved AbstractResolver
 -> ReadM (Unresolved AbstractResolver))
-> Unresolved AbstractResolver
-> ReadM (Unresolved AbstractResolver)
forall a b. (a -> b) -> a -> b
$ AbstractResolver -> Unresolved AbstractResolver
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractResolver
ARLatestLTS
    Char
'l':Char
't':Char
's':Char
'-':String
x | Right (Int
x', Text
"") <- Reader Int
forall a. Integral a => Reader a
decimal Reader Int -> Reader Int
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
x ->
        Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved AbstractResolver
 -> ReadM (Unresolved AbstractResolver))
-> Unresolved AbstractResolver
-> ReadM (Unresolved AbstractResolver)
forall a b. (a -> b) -> a -> b
$ AbstractResolver -> Unresolved AbstractResolver
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractResolver -> Unresolved AbstractResolver)
-> AbstractResolver -> Unresolved AbstractResolver
forall a b. (a -> b) -> a -> b
$ Int -> AbstractResolver
ARLatestLTSMajor Int
x'
    String
_ -> Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved AbstractResolver
 -> ReadM (Unresolved AbstractResolver))
-> Unresolved AbstractResolver
-> ReadM (Unresolved AbstractResolver)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> AbstractResolver
ARResolver (RawSnapshotLocation -> AbstractResolver)
-> Unresolved RawSnapshotLocation -> Unresolved AbstractResolver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation (String -> Text
T.pack String
s)

-- | Most recent Nightly and newest LTS version per major release.

data Snapshots = Snapshots
  { Snapshots -> Day
snapshotsNightly :: !Day
  , Snapshots -> IntMap Int
snapshotsLts     :: !(IntMap Int)
  }
  deriving Int -> Snapshots -> ShowS
[Snapshots] -> ShowS
Snapshots -> String
(Int -> Snapshots -> ShowS)
-> (Snapshots -> String)
-> ([Snapshots] -> ShowS)
-> Show Snapshots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Snapshots -> ShowS
showsPrec :: Int -> Snapshots -> ShowS
$cshow :: Snapshots -> String
show :: Snapshots -> String
$cshowList :: [Snapshots] -> ShowS
showList :: [Snapshots] -> ShowS
Show

instance FromJSON Snapshots where
  parseJSON :: Value -> Parser Snapshots
parseJSON = String -> (Object -> Parser Snapshots) -> Value -> Parser Snapshots
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Snapshots" ((Object -> Parser Snapshots) -> Value -> Parser Snapshots)
-> (Object -> Parser Snapshots) -> Value -> Parser Snapshots
forall a b. (a -> b) -> a -> b
$ \Object
o -> Day -> IntMap Int -> Snapshots
Snapshots
    (Day -> IntMap Int -> Snapshots)
-> Parser Day -> Parser (IntMap Int -> Snapshots)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"nightly" Parser Text -> (Text -> Parser Day) -> Parser Day
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Parser Day
forall {m :: * -> *}. MonadFail m => Text -> m Day
parseNightly)
    Parser (IntMap Int -> Snapshots)
-> Parser (IntMap Int) -> Parser Snapshots
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([IntMap Int] -> IntMap Int)
-> Parser [IntMap Int] -> Parser (IntMap Int)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [IntMap Int] -> IntMap Int
forall (f :: * -> *) a. Foldable f => f (IntMap a) -> IntMap a
IntMap.unions (((Key, Value) -> Parser (IntMap Int))
-> [(Key, Value)] -> Parser [IntMap Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Value -> Parser (IntMap Int)
parseLTS (Value -> Parser (IntMap Int))
-> ((Key, Value) -> Value) -> (Key, Value) -> Parser (IntMap Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Value
forall a b. (a, b) -> b
snd)
          ([(Key, Value)] -> Parser [IntMap Int])
-> [(Key, Value)] -> Parser [IntMap Int]
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Bool) -> [(Key, Value)] -> [(Key, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Bool
isLTS (Text -> Bool) -> ((Key, Value) -> Text) -> (Key, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText (Key -> Text) -> ((Key, Value) -> Key) -> (Key, Value) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Key
forall a b. (a, b) -> a
fst)
          ([(Key, Value)] -> [(Key, Value)])
-> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o)
   where
    parseNightly :: Text -> m Day
parseNightly Text
t =
      case Text -> Either SomeException SnapName
forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t of
        Left SomeException
e -> String -> m Day
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Day) -> String -> m Day
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
        Right (LTS Int
_ Int
_) -> String -> m Day
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected LTS value"
        Right (Nightly Day
d) -> Day -> m Day
forall a. a -> m a
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 = String
-> (Text -> Parser (IntMap Int)) -> Value -> Parser (IntMap Int)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"LTS" ((Text -> Parser (IntMap Int)) -> Value -> Parser (IntMap Int))
-> (Text -> Parser (IntMap Int)) -> Value -> Parser (IntMap Int)
forall a b. (a -> b) -> a -> b
$ \Text
t ->
      case Text -> Either SomeException SnapName
forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t of
        Left SomeException
e -> String -> Parser (IntMap Int)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (IntMap Int)) -> String -> Parser (IntMap Int)
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
        Right (LTS Int
x Int
y) -> IntMap Int -> Parser (IntMap Int)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap Int -> Parser (IntMap Int))
-> IntMap Int -> Parser (IntMap Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IntMap Int
forall a. Int -> a -> IntMap a
IntMap.singleton Int
x Int
y
        Right (Nightly Day
_) -> String -> Parser (IntMap Int)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected nightly value"