-- |
-- Module: Staversion.Internal.BuildPlan.Pantry
-- Description: Pantry YAML format of build plan
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
--
-- @since 0.2.4.0
module Staversion.Internal.BuildPlan.Pantry
  ( PantryBuildPlanMap,
    PantryName,
    pantryCompiler,
    pantryName,
    toBuildPlanMap,
    coresToBuildPlanMap,
    parseBuildPlanMapYAML,
    fetchBuildPlanMapYAML
  ) where

import Control.Applicative ((<$>), (<*>), empty, (<|>))
import Control.Monad (void)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Aeson (FromJSON(..), Value(..), (.:), (.:!))
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>))
import Data.Text (pack, Text)
import qualified Data.Yaml as Yaml

import Staversion.Internal.BuildPlan.BuildPlanMap
  ( BuildPlanMap,
    HasVersions(..),
  )
import qualified Staversion.Internal.BuildPlan.BuildPlanMap as BuildPlanMap
import Staversion.Internal.BuildPlan.Core
  ( Compiler(..),
    CoreBuildPlanMap(..),
    CompilerVersion(..),
    CompilerCores
  )
import Staversion.Internal.BuildPlan.Parser (parserVersion, manyTillWithEnd)
import Staversion.Internal.BuildPlan.Stackage (ExactResolver(..))
import qualified Staversion.Internal.Megaparsec as P
import Staversion.Internal.HTTP (Manager, fetchURL)
import Staversion.Internal.Query (ErrorMsg, PackageName)
import Staversion.Internal.Version (Version)

-- | Name of a pantry snapshot
type PantryName = Text

-- | A build plan map loaded from a Pantry YAML file. This is not a
-- complete 'BuildPlanMap', because it implicitly refers to
-- 'CoreBuildPlanMap'. That's why its data constructor is not
-- exported.
data PantryBuildPlanMap =
  PantryBuildPlanMap
  { PantryBuildPlanMap -> Maybe Text
pantryName :: Maybe PantryName,
    PantryBuildPlanMap -> Compiler
pantryCompiler :: Compiler,
    PantryBuildPlanMap -> BuildPlanMap
pantryMap :: BuildPlanMap
  }

instance HasVersions PantryBuildPlanMap where
  packageVersion :: PantryBuildPlanMap -> Text -> Maybe Version
packageVersion PantryBuildPlanMap
pbp = forall t. HasVersions t => t -> Text -> Maybe Version
packageVersion (PantryBuildPlanMap -> BuildPlanMap
pantryMap PantryBuildPlanMap
pbp)

instance FromJSON PantryBuildPlanMap where
  parseJSON :: Value -> Parser PantryBuildPlanMap
parseJSON (Object Object
o) =
    Maybe Text -> Compiler -> BuildPlanMap -> PantryBuildPlanMap
PantryBuildPlanMap
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:! Key
"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 PantryCompiler -> Compiler
unPantryCompiler Parser PantryCompiler
parserCompiler
    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 [PantryPackage] -> BuildPlanMap
fromPantryPackageList (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"packages")
    where
      parserCompiler :: Parser PantryCompiler
parserCompiler = (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"compiler") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PantryCompiler
parserResolverCompiler
      parserResolverCompiler :: Parser PantryCompiler
parserResolverCompiler = do
        Object
res <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"resolver"
        Object
res forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"compiler"
  parseJSON Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty

-- | Internal type to parse a package in Pantry YAML.
newtype PantryPackage = PantryPackage { PantryPackage -> (Text, Version)
unPantryPackage :: (PackageName, Version) }
  deriving (Int -> PantryPackage -> ShowS
[PantryPackage] -> ShowS
PantryPackage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PantryPackage] -> ShowS
$cshowList :: [PantryPackage] -> ShowS
show :: PantryPackage -> String
$cshow :: PantryPackage -> String
showsPrec :: Int -> PantryPackage -> ShowS
$cshowsPrec :: Int -> PantryPackage -> ShowS
Show,PantryPackage -> PantryPackage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PantryPackage -> PantryPackage -> Bool
$c/= :: PantryPackage -> PantryPackage -> Bool
== :: PantryPackage -> PantryPackage -> Bool
$c== :: PantryPackage -> PantryPackage -> Bool
Eq,Eq PantryPackage
PantryPackage -> PantryPackage -> Bool
PantryPackage -> PantryPackage -> Ordering
PantryPackage -> PantryPackage -> PantryPackage
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 :: PantryPackage -> PantryPackage -> PantryPackage
$cmin :: PantryPackage -> PantryPackage -> PantryPackage
max :: PantryPackage -> PantryPackage -> PantryPackage
$cmax :: PantryPackage -> PantryPackage -> PantryPackage
>= :: PantryPackage -> PantryPackage -> Bool
$c>= :: PantryPackage -> PantryPackage -> Bool
> :: PantryPackage -> PantryPackage -> Bool
$c> :: PantryPackage -> PantryPackage -> Bool
<= :: PantryPackage -> PantryPackage -> Bool
$c<= :: PantryPackage -> PantryPackage -> Bool
< :: PantryPackage -> PantryPackage -> Bool
$c< :: PantryPackage -> PantryPackage -> Bool
compare :: PantryPackage -> PantryPackage -> Ordering
$ccompare :: PantryPackage -> PantryPackage -> Ordering
Ord)

