{-# LANGUAGE NoImplicitPrelude #-}

module Stack.Types.GHCVariant
  ( GHCVariant (..)
  , HasGHCVariant (..)
  , ghcVariantName
  , ghcVariantSuffix
  , parseGHCVariant
  ) where

import           Data.Aeson.Types ( FromJSON, parseJSON, withText )
import           Data.List ( stripPrefix )
import qualified Data.Text as T
import           Stack.Prelude

-- | Specialized variant of GHC (e.g. libgmp4 or integer-simple)

data GHCVariant
  = GHCStandard
  -- ^ Standard bindist

  | GHCIntegerSimple
  -- ^ Bindist that uses integer-simple

  | GHCNativeBignum
  -- ^ Bindist that uses the Haskell-native big-integer backend

  | GHCCustom String
  -- ^ Other bindists

  deriving Int -> GHCVariant -> ShowS
[GHCVariant] -> ShowS
GHCVariant -> String
(Int -> GHCVariant -> ShowS)
-> (GHCVariant -> String)
-> ([GHCVariant] -> ShowS)
-> Show GHCVariant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GHCVariant -> ShowS
showsPrec :: Int -> GHCVariant -> ShowS
$cshow :: GHCVariant -> String
show :: GHCVariant -> String
$cshowList :: [GHCVariant] -> ShowS
showList :: [GHCVariant] -> ShowS
Show

instance FromJSON GHCVariant where
  -- Strange structuring is to give consistent error messages

  parseJSON :: Value -> Parser GHCVariant
parseJSON =
    String -> (Text -> Parser GHCVariant) -> Value -> Parser GHCVariant
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText
      String
"GHCVariant"
      ((SomeException -> Parser GHCVariant)
-> (GHCVariant -> Parser GHCVariant)
-> Either SomeException GHCVariant
-> Parser GHCVariant
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser GHCVariant
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser GHCVariant)
-> (SomeException -> String) -> SomeException -> Parser GHCVariant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) GHCVariant -> Parser GHCVariant
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException GHCVariant -> Parser GHCVariant)
-> (Text -> Either SomeException GHCVariant)
-> Text
-> Parser GHCVariant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either SomeException GHCVariant
forall (m :: * -> *). MonadThrow m => String -> m GHCVariant
parseGHCVariant (String -> Either SomeException GHCVariant)
-> (Text -> String) -> Text -> Either SomeException GHCVariant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

-- | Class for environment values which have a GHCVariant

class HasGHCVariant env where
  ghcVariantL :: SimpleGetter env GHCVariant

instance HasGHCVariant GHCVariant where
  ghcVariantL :: SimpleGetter GHCVariant GHCVariant
ghcVariantL = (GHCVariant -> Const r GHCVariant)
-> GHCVariant -> Const r GHCVariant
forall a. a -> a
id
  {-# INLINE ghcVariantL #-}

-- | Render a GHC variant to a String.

ghcVariantName :: GHCVariant -> String
ghcVariantName :: GHCVariant -> String
ghcVariantName GHCVariant
GHCStandard = String
"standard"
ghcVariantName GHCVariant
GHCIntegerSimple = String
"integersimple"
ghcVariantName GHCVariant
GHCNativeBignum = String
"int-native"
ghcVariantName (GHCCustom String
name) = String
"custom-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name

-- | Render a GHC variant to a String suffix.

ghcVariantSuffix :: GHCVariant -> String
ghcVariantSuffix :: GHCVariant -> String
ghcVariantSuffix GHCVariant
GHCStandard = String
""
ghcVariantSuffix GHCVariant
v = String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ GHCVariant -> String
ghcVariantName GHCVariant
v

-- | Parse GHC variant from a String.

parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant
parseGHCVariant :: forall (m :: * -> *). MonadThrow m => String -> m GHCVariant
parseGHCVariant String
s =
  case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"custom-" String
s of
    Just String
name -> GHCVariant -> m GHCVariant
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> GHCVariant
GHCCustom String
name)
    Maybe String
Nothing
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" -> GHCVariant -> m GHCVariant
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCStandard
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"standard" -> GHCVariant -> m GHCVariant
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCStandard
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"integersimple" -> GHCVariant -> m GHCVariant
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCIntegerSimple
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"int-native" -> GHCVariant -> m GHCVariant
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCNativeBignum
      | Bool
otherwise -> GHCVariant -> m GHCVariant
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> GHCVariant
GHCCustom String
s)