{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
module Cabal.Internal.Newtypes where

import Control.Applicative   (Alternative (..), liftA2)
import Data.Char             (isSpace)
import Data.Function         (on)
import Data.Functor.Identity (Identity (..))
import Data.Proxy            (Proxy (..))
import Network.URI           (URI, parseURI, uriToString)

import qualified Data.Set                           as S
import qualified Distribution.Compat.CharParsing    as C
import qualified Distribution.Compat.Newtype        as C
import qualified Distribution.FieldGrammar.Newtypes as C
import qualified Distribution.Parsec                as C
import qualified Distribution.Pretty                as C
import qualified Distribution.Version               as C
import qualified Text.PrettyPrint                   as PP

-------------------------------------------------------------------------------
-- PackageLocation
-------------------------------------------------------------------------------

newtype PackageLocation = PackageLocation String
  deriving anyclass (C.Newtype String)

-- | This is a bit tricky since it has to cover globs which have embedded @,@
-- chars. But we don't just want to parse strictly as a glob since we want to
-- allow http urls which don't parse as globs, and possibly some
-- system-dependent file paths. So we parse fairly liberally as a token, but
-- we allow @,@ inside matched @{}@ braces.
instance C.Parsec PackageLocation where
    parsec :: forall (m :: * -> *). CabalParsing m => m PackageLocation
parsec = String -> PackageLocation
PackageLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
outerTerm
      where
        outerTerm :: m String
outerTerm = (forall a b. (a -> b) -> a -> b
$ String
"") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChars

        outerChars, outerChar, innerChars, innerChar :: C.CabalParsing m => m ShowS
        outerChars :: forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChars = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
C.some forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChar
        innerChars :: forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChars = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
C.many forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChar

        outerChar :: forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChar = do
            Char
c <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
C.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'}' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
',')
            forall (m :: * -> *).
CabalParsing m =>
Char -> m (String -> String)
kont Char
c

        innerChar :: forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChar = do
            Char
c <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
C.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'}')
            forall (m :: * -> *).
CabalParsing m =>
Char -> m (String -> String)
kont Char
c

        kont :: C.CabalParsing m => Char -> m ShowS
        kont :: forall (m :: * -> *).
CabalParsing m =>
Char -> m (String -> String)
kont Char
c = case Char
c of
           Char
'{' -> do
               String -> String
cs <- forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChars
               Char
c' <- forall (m :: * -> *). CharParsing m => Char -> m Char
C.char Char
'}'
               forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String -> String
showChar Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
c')
           Char
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char -> String -> String
showChar Char
c


instance C.Pretty PackageLocation where
    pretty :: PackageLocation -> Doc
pretty (PackageLocation String
p) = String -> Doc
PP.text String
p

-------------------------------------------------------------------------------
-- NoCommas: something which can be comma separated
-------------------------------------------------------------------------------

newtype NoCommas = NoCommas String
  deriving anyclass (C.Newtype String)

instance C.Parsec NoCommas where
    parsec :: forall (m :: * -> *). CabalParsing m => m NoCommas
parsec = String -> NoCommas
NoCommas forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
C.satisfy (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)) (forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch (forall a. Eq a => a -> a -> Bool
/= Char
','))

instance C.Pretty NoCommas where
    pretty :: NoCommas -> Doc
pretty (NoCommas String
p) = String -> Doc
PP.text String
p

-------------------------------------------------------------------------------
-- Head version
-------------------------------------------------------------------------------

newtype HeadVersion = HeadVersion { HeadVersion -> Maybe Version
getHeadVersion :: Maybe C.Version }
  deriving anyclass (C.Newtype (Maybe C.Version))

instance C.Parsec HeadVersion where
    parsec :: forall (m :: * -> *). CabalParsing m => m HeadVersion
parsec = Maybe Version -> HeadVersion
HeadVersion forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
C.string String
"head" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        Maybe Version -> HeadVersion
HeadVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec

instance C.Pretty HeadVersion where
    pretty :: HeadVersion -> Doc
pretty (HeadVersion Maybe Version
Nothing)  = String -> Doc
PP.text String
"head"
    pretty (HeadVersion (Just Version
v)) = forall a. Pretty a => a -> Doc
C.pretty Version
v

-------------------------------------------------------------------------------
-- Newtype
-------------------------------------------------------------------------------

