{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar".
-- Whenever we can not provide a Parsec instance for a type, we need to wrap it in a newtype and define the instance.
module Distribution.Client.Utils.Newtypes
  ( NumJobs (..)
  , PackageDBNT (..)
  , AllowNewerNT (..)
  , AllowOlderNT (..)
  , ProjectConstraints (..)
  , MaxBackjumps (..)
  , URI_NT (..)
  , KeyThreshold (..)
  )
where

import Distribution.Client.Compat.Prelude
import Distribution.Client.Targets (UserConstraint)
import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..))
import Distribution.Compat.CharParsing
import Distribution.Compat.Newtype
import Distribution.Parsec
import Distribution.Simple.Compiler (PackageDBCWD, interpretPackageDB, readPackageDb)
import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))
import Network.URI (URI, parseURI)

newtype PackageDBNT = PackageDBNT {PackageDBNT -> Maybe PackageDBCWD
getPackageDBNT :: Maybe PackageDBCWD}

instance Newtype (Maybe PackageDBCWD) PackageDBNT

instance Parsec PackageDBNT where
  parsec :: forall (m :: * -> *). CabalParsing m => m PackageDBNT
parsec = m PackageDBNT
forall (m :: * -> *). CabalParsing m => m PackageDBNT
parsecPackageDB

parsecPackageDB :: CabalParsing m => m PackageDBNT
parsecPackageDB :: forall (m :: * -> *). CabalParsing m => m PackageDBNT
parsecPackageDB = Maybe PackageDBCWD -> PackageDBNT
PackageDBNT (Maybe PackageDBCWD -> PackageDBNT)
-> (String -> Maybe PackageDBCWD) -> String -> PackageDBNT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageDB -> PackageDBCWD)
-> Maybe PackageDB -> Maybe PackageDBCWD
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (SymbolicPath CWD ('Dir Pkg)) -> PackageDB -> PackageDBCWD
interpretPackageDB Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing) (Maybe PackageDB -> Maybe PackageDBCWD)
-> (String -> Maybe PackageDB) -> String -> Maybe PackageDBCWD
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe PackageDB
readPackageDb (String -> PackageDBNT) -> m String -> m PackageDBNT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). CabalParsing m => m String
parsecToken

newtype NumJobs = NumJobs {NumJobs -> Maybe Int
getNumJobs :: Maybe Int}

instance Newtype (Maybe Int) NumJobs

instance Parsec NumJobs where
  parsec :: forall (m :: * -> *). CabalParsing m => m NumJobs
parsec = m NumJobs
forall (m :: * -> *). CabalParsing m => m NumJobs
parsecNumJobs

parsecNumJobs :: CabalParsing m => m NumJobs
parsecNumJobs :: forall (m :: * -> *). CabalParsing m => m NumJobs
parsecNumJobs = m NumJobs
ncpus m NumJobs -> m NumJobs -> m NumJobs
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m NumJobs
numJobs
  where
    ncpus :: m NumJobs
ncpus = String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
"$ncpus" m String -> m NumJobs -> m NumJobs
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NumJobs -> m NumJobs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> NumJobs
NumJobs Maybe Int
forall a. Maybe a
Nothing)
    numJobs :: m NumJobs
numJobs = do
      num <- m Int
forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
integral
      if num < (1 :: Int)
        then do
          parsecWarning PWTOther "The number of jobs should be 1 or more."
          return (NumJobs Nothing)
        else return (NumJobs $ Just num)

newtype URI_NT = URI_NT {URI_NT -> URI
getURI_NT :: URI}

instance Newtype URI URI_NT

instance Parsec URI_NT where
  parsec :: forall (m :: * -> *). CabalParsing m => m URI_NT
parsec = m URI_NT
forall (m :: * -> *). CabalParsing m => m URI_NT
parsecURI_NT

parsecURI_NT :: CabalParsing m => m URI_NT
parsecURI_NT :: forall (m :: * -> *). CabalParsing m => m URI_NT
parsecURI_NT = do
  token <- m String
forall (m :: * -> *). CabalParsing m => m String
parsecToken'
  case parseURI token of
    Maybe URI
Nothing -> String -> m URI_NT
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m URI_NT) -> String -> m URI_NT
forall a b. (a -> b) -> a -> b
$ String
"failed to parse URI " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
token
    Just URI
uri -> URI_NT -> m URI_NT
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI_NT -> m URI_NT) -> URI_NT -> m URI_NT
forall a b. (a -> b) -> a -> b
$ URI -> URI_NT
URI_NT URI
uri

