{-# LANGUAGE NoImplicitPrelude #-}

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

import           Data.List ( stripPrefix )
import qualified Data.Text as T
import           Pantry.Internal.AesonExtended ( FromJSON, parseJSON, withText )
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GHCVariant] -> ShowS
$cshowList :: [GHCVariant] -> ShowS
show :: GHCVariant -> String
$cshow :: GHCVariant -> String
showsPrec :: Int -> GHCVariant -> ShowS
$cshowsPrec :: Int -> GHCVariant -> ShowS
Show

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

  parseJSON :: Value -> Parser GHCVariant
parseJSON =
    forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText
      String
"GHCVariant"
      (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 (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m GHCVariant
parseGHCVariant 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 = 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-" 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
"-" 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 forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"custom-" String
s of
    Just String
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> GHCVariant
GHCCustom String
name)
    Maybe String
Nothing
      | String
s forall a. Eq a => a -> a -> Bool
== String
"" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCStandard
      | String
s forall a. Eq a => a -> a -> Bool
== String
"standard" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCStandard
      | String
s forall a. Eq a => a -> a -> Bool
== String
"integersimple" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCIntegerSimple
      | String
s forall a. Eq a => a -> a -> Bool
== String
"int-native" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCVariant
GHCNativeBignum
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> GHCVariant
GHCCustom String
s)