newtype Int' = Int' Int
  deriving anyclass (C.Newtype Int)

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

instance C.Pretty Int' where
    pretty :: Int' -> Doc
pretty (Int' Int
i) = Int -> Doc
PP.int Int
i

-------------------------------------------------------------------------------
-- Range
-------------------------------------------------------------------------------

newtype Range = Range C.VersionRange
  deriving anyclass (C.Newtype C.VersionRange)

instance C.Parsec Range where
    parsec :: forall (m :: * -> *). CabalParsing m => m Range
parsec = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VersionRange -> Range
Range forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> VersionRange
fromBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec where
        fromBool :: Bool -> VersionRange
fromBool Bool
True  = VersionRange
C.anyVersion
        fromBool Bool
False = VersionRange
C.noVersion

instance C.Pretty Range where
    pretty :: Range -> Doc
pretty (Range VersionRange
r)
        | VersionRange -> VersionRange -> Bool
equivVersionRanges VersionRange
r VersionRange
C.anyVersion = forall a. Pretty a => a -> Doc
C.pretty Bool
True
        | VersionRange -> VersionRange -> Bool
equivVersionRanges VersionRange
r VersionRange
C.noVersion  = forall a. Pretty a => a -> Doc
C.pretty Bool
False
        | Bool
otherwise                         = forall a. Pretty a => a -> Doc
C.pretty VersionRange
r

-------------------------------------------------------------------------------
-- AlaSet
-------------------------------------------------------------------------------

newtype AlaSet sep b a = AlaSet { forall sep b a. AlaSet sep b a -> Set a
getAlaSet :: S.Set a }
  deriving anyclass (C.Newtype (S.Set a))

alaSet :: sep -> S.Set a -> AlaSet sep (Identity a) a
alaSet :: forall sep a. sep -> Set a -> AlaSet sep (Identity a) a
alaSet sep
_ = forall sep b a. Set a -> AlaSet sep b a
AlaSet

-- | More general version of 'alaSet'.
alaSet' :: sep -> (a -> b) -> S.Set a -> AlaSet sep b a
alaSet' :: forall sep a b. sep -> (a -> b) -> Set a -> AlaSet sep b a
alaSet' sep
_ a -> b
_ = forall sep b a. Set a -> AlaSet sep b a
AlaSet

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

instance (C.Newtype a b, C.Sep sep, C.Pretty b) => C.Pretty (AlaSet sep b a) where
    pretty :: AlaSet sep b a -> Doc
pretty = forall sep. Sep sep => Proxy sep -> [Doc] -> Doc
C.prettySep (forall a (proxy :: * -> *). Proxy a -> proxy a
hack (forall {k} (t :: k). Proxy t
Proxy :: Proxy sep)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> Doc
C.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall o n. Newtype o n => o -> n
C.pack :: a -> b)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o n. Newtype o n => n -> o
C.unpack

-- Someone (= me) forgot to export Distribution.Parsec.Newtypes.P
hack :: Proxy a -> proxy a
hack :: forall a (proxy :: * -> *). Proxy a -> proxy a
hack Proxy a
_ = forall a. HasCallStack => a
undefined

-------------------------------------------------------------------------------
-- WrapURI
-------------------------------------------------------------------------------

newtype WrappedURI = WrapURI URI
  deriving anyclass (C.Newtype URI)

instance C.Parsec WrappedURI where
    parsec :: forall (m :: * -> *). CabalParsing m => m WrappedURI
parsec = do
        String
t <- forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        case String -> Maybe URI
parseURI String
t of
            Just URI
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> WrappedURI
WrapURI URI
x)
            Maybe URI
Nothing -> forall (m :: * -> *) a. Parsing m => String -> m a
C.unexpected forall a b. (a -> b) -> a -> b
$ String
"Not an URI: " forall a. [a] -> [a] -> [a]
++ String
t

instance C.Pretty WrappedURI where
    pretty :: WrappedURI -> Doc
pretty (WrapURI URI
uri) = String -> Doc
PP.text ((String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id URI
uri String
"")

-------------------------------------------------------------------------------
-- extras
-------------------------------------------------------------------------------

-- | Whether two ranges are equivalent.
equivVersionRanges :: C.VersionRange -> C.VersionRange -> Bool
equivVersionRanges :: VersionRange -> VersionRange -> Bool
equivVersionRanges = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) VersionRange -> [VersionInterval]
C.asVersionIntervals