import Control.Exception.Lifted

import Control.Monad.Catch (MonadThrow)

import Data.List (find)

import Data.Maybe

import Data.Monoid.Extra

import Data.Typeable (Typeable)

import Distribution.Version (simplifyVersionRange)

import Path

import Stack.Types.BuildPlan

import Stack.Types.Version

import Stack.Types.Config

import Stack.Types.Docker

import Stack.Types.Config

-- ** Resolver & AbstractResolver

,Resolver

,LoadedResolver

,ResolverThat's(..)

,parseResolverText

,resolverDirName

,resolverName

,customResolverHash

,toResolverNotLoaded

,AbstractResolver(..)

,readAbstractResolver

import Control.Monad.Catch (MonadThrow, MonadMask, throwM)

(.=), (..:), (..:?), (..!=), Value(Bool, String, Object),

import Data.Text.Encoding (encodeUtf8, decodeUtf8)

import Data.Text.Read (decimal)

import Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName, parseSnapName, SnapshotHash (..), trimmedSnapshotHash)

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

data AbstractResolver

= ARLatestNightly

| ARLatestLTS

| ARLatestLTSMajor !Int

| ARResolver !Resolver

| ARGlobal

deriving Show

readAbstractResolver :: ReadM AbstractResolver

readAbstractResolver = do

s <- OA.readerAsk

case s of

"global" -> return ARGlobal

"nightly" -> return ARLatestNightly

"lts" -> return ARLatestLTS

'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->

return $ ARLatestLTSMajor x'

_ ->

case parseResolverText $ T.pack s of

Left e -> OA.readerError $ show e

Right x -> return $ ARResolver x

data IsLoaded = Loaded | NotLoaded

type LoadedResolver = ResolverThat's 'Loaded

type Resolver = ResolverThat's 'NotLoaded

-- | How we resolve which dependencies to install given a set of packages.

data ResolverThat's (l :: IsLoaded) where

-- Use an official snapshot from the Stackage project, either an LTS

-- Haskell or Stackage Nightly.

ResolverSnapshot :: !SnapName -> ResolverThat's l

-- Require a specific compiler version, but otherwise provide no

-- build plan. Intended for use cases where end user wishes to

-- specify all upstream dependencies manually, such as using a

-- dependency solver.

ResolverCompiler :: !CompilerVersion -> ResolverThat's l

-- A custom resolver based on the given name and URL. When a URL is

-- provided, it file is to be completely immutable. Filepaths are

-- always loaded. This constructor is used before the build-plan has

-- been loaded, as we do not yet know the custom snapshot's hash.

ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded

-- Like 'ResolverCustom', but after loading the build-plan, so we

-- have a hash. This is necessary in order to identify the location

-- files are stored for the resolver.

ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded

deriving instance Eq (ResolverThat's k)

deriving instance Show (ResolverThat's k)

instance ToJSON (ResolverThat's k) where

toJSON x = case x of

ResolverSnapshot{} -> toJSON $ resolverName x

ResolverCompiler{} -> toJSON $ resolverName x

ResolverCustom n l -> handleCustom n l

ResolverCustomLoaded n l _ -> handleCustom n l

where

handleCustom n l = object

[ "name" .= n

, "location" .= l

]

instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where

-- Strange structuring is to give consistent error messages

parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom

<$> o ..: "name"

<*> o ..: "location") v

parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t)

parseJSON _ = fail "Invalid Resolver, must be Object or String"

-- | Convert a Resolver into its @Text@ representation, as will be used by

resolverDirName :: LoadedResolver -> Text

resolverDirName (ResolverSnapshot name) = renderSnapName name

resolverDirName (ResolverCompiler v) = compilerVersionText v

resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash)

-- | Convert a Resolver into its @Text@ representation for human

resolverName :: ResolverThat's l -> Text

resolverName (ResolverSnapshot name) = renderSnapName name

resolverName (ResolverCompiler v) = compilerVersionText v

resolverName (ResolverCustom name _) = "custom-" <> name

resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name

customResolverHash :: LoadedResolver-> Maybe SnapshotHash

customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash

customResolverHash _ = Nothing

-- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).

parseResolverText :: MonadThrow m => Text -> m Resolver

parseResolverText t

| Right x <- parseSnapName t = return $ ResolverSnapshot x

| Just v <- parseCompilerVersion t = return $ ResolverCompiler v

| otherwise = throwM $ ParseResolverException t

toResolverNotLoaded :: LoadedResolver -> Resolver

toResolverNotLoaded r = case r of

ResolverSnapshot s -> ResolverSnapshot s

ResolverCompiler v -> ResolverCompiler v

ResolverCustomLoaded n l _ -> ResolverCustom n l