{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.IndexUtils.ActiveRepos (
    ActiveRepos (..),
    defaultActiveRepos,
    filterSkippedActiveRepos,
    ActiveRepoEntry (..),
    CombineStrategy (..),
    organizeByRepos,
) where

import Distribution.Client.Compat.Prelude
import Distribution.Client.Types.RepoName (RepoName (..))
import Prelude ()

import Distribution.Parsec (parsecLeadingCommaNonEmpty)

import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint                as Disp

-- $setup
-- >>> import Distribution.Parsec

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

-- | Ordered list of active repositories.
newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]
  deriving (ActiveRepos -> ActiveRepos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActiveRepos -> ActiveRepos -> Bool
$c/= :: ActiveRepos -> ActiveRepos -> Bool
== :: ActiveRepos -> ActiveRepos -> Bool
$c== :: ActiveRepos -> ActiveRepos -> Bool
Eq, Int -> ActiveRepos -> ShowS
[ActiveRepos] -> ShowS
ActiveRepos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActiveRepos] -> ShowS
$cshowList :: [ActiveRepos] -> ShowS
show :: ActiveRepos -> String
$cshow :: ActiveRepos -> String
showsPrec :: Int -> ActiveRepos -> ShowS
$cshowsPrec :: Int -> ActiveRepos -> ShowS
Show, forall x. Rep ActiveRepos x -> ActiveRepos
forall x. ActiveRepos -> Rep ActiveRepos x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ActiveRepos x -> ActiveRepos
$cfrom :: forall x. ActiveRepos -> Rep ActiveRepos x
Generic)

defaultActiveRepos :: ActiveRepos
defaultActiveRepos :: ActiveRepos
defaultActiveRepos = [ActiveRepoEntry] -> ActiveRepos
ActiveRepos [ CombineStrategy -> ActiveRepoEntry
ActiveRepoRest CombineStrategy
CombineStrategyMerge ]

-- | Note, this does nothing if 'ActiveRepoRest' is present.
filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos
filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos
filterSkippedActiveRepos repos :: ActiveRepos
repos@(ActiveRepos [ActiveRepoEntry]
entries)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ActiveRepoEntry -> Bool
isActiveRepoRest [ActiveRepoEntry]
entries = ActiveRepos
repos
    | Bool
otherwise                    = [ActiveRepoEntry] -> ActiveRepos
ActiveRepos (forall a. (a -> Bool) -> [a] -> [a]
filter ActiveRepoEntry -> Bool
notSkipped [ActiveRepoEntry]
entries)
  where
    isActiveRepoRest :: ActiveRepoEntry -> Bool
isActiveRepoRest (ActiveRepoRest CombineStrategy
_) = Bool
True
    isActiveRepoRest ActiveRepoEntry
_                  = Bool
False

    notSkipped :: ActiveRepoEntry -> Bool
notSkipped (ActiveRepo RepoName
_ CombineStrategy
CombineStrategySkip) = Bool
False
    notSkipped ActiveRepoEntry
_                                  = Bool
True

instance Binary ActiveRepos
instance Structured ActiveRepos
instance NFData ActiveRepos

instance Pretty ActiveRepos where
    pretty :: ActiveRepos -> Doc
pretty (ActiveRepos [])
        = String -> Doc
Disp.text String
":none"
    pretty (ActiveRepos [ActiveRepoEntry]
repos)
        = [Doc] -> Doc
Disp.hsep
        forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
Disp.punctuate Doc
Disp.comma
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [ActiveRepoEntry]
repos

-- | Note: empty string is not valid 'ActiveRepos'.
--
-- >>> simpleParsec "" :: Maybe ActiveRepos
-- Nothing
--
-- >>> simpleParsec ":none" :: Maybe ActiveRepos
-- Just (ActiveRepos [])
--
-- >>> simpleParsec ":rest" :: Maybe ActiveRepos
-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge])
--
-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos
-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])
--
instance Parsec ActiveRepos where
    parsec :: forall (m :: * -> *). CabalParsing m => m ActiveRepos
