{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module HaskellCI.Config.Folds where

import HaskellCI.Prelude

import qualified Data.Map.Strict                 as M
import qualified Data.Set                        as S
import qualified Distribution.Compat.CharParsing as C
import qualified Distribution.Compat.Newtype     as C
import qualified Distribution.Parsec             as C
import qualified Distribution.Pretty             as C
import qualified Text.PrettyPrint                as PP

data Fold
    = FoldSDist
    | FoldUnpack
    | FoldBuild
    | FoldBuildInstalled
    | FoldBuildEverything
    | FoldTest
    | FoldHaddock
    | FoldStackage
    | FoldCheck
    | FoldDoctest
    | FoldHLint
    | FoldConstraintSets
  deriving (Fold -> Fold -> Bool
(Fold -> Fold -> Bool) -> (Fold -> Fold -> Bool) -> Eq Fold
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fold -> Fold -> Bool
== :: Fold -> Fold -> Bool
$c/= :: Fold -> Fold -> Bool
/= :: Fold -> Fold -> Bool
Eq, Eq Fold
Eq Fold =>
(Fold -> Fold -> Ordering)
-> (Fold -> Fold -> Bool)
-> (Fold -> Fold -> Bool)
-> (Fold -> Fold -> Bool)
-> (Fold -> Fold -> Bool)
-> (Fold -> Fold -> Fold)
-> (Fold -> Fold -> Fold)
-> Ord Fold
Fold -> Fold -> Bool
Fold -> Fold -> Ordering
Fold -> Fold -> Fold
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fold -> Fold -> Ordering
compare :: Fold -> Fold -> Ordering
$c< :: Fold -> Fold -> Bool
< :: Fold -> Fold -> Bool
$c<= :: Fold -> Fold -> Bool
<= :: Fold -> Fold -> Bool
$c> :: Fold -> Fold -> Bool
> :: Fold -> Fold -> Bool
$c>= :: Fold -> Fold -> Bool
>= :: Fold -> Fold -> Bool
$cmax :: Fold -> Fold -> Fold
max :: Fold -> Fold -> Fold
$cmin :: Fold -> Fold -> Fold
min :: Fold -> Fold -> Fold
Ord, Int -> Fold -> ShowS
[Fold] -> ShowS
Fold -> String
(Int -> Fold -> ShowS)
-> (Fold -> String) -> ([Fold] -> ShowS) -> Show Fold
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fold -> ShowS
showsPrec :: Int -> Fold -> ShowS
$cshow :: Fold -> String
show :: Fold -> String
$cshowList :: [Fold] -> ShowS
showList :: [Fold] -> ShowS
Show, Int -> Fold
Fold -> Int
Fold -> [Fold]
Fold -> Fold
Fold -> Fold -> [Fold]
Fold -> Fold -> Fold -> [Fold]
(Fold -> Fold)
-> (Fold -> Fold)
-> (Int -> Fold)
-> (Fold -> Int)
-> (Fold -> [Fold])
-> (Fold -> Fold -> [Fold])
-> (Fold -> Fold -> [Fold])
-> (Fold -> Fold -> Fold -> [Fold])
-> Enum Fold
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Fold -> Fold
succ :: Fold -> Fold
$cpred :: Fold -> Fold
pred :: Fold -> Fold
$ctoEnum :: Int -> Fold
toEnum :: Int -> Fold
$cfromEnum :: Fold -> Int
fromEnum :: Fold -> Int
$cenumFrom :: Fold -> [Fold]
enumFrom :: Fold -> [Fold]
$cenumFromThen :: Fold -> Fold -> [Fold]
enumFromThen :: Fold -> Fold -> [Fold]
$cenumFromTo :: Fold -> Fold -> [Fold]
enumFromTo :: Fold -> Fold -> [Fold]
$cenumFromThenTo :: Fold -> Fold -> Fold -> [Fold]
enumFromThenTo :: Fold -> Fold -> Fold -> [Fold]
Enum, Fold
Fold -> Fold -> Bounded Fold
forall a. a -> a -> Bounded a
$cminBound :: Fold
minBound :: Fold
$cmaxBound :: Fold
maxBound :: Fold
Bounded)

-------------------------------------------------------------------------------
-- Functions
-------------------------------------------------------------------------------

showFold :: Fold -> String
showFold :: Fold -> String
showFold = ShowS
dashise ShowS -> (Fold -> String) -> Fold -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
4 ShowS -> (Fold -> String) -> Fold -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold -> String
forall a. Show a => a -> String
show
  where
    dashise :: ShowS
dashise = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
split

    split :: String -> [String]
split [] = []
    split String
xs0 =
        let (String
ys, String
xs1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
xs0
            (String
zs, String
xs2) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
xs1
        in (String
ys String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
zs) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
split String
xs2

possibleFolds :: [Fold]
possibleFolds :: [Fold]
possibleFolds = [Fold
forall a. Bounded a => a
minBound .. Fold
forall a. Bounded a => a
maxBound]

-------------------------------------------------------------------------------
-- Folds
-------------------------------------------------------------------------------

newtype Folds = Folds { Folds -> Set Fold
getFolds :: S.Set Fold }
  deriving anyclass (C.Newtype (S.Set Fold))

instance C.Parsec Folds where
    parsec :: forall (m :: * -> *). CabalParsing m => m Folds
parsec = ([Set Fold] -> Folds) -> m [Set Fold] -> m Folds
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set Fold -> Folds
Folds (Set Fold -> Folds)
-> ([Set Fold] -> Set Fold) -> [Set Fold] -> Folds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set Fold] -> Set Fold
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions) (m [Set Fold] -> m Folds) -> m [Set Fold] -> m Folds
forall a b. (a -> b) -> a -> b
$ m (Set Fold) -> m [Set Fold]
forall {f :: * -> *} {a}. CharParsing f => f a -> f [a]
manySpaces (m (Set Fold) -> m [Set Fold]) -> m (Set Fold) -> m [Set Fold]
forall a b. (a -> b) -> a -> b
$ do
        String