newtype KeyThreshold = KeyThreshold {KeyThreshold -> Int
getKeyThreshold :: Int}

instance Newtype Int KeyThreshold

instance Parsec KeyThreshold where
  parsec :: forall (m :: * -> *). CabalParsing m => m KeyThreshold
parsec = Int -> KeyThreshold
KeyThreshold (Int -> KeyThreshold) -> m Int -> m KeyThreshold
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Int
forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
integral

newtype ProjectConstraints = ProjectConstraints {ProjectConstraints -> (UserConstraint, ConstraintSource)
getProjectConstraints :: (UserConstraint, ConstraintSource)}

instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints

instance Parsec ProjectConstraints where
  parsec :: forall (m :: * -> *). CabalParsing m => m ProjectConstraints
parsec = m ProjectConstraints
forall (m :: * -> *). CabalParsing m => m ProjectConstraints
parsecProjectConstraints

-- | Parse 'ProjectConstraints'. As the 'CabalParsing' class does not have access to the file we parse,
-- ConstraintSource is first unknown and we set it afterwards
parsecProjectConstraints :: CabalParsing m => m ProjectConstraints
parsecProjectConstraints :: forall (m :: * -> *). CabalParsing m => m ProjectConstraints
parsecProjectConstraints = do
  userConstraint <- m UserConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m UserConstraint
parsec
  return $ ProjectConstraints (userConstraint, ConstraintSourceUnknown)

newtype MaxBackjumps = MaxBackjumps {MaxBackjumps -> Int
getMaxBackjumps :: Int}

instance Newtype Int MaxBackjumps

instance Parsec MaxBackjumps where
  parsec :: forall (m :: * -> *). CabalParsing m => m MaxBackjumps
parsec = m MaxBackjumps
forall (m :: * -> *). CabalParsing m => m MaxBackjumps
parseMaxBackjumps

parseMaxBackjumps :: CabalParsing m => m MaxBackjumps
parseMaxBackjumps :: forall (m :: * -> *). CabalParsing m => m MaxBackjumps
parseMaxBackjumps = Int -> MaxBackjumps
MaxBackjumps (Int -> MaxBackjumps) -> m Int -> m MaxBackjumps
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Int
forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
integral

newtype AllowNewerNT = AllowNewerNT {AllowNewerNT -> Maybe AllowNewer
getAllowNewerNT :: Maybe AllowNewer}

instance Newtype (Maybe AllowNewer) AllowNewerNT

instance Parsec AllowNewerNT where
  parsec :: forall (m :: * -> *). CabalParsing m => m AllowNewerNT
parsec = m AllowNewerNT
forall (m :: * -> *). CabalParsing m => m AllowNewerNT
parsecAllowNewer

parsecAllowNewer :: CabalParsing m => m AllowNewerNT
parsecAllowNewer :: forall (m :: * -> *). CabalParsing m => m AllowNewerNT
parsecAllowNewer = Maybe AllowNewer -> AllowNewerNT
AllowNewerNT (Maybe AllowNewer -> AllowNewerNT)
-> (AllowNewer -> Maybe AllowNewer) -> AllowNewer -> AllowNewerNT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowNewer -> Maybe AllowNewer
forall a. a -> Maybe a
Just (AllowNewer -> AllowNewerNT) -> m AllowNewer -> m AllowNewerNT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m AllowNewer
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m AllowNewer
parsec

newtype AllowOlderNT = AllowOlderNT {AllowOlderNT -> Maybe AllowOlder
getAllowOlderNT :: Maybe AllowOlder}

instance Newtype (Maybe AllowOlder) AllowOlderNT

instance Parsec AllowOlderNT where
  parsec :: forall (m :: * -> *). CabalParsing m => m AllowOlderNT
parsec = m AllowOlderNT
forall (m :: * -> *). CabalParsing m => m AllowOlderNT
parsecAllowOlder

parsecAllowOlder :: CabalParsing m => m AllowOlderNT
parsecAllowOlder :: forall (m :: * -> *). CabalParsing m => m AllowOlderNT
parsecAllowOlder = Maybe AllowOlder -> AllowOlderNT
AllowOlderNT (Maybe AllowOlder -> AllowOlderNT)
-> (AllowOlder -> Maybe AllowOlder) -> AllowOlder -> AllowOlderNT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowOlder -> Maybe AllowOlder
forall a. a -> Maybe a
Just (AllowOlder -> AllowOlderNT) -> m AllowOlder -> m AllowOlderNT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m AllowOlder
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m AllowOlder
parsec