{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module HaskellCI.Newtypes where

import HaskellCI.Prelude

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.Types.Version         as C
import qualified Distribution.Types.VersionRange    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 (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 :: forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChars = ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
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 a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
C.some m (String -> String)
forall (m :: * -> *). CabalParsing m => m (String -> String)
outerChar
        innerChars :: forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChars = ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
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 a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
C.many m (String -> String)
forall (m :: * -> *). CabalParsing m => m (String -> String)
innerChar

        outerChar :: forall (m :: * -> *). CabalParsing m => 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 :: forall (m :: * -> *). CabalParsing m => 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 :: forall (m :: * -> *).
CabalParsing m =>
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 a. a -> m a
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 a. a -> m a
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 :: forall (m :: * -> *). CabalParsing m => 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 a b c. (a -> b -> c) -> m a -> m b -> m c
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 :: forall (m :: * -> *). CabalParsing m => m HeadVersion
parsec = Maybe Version -> HeadVersion
HeadVersion Maybe Version
forall a. Maybe a
Nothing HeadVersion -> m String -> m HeadVersion
forall a b. a -> m b -> m a
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 a. m a -> m a -> m a
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
forall (m :: * -> *). CabalParsing m => m Version
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 :: forall (m :: * -> *). CabalParsing m => 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 :: forall (m :: * -> *). CabalParsing m => m Range
parsec = (VersionRange -> Range) -> m VersionRange -> m Range
forall a b. (a -> b) -> m a -> m b
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
forall (m :: * -> *). CabalParsing m => m VersionRange
C.parsec m VersionRange -> m VersionRange -> m VersionRange
forall a. m a -> m a -> m a
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
forall (m :: * -> *). CabalParsing m => m Bool
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 { 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
_ = 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' :: forall sep a b. 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 :: forall (m :: * -> *). CabalParsing m => 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]
forall (m :: * -> *) a. 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
forall (m :: * -> *). CabalParsing m => m b
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 :: forall a (proxy :: * -> *). Proxy a -> proxy a
hack Proxy a
_ = proxy a
forall a. HasCallStack => a
undefined