{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE CPP #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE MultiWayIf #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE StandaloneDeriving #-}

module Stack.Types.Resolver

(Resolver

,IsLoaded(..)

,LoadedResolver

,ResolverThat's(..)

,parseResolverText

,resolverDirName

,resolverName

,customResolverHash

,toResolverNotLoaded

,AbstractResolver(..)

,readAbstractResolver

) where

import Control.Applicative

import Control.Monad.Catch (MonadThrow, throwM)

import Data.Aeson.Extended

(ToJSON, toJSON, FromJSON, parseJSON, object,

WithJSONWarnings(..), Value(String, Object), (.=),

noJSONWarnings, (..:), withObjectWarnings)

import Data.Monoid.Extra

import Data.Text (Text)

import qualified Data.Text as T

import Data.Text.Encoding (decodeUtf8)

import Data.Text.Read (decimal)

import Options.Applicative (ReadM)

import qualified Options.Applicative as OA

import qualified Options.Applicative.Types as OA

import Prelude

import Stack.Types.BuildPlan (parseSnapName, renderSnapName, SnapName, SnapshotHash,

trimmedSnapshotHash)

import {-# SOURCE #-} Stack.Types.Config (ConfigException(..))

import Stack.Types.Compiler

data IsLoaded = Loaded | NotLoaded

type LoadedResolver = ResolverThat's 'Loaded

type Resolver = ResolverThat's 'NotLoaded

-- TODO: once GHC 8.0 is the lowest version we support, make these into

-- actual haddock comments...

-- | 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

-- directory names

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

-- presentation.

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

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

-- latest nightly).

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