{-# 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 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