parsec = [ActiveRepoEntry] -> ActiveRepos
ActiveRepos [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (forall (m :: * -> *). CharParsing m => String -> m String
P.string String
":none")
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
            NonEmpty ActiveRepoEntry
repos <- forall (m :: * -> *) a. CabalParsing m => m a -> m (NonEmpty a)
parsecLeadingCommaNonEmpty forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
            forall (m :: * -> *) a. Monad m => a -> m a
return ([ActiveRepoEntry] -> ActiveRepos
ActiveRepos (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty ActiveRepoEntry
repos))

data ActiveRepoEntry
    = ActiveRepoRest CombineStrategy        -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'
    | ActiveRepo RepoName CombineStrategy   -- ^ explicit repository name
  deriving (ActiveRepoEntry -> ActiveRepoEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActiveRepoEntry -> ActiveRepoEntry -> Bool
$c/= :: ActiveRepoEntry -> ActiveRepoEntry -> Bool
== :: ActiveRepoEntry -> ActiveRepoEntry -> Bool
$c== :: ActiveRepoEntry -> ActiveRepoEntry -> Bool
Eq, Int -> ActiveRepoEntry -> ShowS
[ActiveRepoEntry] -> ShowS
ActiveRepoEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActiveRepoEntry] -> ShowS
$cshowList :: [ActiveRepoEntry] -> ShowS
show :: ActiveRepoEntry -> String
$cshow :: ActiveRepoEntry -> String
showsPrec :: Int -> ActiveRepoEntry -> ShowS
$cshowsPrec :: Int -> ActiveRepoEntry -> ShowS
Show, forall x. Rep ActiveRepoEntry x -> ActiveRepoEntry
forall x. ActiveRepoEntry -> Rep ActiveRepoEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ActiveRepoEntry x -> ActiveRepoEntry
$cfrom :: forall x. ActiveRepoEntry -> Rep ActiveRepoEntry x
Generic)

instance Binary ActiveRepoEntry
instance Structured ActiveRepoEntry
instance NFData ActiveRepoEntry

instance Pretty ActiveRepoEntry where
    pretty :: ActiveRepoEntry -> Doc
pretty (ActiveRepoRest CombineStrategy
s) =
        String -> Doc
Disp.text String
":rest" Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
<<>> forall a. Pretty a => a -> Doc
pretty CombineStrategy
s
    pretty (ActiveRepo RepoName
r CombineStrategy
s) =
        forall a. Pretty a => a -> Doc
pretty RepoName
r Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
<<>> forall a. Pretty a => a -> Doc
pretty CombineStrategy
s

instance Parsec ActiveRepoEntry where
    parsec :: forall (m :: * -> *). CabalParsing m => m ActiveRepoEntry
parsec = m ActiveRepoEntry
leadColon forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ActiveRepoEntry
leadRepo where
        leadColon :: m ActiveRepoEntry
leadColon = do
            Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
            String
token <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
P.munch1 Char -> Bool
isAlpha
            case String
token of
                String
"rest" -> CombineStrategy -> ActiveRepoEntry
ActiveRepoRest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m CombineStrategy
strategyP
                String
"repo" -> forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ActiveRepoEntry
leadRepo
                String
_      -> forall (m :: * -> *) a. Parsing m => String -> m a
P.unexpected forall a b. (a -> b) -> a -> b
$ String
"Unknown active repository entry type: " forall a. [a] -> [a] -> [a]
++ String
token

        leadRepo :: m ActiveRepoEntry
leadRepo = do
            RepoName
r <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
            CombineStrategy
s <- m CombineStrategy
strategyP
            forall (m :: * -> *) a. Monad m => a -> m a
return (RepoName -> CombineStrategy -> ActiveRepoEntry
ActiveRepo RepoName
r CombineStrategy
s)

        strategyP :: m CombineStrategy
strategyP = forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option CombineStrategy
CombineStrategyMerge (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec)

