Base.hs 1.98 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
{-# LANGUAGE FlexibleInstances #-}
Andrey Mokhov's avatar
Andrey Mokhov committed
2

3
4
5
6
7
module Base (
    module Development.Shake,
    module Development.Shake.FilePath,
    module Control.Applicative,
    module Data.Monoid,
8
    module Data.List,
9
    Stage (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
10
    Args, arg, args, ShowAction (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
11
    Condition (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
12
    joinArgs, joinArgsSpaced, splitArgs,
13
    filterOut
14
15
    ) where

Andrey Mokhov's avatar
Andrey Mokhov committed
16
import Development.Shake
17
import Development.Shake.FilePath
Andrey Mokhov's avatar
Andrey Mokhov committed
18
import Control.Applicative hiding ((*>))
19
20
21
22
23
24
25
import Data.Monoid
import Data.List

data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum)

type Args = Action [String]

Andrey Mokhov's avatar
Andrey Mokhov committed
26
27
type Condition = Action Bool

28
29
30
31
instance Monoid a => Monoid (Action a) where
    mempty = return mempty
    mappend p q = mappend <$> p <*> q

Andrey Mokhov's avatar
Andrey Mokhov committed
32
class ShowAction a where
Andrey Mokhov's avatar
Andrey Mokhov committed
33
34
35
36
37
38
39
    showAction     :: a -> Args
    showListAction :: [a] -> Args -- the Creators' trick for overlapping String instances
    showListAction = mconcat . map showAction

instance ShowAction Char where
    showAction c     = return [[c]]
    showListAction s = return [s]
Andrey Mokhov's avatar
Andrey Mokhov committed
40

Andrey Mokhov's avatar
Andrey Mokhov committed
41
42
instance ShowAction a => ShowAction [a] where
    showAction = showListAction
Andrey Mokhov's avatar
Andrey Mokhov committed
43

Andrey Mokhov's avatar
Andrey Mokhov committed
44
45
instance ShowAction a => ShowAction (Action a) where
    showAction = (showAction =<<)
46

Andrey Mokhov's avatar
Andrey Mokhov committed
47
48
arg :: ShowAction a => a -> Args
arg = showAction
49

50
51
type ArgsCombine = Args -> Args -> Args

52
class Collect a where
53
    collect :: ArgsCombine -> Args -> a
54
55

instance Collect Args where
56
    collect = const id
57
58

instance (ShowAction a, Collect r) => Collect (a -> r) where
Andrey Mokhov's avatar
Andrey Mokhov committed
59
    collect combine x = \y -> collect combine $ x `combine` arg y
60
61

args :: Collect a => a
62
args = collect (<>) mempty
63

64
joinArgs :: Collect a => a
Andrey Mokhov's avatar
Andrey Mokhov committed
65
joinArgs = collect (\x y -> intercalateArgs "" $ x <> y) mempty
66

Andrey Mokhov's avatar
Andrey Mokhov committed
67
68
joinArgsSpaced :: Collect a => a
joinArgsSpaced = collect (\x y -> intercalateArgs " " $ x <> y) mempty
69

70
71
72
73
intercalateArgs :: String -> Args -> Args
intercalateArgs s as = do
    as' <- as
    return [intercalate s as']
74

75
76
77
splitArgs :: Args -> Args
splitArgs = fmap (concatMap words)

78
filterOut :: Args -> [String] -> Args
79
filterOut as list = filter (`notElem` list) <$> as