fromPantryPackageList :: [PantryPackage] -> BuildPlanMap
fromPantryPackageList :: [PantryPackage] -> BuildPlanMap
fromPantryPackageList = [(Text, Version)] -> BuildPlanMap
BuildPlanMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map PantryPackage -> (Text, Version)
unPantryPackage

instance FromJSON PantryPackage where
  parseJSON :: Value -> Parser PantryPackage
parseJSON (Object Object
o) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Version) -> PantryPackage
PantryPackage forall a b. (a -> b) -> a -> b
$ Text -> Parser (Text, Version)
parsePText forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hackage")
    where
      parsePText :: Text -> Aeson.Parser (PackageName, Version)
      parsePText :: Text -> Parser (Text, Version)
parsePText Text
t = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.runParser Parser (Text, Version)
the_parser String
"" Text
t
      the_parser :: Parser (Text, Version)
the_parser = Parser () -> Parser (Text, Version)
parserPackage (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'@')
  parseJSON Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty

-- | Internal type to parse a compiler in Pantry YAML.
newtype PantryCompiler = PantryCompiler { PantryCompiler -> Compiler
unPantryCompiler :: Compiler }
  deriving (Int -> PantryCompiler -> ShowS
[PantryCompiler] -> ShowS
PantryCompiler -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PantryCompiler] -> ShowS
$cshowList :: [PantryCompiler] -> ShowS
show :: PantryCompiler -> String
$cshow :: PantryCompiler -> String
showsPrec :: Int -> PantryCompiler -> ShowS
$cshowsPrec :: Int -> PantryCompiler -> ShowS
Show,PantryCompiler -> PantryCompiler -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PantryCompiler -> PantryCompiler -> Bool
$c/= :: PantryCompiler -> PantryCompiler -> Bool
== :: PantryCompiler -> PantryCompiler -> Bool
$c== :: PantryCompiler -> PantryCompiler -> Bool
Eq,Eq PantryCompiler
PantryCompiler -> PantryCompiler -> Bool
PantryCompiler -> PantryCompiler -> Ordering
PantryCompiler -> PantryCompiler -> PantryCompiler
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 :: PantryCompiler -> PantryCompiler -> PantryCompiler
$cmin :: PantryCompiler -> PantryCompiler -> PantryCompiler
max :: PantryCompiler -> PantryCompiler -> PantryCompiler
$cmax :: PantryCompiler -> PantryCompiler -> PantryCompiler
>= :: PantryCompiler -> PantryCompiler -> Bool
$c>= :: PantryCompiler -> PantryCompiler -> Bool
> :: PantryCompiler -> PantryCompiler -> Bool
$c> :: PantryCompiler -> PantryCompiler -> Bool
<= :: PantryCompiler -> PantryCompiler -> Bool
$c<= :: PantryCompiler -> PantryCompiler -> Bool
< :: PantryCompiler -> PantryCompiler -> Bool
$c< :: PantryCompiler -> PantryCompiler -> Bool
compare :: PantryCompiler -> PantryCompiler -> Ordering
$ccompare :: PantryCompiler -> PantryCompiler -> Ordering
Ord)

instance FromJSON PantryCompiler where
  parseJSON :: Value -> Parser PantryCompiler
parseJSON (String Text
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Version) -> PantryCompiler
toCompiler 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 => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.runParser Parser (Text, Version)
the_parser String
"" Text
s
    where
      the_parser :: Parser (Text, Version)
the_parser = Parser () -> Parser (Text, Version)
parserPackage (forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof)
      toCompiler :: (Text, Version) -> PantryCompiler
toCompiler (Text
name, Version
ver) = Compiler -> PantryCompiler
PantryCompiler forall a b. (a -> b) -> a -> b
$ Text -> CompilerVersion -> Compiler
Compiler Text
name forall a b. (a -> b) -> a -> b
$ Version -> CompilerVersion
CVNumbered Version
ver
  parseJSON Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty

