{-# 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 :: m PackageLocation
parsec = String -> PackageLocation
PackageLocation (String -> PackageLocation) -> m String -> m PackageLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
outerTerm
      where
        outerTerm :: m String
outerTerm = ((String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"") ((String -> String) -> String) -> m (String -> String) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (String -> String)
forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChars

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

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

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

        kont :: C.CabalParsing m => Char -> m ShowS
        kont :: Char -> m (String -> String)
kont Char
c = case Char
c of
           Char
'{' -> do
               String -> String
cs <- m (String -> String)
forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChars
               Char
c' <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
C.char Char
'}'
               (String -> String) -> m (String -> String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String -> String
showChar Char
c (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cs (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
c')
           Char
_   -> (String -> String) -> m (String -> String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> String) -> m (String -> String))
-> (String -> String) -> m (String -> String)
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 :: m NoCommas
parsec = String -> NoCommas
NoCommas (String -> NoCommas) -> m String -> m NoCommas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> String -> String) -> m Char -> m String -> m String
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ((Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
C.satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)) ((Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch (Char -> Char -> Bool
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 :: m HeadVersion
parsec = Maybe Version -> HeadVersion
HeadVersion Maybe Version
forall a. Maybe a
Nothing HeadVersion -> m String -> m HeadVersion
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
C.string String
"head" m HeadVersion -> m HeadVersion -> m HeadVersion
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        Maybe Version -> HeadVersion
HeadVersion (Maybe Version -> HeadVersion)
-> (Version -> Maybe Version) -> Version -> HeadVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> HeadVersion) -> m Version -> m HeadVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Version
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)) = Version -> Doc
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 :: m Int'
parsec = Int -> Int'
Int' (Int -> Int') -> m Int -> m Int'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Int
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 :: m Range
parsec = (VersionRange -> Range) -> m VersionRange -> m Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VersionRange -> Range
Range (m VersionRange -> m Range) -> m VersionRange -> m Range
forall a b. (a -> b) -> a -> b
$ m VersionRange
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec m VersionRange -> m VersionRange -> m VersionRange
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> VersionRange
fromBool (Bool -> VersionRange) -> m Bool -> m VersionRange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Bool
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 = Bool -> Doc
forall a. Pretty a => a -> Doc
C.pretty Bool
True
        | VersionRange -> VersionRange -> Bool
equivVersionRanges VersionRange
r VersionRange
C.noVersion  = Bool -> Doc
forall a. Pretty a => a -> Doc
C.pretty Bool
False
        | Bool
otherwise                         = VersionRange -> Doc
forall a. Pretty a => a -> Doc
C.pretty VersionRange
r

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

newtype AlaSet sep b a = AlaSet { 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 :: sep -> Set a -> AlaSet sep (Identity a) a
alaSet sep
_ = Set a -> AlaSet sep (Identity a) a
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' :: sep -> (a -> b) -> Set a -> AlaSet sep b a
alaSet' sep
_ a -> b
_ = Set a -> AlaSet sep b a
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 :: m (AlaSet sep b a)
parsec   = Set a -> AlaSet sep b a
forall o n. Newtype o n => o -> n
C.pack (Set a -> AlaSet sep b a)
-> ([b] -> Set a) -> [b] -> AlaSet sep b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> ([b] -> [a]) -> [b] -> Set 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
C.unpack :: b -> a) ([b] -> AlaSet sep b a) -> m [b] -> m (AlaSet 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]
C.parseSep (Proxy sep -> Proxy sep
forall a (proxy :: * -> *). Proxy a -> proxy a
hack (Proxy sep
forall k (t :: k). Proxy t
Proxy :: Proxy sep)) m b
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 = Proxy sep -> [Doc] -> Doc
forall sep. Sep sep => Proxy sep -> [Doc] -> Doc
C.prettySep (Proxy sep -> Proxy sep
forall a (proxy :: * -> *). Proxy a -> proxy a
hack (Proxy sep
forall k (t :: k). Proxy t
Proxy :: Proxy sep)) ([Doc] -> Doc)
-> (AlaSet sep b a -> [Doc]) -> AlaSet 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
C.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
C.pack :: a -> b)) ([a] -> [Doc])
-> (AlaSet sep b a -> [a]) -> AlaSet sep b a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a])
-> (AlaSet sep b a -> Set a) -> AlaSet sep b a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlaSet sep b a -> Set a
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 :: Proxy a -> proxy a
hack Proxy a
_ = proxy a
forall a. HasCallStack => a
undefined

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

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

instance C.Parsec WrappedURI where
    parsec :: m WrappedURI
parsec = do
        String
t <- m String
forall (m :: * -> *). CabalParsing m => m String
C.parsecToken
        case String -> Maybe URI
parseURI String
t of
            Just URI
x  -> WrappedURI -> m WrappedURI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> WrappedURI
WrapURI URI
x)
            Maybe URI
Nothing -> String -> m WrappedURI
forall (m :: * -> *) a. Parsing m => String -> m a
C.unexpected (String -> m WrappedURI) -> String -> m WrappedURI
forall a b. (a -> b) -> a -> b
$ String
"Not an URI: " String -> String -> String
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 String -> String
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 = ([VersionInterval] -> [VersionInterval] -> Bool)
-> (VersionRange -> [VersionInterval])
-> VersionRange
-> VersionRange
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on [VersionInterval] -> [VersionInterval] -> Bool
forall a. Eq a => a -> a -> Bool
(==) VersionRange -> [VersionInterval]
C.asVersionIntervals