{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Client.Utils.Parsec
  ( remoteRepoGrammar

    -- ** Flag
  , alaFlag
  , Flag'

    -- ** NubList
  , alaNubList
  , alaNubList'
  , NubList'

    -- ** Newtype wrappers
  , module Distribution.Client.Utils.Newtypes
  ) where

import Distribution.Client.Compat.Prelude
import Distribution.Compat.Newtype
import Prelude ()

import Distribution.Client.Types.Repo
import Distribution.Client.Types.RepoName
import Distribution.Client.Utils.Newtypes
import Distribution.FieldGrammar
import Distribution.Simple.Flag
import Distribution.Utils.NubList (NubList (..))
import qualified Distribution.Utils.NubList as NubList

-- | Like 'List' for usage with a 'FieldGrammar', but for 'Flag'.
-- This enables to parse type aliases such as 'FilePath' that do not have 'Parsec' instances
-- by using newtype variants such as 'FilePathNT'.
-- For example, if you need to parse a 'Flag FilePath', you can use 'alaFlag' FilePathNT'.
newtype Flag' b a = Flag' {forall b a. Flag' b a -> Flag a
_getFlag :: Flag a}

-- | 'Flag'' constructor, with additional phantom argument to constrain the resulting type
alaFlag :: (a -> b) -> Flag a -> Flag' b a
alaFlag :: forall a b. (a -> b) -> Flag a -> Flag' b a
alaFlag a -> b
_ = Flag a -> Flag' b a
forall b a. Flag a -> Flag' b a
Flag'

instance Newtype (Flag a) (Flag' wrapper a)

instance (Newtype a b, Parsec b) => Parsec (Flag' b a) where
  parsec :: forall (m :: * -> *). CabalParsing m => m (Flag' b a)
parsec = Flag a -> Flag' b a
forall o n. Newtype o n => o -> n
pack (Flag a -> Flag' b a) -> (b -> Flag a) -> b -> Flag' b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Flag a
forall a. a -> Flag a
toFlag (a -> Flag a) -> (b -> a) -> b -> Flag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a
forall o n. Newtype o n => n -> o
unpack :: b -> a) (b -> Flag' b a) -> m b -> m (Flag' b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m b
parsec

instance (Newtype a b, Pretty b) => Pretty (Flag' b a) where
  pretty :: Flag' b a -> Doc
pretty = b -> Doc
forall a. Pretty a => a -> Doc
pretty (b -> Doc) -> (Flag' b a -> b) -> Flag' b a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b
forall o n. Newtype o n => o -> n
pack :: a -> b) (a -> b) -> (Flag' b a -> a) -> Flag' b a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag a -> a
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag a -> a) -> (Flag' b a -> Flag a) -> Flag' b a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag' b a -> Flag a
forall o n. Newtype o n => n -> o
unpack

-- | Like 'List' for usage with a 'FieldGrammar', but for 'NubList'.
newtype NubList' sep b a = NubList' {forall sep b a. NubList' sep b a -> NubList a
_getNubList :: NubList a}

-- | 'alaNubList' and 'alaNubList'' are simply 'NubList'' constructor, with additional phantom
-- arguments to constrain the resulting type
--
-- >>> :t alaNubList VCat
-- alaNubList VCat :: NubList a -> NubList' VCat (Identity a) a
--
-- >>> :t alaNubList' FSep Token
-- alaNubList' FSep Token
--   :: NubList String -> NubList' FSep Token String
--
-- >>> unpack' (alaNubList' FSep Token) <$> eitherParsec "foo bar foo"
-- Right ["foo","bar"]
alaNubList :: sep -> NubList a -> NubList' sep (Identity a) a
alaNubList :: forall sep a. sep -> NubList a -> NubList' sep (Identity a) a
alaNubList sep
_ = NubList a -> NubList' sep (Identity a) a
forall sep b a. NubList a -> NubList' sep b a
NubList'

-- | More general version of 'alaNubList'.
alaNubList' :: sep -> (a -> b) -> NubList a -> NubList' sep b a
alaNubList' :: forall sep a b. sep -> (a -> b) -> NubList a -> NubList' sep b a
alaNubList' sep
_ a -> b
_ = NubList a -> NubList' sep b a
forall sep b a. NubList a -> NubList' sep b a
NubList'

instance Newtype (NubList a) (NubList' sep wrapper a)

instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (NubList' sep b a) where
  parsec :: forall (m :: * -> *). CabalParsing m => m (NubList' sep b a)
parsec = NubList a -> NubList' sep b a
forall o n. Newtype o n => o -> n
pack (NubList a -> NubList' sep b a)
-> ([b] -> NubList a) -> [b] -> NubList' sep b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> NubList a
forall a. Ord a => [a] -> NubList a
NubList.toNubList ([a] -> NubList a) -> ([b] -> [a]) -> [b] -> NubList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> [b] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (b -> a
forall o n. Newtype o n => n -> o
unpack :: b -> a) ([b] -> NubList' sep b a) -> m [b] -> m (NubList' sep b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy sep -> m b -> m [b]
forall sep (m :: * -> *) a.
(Sep sep, CabalParsing m) =>
Proxy sep -> m a -> m [a]
forall (m :: * -> *) a. CabalParsing m => Proxy sep -> m a -> m [a]
parseSep (Proxy sep
forall {k} (t :: k). Proxy t
Proxy :: Proxy sep) m b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m b
parsec

instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where
  pretty :: NubList' sep b a -> Doc
pretty = Proxy sep -> [Doc] -> Doc
forall sep. Sep sep => Proxy sep -> [Doc] -> Doc
prettySep (Proxy sep
forall {k} (t :: k). Proxy t
Proxy :: Proxy sep) ([Doc] -> Doc)
-> (NubList' sep b a -> [Doc]) -> NubList' sep b a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (b -> Doc
forall a. Pretty a => a -> Doc
pretty (b -> Doc) -> (a -> b) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b
forall o n. Newtype o n => o -> n
pack :: a -> b)) ([a] -> [Doc])
-> (NubList' sep b a -> [a]) -> NubList' sep b a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NubList a -> [a]
forall a. NubList a -> [a]
NubList.fromNubList (NubList a -> [a])
-> (NubList' sep b a -> NubList a) -> NubList' sep b a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NubList' sep b a -> NubList a
forall o n. Newtype o n => n -> o
unpack

remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo
remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo
remoteRepoGrammar RepoName
name =
  (URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo)
-> ParsecFieldGrammar
     RemoteRepo
     (URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo)
forall a. a -> ParsecFieldGrammar RemoteRepo a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoName
-> URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo
RemoteRepo RepoName
name)
    ParsecFieldGrammar
  RemoteRepo
  (URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo)
-> ParsecFieldGrammar RemoteRepo URI
-> ParsecFieldGrammar
     RemoteRepo (Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo)
forall a b.
ParsecFieldGrammar RemoteRepo (a -> b)
-> ParsecFieldGrammar RemoteRepo a
-> ParsecFieldGrammar RemoteRepo b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> (URI -> URI_NT)
-> ALens' RemoteRepo URI
-> ParsecFieldGrammar RemoteRepo URI
forall b a s.
(Parsec b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> ParsecFieldGrammar s a
forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> g s a
uniqueFieldAla FieldName
"url" URI -> URI_NT
URI_NT ALens' RemoteRepo URI
Lens' RemoteRepo URI
remoteRepoURILens
    ParsecFieldGrammar
  RemoteRepo (Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo)
-> ParsecFieldGrammar RemoteRepo (Maybe Bool)
-> ParsecFieldGrammar
     RemoteRepo ([String] -> Int -> Bool -> RemoteRepo)
forall a b.
ParsecFieldGrammar RemoteRepo (a -> b)
-> ParsecFieldGrammar RemoteRepo a
-> ParsecFieldGrammar RemoteRepo b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ALens' RemoteRepo (Maybe Bool)
-> ParsecFieldGrammar RemoteRepo (Maybe Bool)
forall (c :: * -> Constraint) (g :: * -> * -> *) a s.
(FieldGrammar c g, c (Identity a)) =>
FieldName -> ALens' s (Maybe a) -> g s (Maybe a)
optionalField FieldName
"secure" ALens' RemoteRepo (Maybe Bool)
Lens' RemoteRepo (Maybe Bool)
remoteRepoSecureLens
    ParsecFieldGrammar
  RemoteRepo ([String] -> Int -> Bool -> RemoteRepo)
-> ParsecFieldGrammar RemoteRepo [String]
-> ParsecFieldGrammar RemoteRepo (Int -> Bool -> RemoteRepo)
forall a b.
ParsecFieldGrammar RemoteRepo (a -> b)
-> ParsecFieldGrammar RemoteRepo a
-> ParsecFieldGrammar RemoteRepo b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> ([String] -> List FSep Token String)
-> ALens' RemoteRepo [String]
-> ParsecFieldGrammar RemoteRepo [String]
forall b a s.
(Parsec b, Monoid a, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> ParsecFieldGrammar s a
forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Monoid a, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> g s a
monoidalFieldAla FieldName
"root-keys" (FSep -> (String -> Token) -> [String] -> List FSep Token String
forall sep a b. sep -> (a -> b) -> [a] -> List sep b a
alaList' FSep
FSep String -> Token
Token) ALens' RemoteRepo [String]
Lens' RemoteRepo [String]
remoteRepoRootKeysLens
    ParsecFieldGrammar RemoteRepo (Int -> Bool -> RemoteRepo)
-> ParsecFieldGrammar RemoteRepo Int
-> ParsecFieldGrammar RemoteRepo (Bool -> RemoteRepo)
forall a b.
ParsecFieldGrammar RemoteRepo (a -> b)
-> ParsecFieldGrammar RemoteRepo a
-> ParsecFieldGrammar RemoteRepo b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldName
-> (Int -> KeyThreshold)
-> ALens' RemoteRepo Int
-> Int
-> ParsecFieldGrammar RemoteRepo Int
forall b a s.
(Parsec b, Newtype a b, Eq a) =>
FieldName -> (a -> b) -> ALens' s a -> a -> ParsecFieldGrammar s a
forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b, Eq a) =>
FieldName -> (a -> b) -> ALens' s a -> a -> g s a
optionalFieldDefAla FieldName
"key-threshold" Int -> KeyThreshold
KeyThreshold ALens' RemoteRepo Int
Lens' RemoteRepo Int
remoteRepoKeyThresholdLens Int
0
    ParsecFieldGrammar RemoteRepo (Bool -> RemoteRepo)
-> ParsecFieldGrammar RemoteRepo Bool
-> ParsecFieldGrammar RemoteRepo RemoteRepo
forall a b.
ParsecFieldGrammar RemoteRepo (a -> b)
-> ParsecFieldGrammar RemoteRepo a
-> ParsecFieldGrammar RemoteRepo b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> ParsecFieldGrammar RemoteRepo Bool
forall a. a -> ParsecFieldGrammar RemoteRepo a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False -- we don't parse remoteRepoShouldTryHttps