data CombineStrategy
    = CombineStrategySkip     -- ^ skip this repository
    | CombineStrategyMerge    -- ^ merge existing versions
    | CombineStrategyOverride -- ^ if later repository specifies a package,
                              --   all package versions are replaced
  deriving (CombineStrategy -> CombineStrategy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CombineStrategy -> CombineStrategy -> Bool
$c/= :: CombineStrategy -> CombineStrategy -> Bool
== :: CombineStrategy -> CombineStrategy -> Bool
$c== :: CombineStrategy -> CombineStrategy -> Bool
Eq, Int -> CombineStrategy -> ShowS
[CombineStrategy] -> ShowS
CombineStrategy -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CombineStrategy] -> ShowS
$cshowList :: [CombineStrategy] -> ShowS
show :: CombineStrategy -> String
$cshow :: CombineStrategy -> String
showsPrec :: Int -> CombineStrategy -> ShowS
$cshowsPrec :: Int -> CombineStrategy -> ShowS
Show, Int -> CombineStrategy
CombineStrategy -> Int
CombineStrategy -> [CombineStrategy]
CombineStrategy -> CombineStrategy
CombineStrategy -> CombineStrategy -> [CombineStrategy]
CombineStrategy
-> CombineStrategy -> CombineStrategy -> [CombineStrategy]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CombineStrategy
-> CombineStrategy -> CombineStrategy -> [CombineStrategy]
$cenumFromThenTo :: CombineStrategy
-> CombineStrategy -> CombineStrategy -> [CombineStrategy]
enumFromTo :: CombineStrategy -> CombineStrategy -> [CombineStrategy]
$cenumFromTo :: CombineStrategy -> CombineStrategy -> [CombineStrategy]
enumFromThen :: CombineStrategy -> CombineStrategy -> [CombineStrategy]
$cenumFromThen :: CombineStrategy -> CombineStrategy -> [CombineStrategy]
enumFrom :: CombineStrategy -> [CombineStrategy]
$cenumFrom :: CombineStrategy -> [CombineStrategy]
fromEnum :: CombineStrategy -> Int
$cfromEnum :: CombineStrategy -> Int
toEnum :: Int -> CombineStrategy
$ctoEnum :: Int -> CombineStrategy
pred :: CombineStrategy -> CombineStrategy
$cpred :: CombineStrategy -> CombineStrategy
succ :: CombineStrategy -> CombineStrategy
$csucc :: CombineStrategy -> CombineStrategy
Enum, CombineStrategy
forall a. a -> a -> Bounded a
maxBound :: CombineStrategy
$cmaxBound :: CombineStrategy
minBound :: CombineStrategy
$cminBound :: CombineStrategy
Bounded, forall x. Rep CombineStrategy x -> CombineStrategy
forall x. CombineStrategy -> Rep CombineStrategy x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CombineStrategy x -> CombineStrategy
$cfrom :: forall x. CombineStrategy -> Rep CombineStrategy x
Generic)

instance Binary CombineStrategy
instance Structured CombineStrategy
instance NFData CombineStrategy

instance Pretty CombineStrategy where
    pretty :: CombineStrategy -> Doc
pretty CombineStrategy
CombineStrategySkip     = String -> Doc
Disp.text String
"skip"
    pretty CombineStrategy
CombineStrategyMerge    = String -> Doc
Disp.text String
"merge"
    pretty CombineStrategy
CombineStrategyOverride = String -> Doc
Disp.text String
"override"

instance Parsec CombineStrategy where
    parsec :: forall (m :: * -> *). CabalParsing m => m CombineStrategy
parsec = forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice
        [ CombineStrategy
CombineStrategySkip     forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"skip"
        , CombineStrategy
CombineStrategyMerge    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"merge"
        , CombineStrategy
CombineStrategyOverride forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"override"
        ]

-------------------------------------------------------------------------------
-- Organisation
-------------------------------------------------------------------------------

-- | Sort values 'RepoName' according to 'ActiveRepos' list.
--
-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"]
-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos
-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]
--
-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos
-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]
--
-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos
-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)]
--
-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos
-- Left "no repository provided d"
--
-- Note: currently if 'ActiveRepoRest' is provided more than once,
-- rest-repositories will be multiple times in the output.
--
organizeByRepos
    :: forall a. ActiveRepos
    -> (a -> RepoName)
    -> [a]
    -> Either String [(a, CombineStrategy)]