-- | Combine 'PantryBuildPlanMap' and 'CoreBuildPlanMap' to make a
-- complete 'BuildPlanMap'.
toBuildPlanMap :: CoreBuildPlanMap -> PantryBuildPlanMap -> Either String BuildPlanMap
toBuildPlanMap :: CoreBuildPlanMap
-> PantryBuildPlanMap -> Either String BuildPlanMap
toBuildPlanMap CoreBuildPlanMap
cbp PantryBuildPlanMap
pbp = 
  if Compiler
ccv forall a. Eq a => a -> a -> Bool
== Compiler
pcv
  then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PantryBuildPlanMap -> BuildPlanMap
pantryMap PantryBuildPlanMap
pbp forall a. Semigroup a => a -> a -> a
<> CoreBuildPlanMap -> BuildPlanMap
coreMap CoreBuildPlanMap
cbp
  else forall a b. a -> Either a b
Left (String
"Unmatched compiler versions: Core: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Compiler
ccv forall a. Semigroup a => a -> a -> a
<> String
", Pantry: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Compiler
pcv)
  where
    ccv :: Compiler
ccv = CoreBuildPlanMap -> Compiler
coreCompiler CoreBuildPlanMap
cbp
    pcv :: Compiler
pcv = PantryBuildPlanMap -> Compiler
pantryCompiler PantryBuildPlanMap
pbp

-- | Select a 'CoreBuildPlanMap' from the given map to make a complete
-- 'BuildPlanMap' from 'PantryBuildPlanMap'.
coresToBuildPlanMap :: CompilerCores -> PantryBuildPlanMap -> Either String BuildPlanMap
coresToBuildPlanMap :: CompilerCores -> PantryBuildPlanMap -> Either String BuildPlanMap
coresToBuildPlanMap CompilerCores
cmap PantryBuildPlanMap
pbp = do
  CoreBuildPlanMap
cbp <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left (String
"No CoreBuildPlanMap for compiler " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Compiler
compiler)) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Compiler
compiler CompilerCores
cmap
  CoreBuildPlanMap
-> PantryBuildPlanMap -> Either String BuildPlanMap
toBuildPlanMap CoreBuildPlanMap
cbp PantryBuildPlanMap
pbp
  where
    compiler :: Compiler
compiler = PantryBuildPlanMap -> Compiler
pantryCompiler PantryBuildPlanMap
pbp

-- | Parse a YAML document for a 'CoreBuildPlanMap'.
parseBuildPlanMapYAML :: BS.ByteString -> Either ErrorMsg PantryBuildPlanMap
parseBuildPlanMapYAML :: ByteString -> Either String PantryBuildPlanMap
parseBuildPlanMapYAML = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
toErrorMsg) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither'
  where
    toErrorMsg :: a -> String
toErrorMsg a
e = String
"Error while parsing PantryBuildPlanMap: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
e

-- | Fetch a Pantry build plan file from the Web.
fetchBuildPlanMapYAML :: Manager -> ExactResolver -> IO BSL.ByteString
fetchBuildPlanMapYAML :: Manager -> ExactResolver -> IO ByteString
fetchBuildPlanMapYAML Manager
man ExactResolver
er = Manager -> String -> IO ByteString
fetchURL Manager
man String
url
  where
    url :: String
url = String
"https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" forall a. Semigroup a => a -> a -> a
<> String
resolver_part
    resolver_part :: String
resolver_part =
      case ExactResolver
er of
        ExactLTS Word
major Word
minor -> String
"lts/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
major forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
minor forall a. [a] -> [a] -> [a]
++ String
".yaml"
        ExactNightly Word
year Word
month Word
day -> String
"nightly/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
year forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
month forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
day forall a. [a] -> [a] -> [a]
++ String
".yaml"

parserPackage :: P.Parser () -- ^ Parser of a symbol that follows the packageName-version string.
              -> P.Parser (PackageName, Version)
parserPackage :: Parser () -> Parser (Text, Version)
parserPackage Parser ()
end = do
  (String
pstr, Version
ver) <- forall a end. Parser a -> Parser end -> Parser ([a], end)
manyTillWithEnd Parser Char
P.anyChar ParsecT (ErrorFancy Void) Text Identity Version
versionAndEnd
  forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
pack String
pstr, Version
ver)
  where
    versionAndEnd :: ParsecT (ErrorFancy Void) Text Identity Version
versionAndEnd = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'-'
      Version
v <- ParsecT (ErrorFancy Void) Text Identity Version
parserVersion
      Parser ()
end
      forall (m :: * -> *) a. Monad m => a -> m a
return Version
v