{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fold -> Fold -> Bool
$c/= :: Fold -> Fold -> Bool
== :: Fold -> Fold -> Bool
$c== :: Fold -> Fold -> Bool
Eq, Eq 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
min :: Fold -> Fold -> Fold
$cmin :: Fold -> Fold -> Fold
max :: Fold -> Fold -> Fold
$cmax :: Fold -> Fold -> Fold
>= :: Fold -> Fold -> Bool
$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
compare :: Fold -> Fold -> Ordering
$ccompare :: Fold -> Fold -> Ordering
Ord, Int -> Fold -> ShowS
[Fold] -> ShowS
Fold -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fold] -> ShowS
$cshowList :: [Fold] -> ShowS
show :: Fold -> String
$cshow :: Fold -> String
showsPrec :: Int -> Fold -> ShowS
$cshowsPrec :: Int -> Fold -> ShowS
Show, Int -> Fold
Fold -> Int
Fold -> [Fold]
Fold -> Fold
Fold -> Fold -> [Fold]
Fold -> Fold -> Fold -> [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
enumFromThenTo :: Fold -> Fold -> Fold -> [Fold]
$cenumFromThenTo :: Fold -> Fold -> Fold -> [Fold]
enumFromTo :: Fold -> Fold -> [Fold]
$cenumFromTo :: Fold -> Fold -> [Fold]
enumFromThen :: Fold -> Fold -> [Fold]
$cenumFromThen :: Fold -> Fold -> [Fold]
enumFrom :: Fold -> [Fold]
$cenumFrom :: Fold -> [Fold]
fromEnum :: Fold -> Int
$cfromEnum :: Fold -> Int
toEnum :: Int -> Fold
$ctoEnum :: Int -> Fold
pred :: Fold -> Fold
$cpred :: Fold -> Fold
succ :: Fold -> Fold
$csucc :: Fold -> Fold
Enum, Fold
forall a. a -> a -> Bounded a
maxBound :: Fold
$cmaxBound :: Fold
minBound :: Fold
$cminBound :: Fold
Bounded)

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

showFold :: Fold -> String
showFold :: Fold -> String
showFold = ShowS
dashise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  where
    dashise :: ShowS
dashise = forall a. [a] -> [[a]] -> [a]
intercalate String
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
xs0
            (String
zs, String
xs2) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
xs1
        in (String
ys forall a. [a] -> [a] -> [a]
++ String
zs) forall a. a -> [a] -> [a]
: String -> [String]
split String
xs2

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

instance C.Pretty Folds where
    pretty :: Folds -> Doc
pretty = [Doc] -> Doc
PP.fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
PP.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold -> String
showFold) 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
. Folds -> Set Fold
getFolds