organizeByRepos :: forall a.
ActiveRepos
-> (a -> RepoName) -> [a] -> Either String [(a, CombineStrategy)]
organizeByRepos (ActiveRepos [ActiveRepoEntry]
xs0) a -> RepoName
sel [a]
ys0 =
    -- here we use lazyness to do only one traversal
    let ([a]
rest, Either String [(a, CombineStrategy)]
result) = case [a]
-> [ActiveRepoEntry]
-> [a]
-> Either String ([a], [(a, CombineStrategy)])
go [a]
rest [ActiveRepoEntry]
xs0 [a]
ys0 of
            Right ([a]
rest', [(a, CombineStrategy)]
result') -> ([a]
rest', forall a b. b -> Either a b
Right [(a, CombineStrategy)]
result')
            Left String
err               -> ([],    forall a b. a -> Either a b
Left String
err)
    in Either String [(a, CombineStrategy)]
result
  where
    go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])
    go :: [a]
-> [ActiveRepoEntry]
-> [a]
-> Either String ([a], [(a, CombineStrategy)])
go [a]
_rest []                      [a]
ys = forall a b. b -> Either a b
Right ([a]
ys, [])
    go  [a]
rest (ActiveRepoRest CombineStrategy
s : [ActiveRepoEntry]
xs) [a]
ys =
        [a]
-> [ActiveRepoEntry]
-> [a]
-> Either String ([a], [(a, CombineStrategy)])
go [a]
rest [ActiveRepoEntry]
xs [a]
ys forall err s b c.
Either err ([s], b)
-> (([s], b) -> ([s], c)) -> Either err ([s], c)
<&> \([a]
rest', [(a, CombineStrategy)]
result) ->
           ([a]
rest', forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x, CombineStrategy
s)) [a]
rest forall a. [a] -> [a] -> [a]
++ [(a, CombineStrategy)]
result)
    go  [a]
rest (ActiveRepo RepoName
r CombineStrategy
s : [ActiveRepoEntry]
xs)   [a]
ys = do
        (a
z, [a]
zs) <- RepoName -> [a] -> Either String (a, [a])
extract RepoName
r [a]
ys
        [a]
-> [ActiveRepoEntry]
-> [a]
-> Either String ([a], [(a, CombineStrategy)])
go [a]
rest [ActiveRepoEntry]
xs [a]
zs forall err s b c.
Either err ([s], b)
-> (([s], b) -> ([s], c)) -> Either err ([s], c)
<&> \([a]
rest', [(a, CombineStrategy)]
result) ->
            ([a]
rest', (a
z, CombineStrategy
s) forall a. a -> [a] -> [a]
: [(a, CombineStrategy)]
result)

    extract :: RepoName -> [a] -> Either String (a, [a])
    extract :: RepoName -> [a] -> Either String (a, [a])
extract RepoName
r = forall {c}. ([a] -> c) -> [a] -> Either String (a, c)
loop forall a. a -> a
id where
        loop :: ([a] -> c) -> [a] -> Either String (a, c)
loop [a] -> c
_acc []     = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"no repository provided " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow RepoName
r
        loop  [a] -> c
acc (a
x:[a]
xs)
            | a -> RepoName
sel a
x forall a. Eq a => a -> a -> Bool
== RepoName
r = forall a b. b -> Either a b
Right (a
x, [a] -> c
acc [a]
xs)
            | Bool
otherwise  = ([a] -> c) -> [a] -> Either String (a, c)
loop ([a] -> c
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
x forall a. a -> [a] -> [a]
:)) [a]
xs

    (<&>)
        :: Either err ([s], b)
        -> (([s], b) -> ([s], c))
        -> Either err ([s], c)
    <&> :: forall err s b c.
Either err ([s], b)
-> (([s], b) -> ([s], c)) -> Either err ([s], c)
(<&>) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap