{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}

module Stack.Types.Resolver
  (AbstractResolver(..)
  ,readAbstractResolver
  ,Snapshots (..)
  ) where

import           Pantry.Internal.AesonExtended
                 (FromJSON, parseJSON,
                  withObject, (.:), withText)
import qualified Data.HashMap.Strict as HashMap
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

-- | 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure AbstractResolver
ARGlobal
        String
"nightly" -> Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
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 (f :: * -> *) a. Applicative f => a -> f a
pure AbstractResolver
ARLatestNightly
        String
"lts" -> Unresolved AbstractResolver -> ReadM (Unresolved AbstractResolver)
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 (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 (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 (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 (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)

data BuildPlanTypesException
    = ParseResolverException !Text
    | FilepathInDownloadedSnapshot !Text
    deriving Typeable
instance Exception BuildPlanTypesException
instance Show BuildPlanTypesException where
    show :: BuildPlanTypesException -> String
show (ParseResolverException Text
t) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ 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. "
        , String
"See https://www.stackage.org/snapshots for a complete list."
        ]
    show (FilepathInDownloadedSnapshot Text
url) = [String] -> String
unlines
        [ 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
        ]

-- | 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
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 = 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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([IntMap Int] -> IntMap Int)
-> Parser [IntMap Int] -> Parser (IntMap Int)
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 (((Text, Value) -> Parser (IntMap Int))
-> [(Text, Value)] -> Parser [IntMap Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Value -> Parser (IntMap Int)
parseLTS (Value -> Parser (IntMap Int))
-> ((Text, Value) -> Value) -> (Text, Value) -> Parser (IntMap Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> Value
forall a b. (a, b) -> b
snd)
                ([(Text, Value)] -> Parser [IntMap Int])
-> [(Text, Value)] -> Parser [IntMap Int]
forall a b. (a -> b) -> a -> b
$ ((Text, Value) -> Bool) -> [(Text, Value)] -> [(Text, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Bool
isLTS (Text -> Bool) -> ((Text, Value) -> Text) -> (Text, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> Text
forall a b. (a, b) -> a
fst)
                ([(Text, Value)] -> [(Text, Value)])
-> [(Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.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 (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Day) -> String -> m Day
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                Right (LTS Int
_ Int
_) -> String -> m Day
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected LTS value"
                Right (Nightly Day
d) -> Day -> m Day
forall (m :: * -> *) a. Monad m => a -> m a
return Day
d

        isLTS :: Text -> Bool
isLTS = (Text
"lts-" Text -> Text -> Bool
`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 (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 a. Show a => a -> String
show SomeException
e
                Right (LTS Int
x Int
y) -> IntMap Int -> Parser (IntMap Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected nightly value"