t <- m String
forall (m :: * -> *). CabalParsing m => m String
C.parsecToken'
        case String
t of
            String
"all"          -> Set Fold -> m (Set Fold)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Fold -> m (Set Fold)) -> Set Fold -> m (Set Fold)
forall a b. (a -> b) -> a -> b
$ [Fold] -> Set Fold
forall a. Ord a => [a] -> Set a
S.fromList [Fold]
possibleFolds
            String
"all-but-test" -> Set Fold -> m (Set Fold)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Fold -> m (Set Fold)) -> Set Fold -> m (Set Fold)
forall a b. (a -> b) -> a -> b
$  Fold -> Set Fold -> Set Fold
forall a. Ord a => a -> Set a -> Set a
S.delete Fold
FoldTest (Set Fold -> Set Fold) -> Set Fold -> Set Fold
forall a b. (a -> b) -> a -> b
$ [Fold] -> Set Fold
forall a. Ord a => [a] -> Set a
S.fromList [Fold]
possibleFolds
            String
n -> case String -> Map String Fold -> Maybe Fold
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
n Map String Fold
ps of
                Just Fold
n' -> Set Fold -> m (Set Fold)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Fold -> m (Set Fold)) -> Set Fold -> m (Set Fold)
forall a b. (a -> b) -> a -> b
$ Fold -> Set Fold
forall a. a -> Set a
S.singleton Fold
n'
                Maybe Fold
Nothing -> String -> m (Set Fold)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Set Fold)) -> String -> m (Set Fold)
forall a b. (a -> b) -> a -> b
$ String
"Illegal fold name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n
      where
        ps :: Map String Fold
ps = [(String, Fold)] -> Map String Fold
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Fold)] -> Map String Fold)
-> [(String, Fold)] -> Map String Fold
forall a b. (a -> b) -> a -> b
$ (Fold -> (String, Fold)) -> [Fold] -> [(String, Fold)]
forall a b. (a -> b) -> [a] -> [b]
map (\Fold
x -> (Fold -> String
showFold Fold
x, Fold
x)) [Fold]
possibleFolds
        manySpaces :: f a -> f [a]
manySpaces f a
p = f a -> f [a]
forall a. f a -> f [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
C.many (f a
p f a -> f () -> f a
forall a b. f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* f ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces)

instance C.Pretty Folds where
    pretty :: Folds -> Doc
pretty = [Doc] -> Doc
PP.fsep ([Doc] -> Doc) -> (Folds -> [Doc]) -> Folds -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fold -> Doc) -> [Fold] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
PP.text (String -> Doc) -> (Fold -> String) -> Fold -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold -> String
showFold) ([Fold] -> [Doc]) -> (Folds -> [Fold]) -> Folds -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Fold -> [Fold]
forall a. Set a -> [a]
S.toList (Set Fold -> [Fold]) -> (Folds -> Set Fold) -> Folds -> [Fold]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Folds -> Set Fold
getFolds