Base.hs 2.27 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
module Base (
    module Development.Shake,
    module Development.Shake.FilePath,
    module Control.Applicative,
7
    module Data.Function,
8
    module Data.Monoid,
9
    module Data.List,
10
    Stage (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
11
    Args, arg, ShowArgs (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
12
    Condition (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
13
    (<+>),
Andrey Mokhov's avatar
Andrey Mokhov committed
14
    filterOut,
15
    productArgs, concatArgs
16
17
    ) where

18
import Development.Shake hiding ((*>))
19
import Development.Shake.FilePath
20
import Control.Applicative
21
import Data.Function
22
23
24
25
26
import Data.Monoid
import Data.List

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

Andrey Mokhov's avatar
Andrey Mokhov committed
27
28
29
instance Show Stage where
    show = show . fromEnum

Andrey Mokhov's avatar
Andrey Mokhov committed
30
31
-- The returned list of strings is a list of arguments
-- to be passed to a Builder
32
33
type Args = Action [String]

Andrey Mokhov's avatar
Andrey Mokhov committed
34
35
type Condition = Action Bool

36
37
38
39
instance Monoid a => Monoid (Action a) where
    mempty = return mempty
    mappend p q = mappend <$> p <*> q

40
-- Using the Creators' trick for overlapping String instances
Andrey Mokhov's avatar
Andrey Mokhov committed
41
42
class ShowArgs a where
    showArgs     :: a -> Args
43
    showListArgs :: [a] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
44
    showListArgs = mconcat . map showArgs
Andrey Mokhov's avatar
Andrey Mokhov committed
45

Andrey Mokhov's avatar
Andrey Mokhov committed
46
47
48
instance ShowArgs Char where
    showArgs c     = return [[c]]
    showListArgs s = return [s]
Andrey Mokhov's avatar
Andrey Mokhov committed
49

Andrey Mokhov's avatar
Andrey Mokhov committed
50
51
instance ShowArgs a => ShowArgs [a] where
    showArgs = showListArgs
Andrey Mokhov's avatar
Andrey Mokhov committed
52

Andrey Mokhov's avatar
Andrey Mokhov committed
53
54
instance ShowArgs a => ShowArgs (Action a) where
    showArgs = (showArgs =<<)
55

Andrey Mokhov's avatar
Andrey Mokhov committed
56
57
arg :: ShowArgs a => a -> Args
arg = showArgs
58

Andrey Mokhov's avatar
Andrey Mokhov committed
59
-- Combine two heterogeneous ShowArgs values
Andrey Mokhov's avatar
Andrey Mokhov committed
60
61
(<+>) :: (ShowArgs a, ShowArgs b) => a -> b -> Args
a <+> b = (<>) <$> showArgs a <*> showArgs b
62

Andrey Mokhov's avatar
Andrey Mokhov committed
63
64
infixr 6 <+>

Andrey Mokhov's avatar
Andrey Mokhov committed
65
-- Filter out given arg(s) from a collection
Andrey Mokhov's avatar
Andrey Mokhov committed
66
67
68
69
filterOut :: ShowArgs a => Args -> a -> Args
filterOut as exclude = do
    exclude' <- showArgs exclude
    filter (`notElem` exclude') <$> as
Andrey Mokhov's avatar
Andrey Mokhov committed
70

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
-- Generate a cross product collection of two argument collections
-- Example: productArgs ["-a", "-b"] "c" = arg ["-a", "c", "-b", "c"]
productArgs :: (ShowArgs a, ShowArgs b) => a -> b -> Args
productArgs as bs = do
    as' <- showArgs as
    bs' <- showArgs bs
    return $ concat $ sequence [as', bs']

-- Similar to productArgs but concat resulting arguments pairwise
-- Example: concatArgs ["-a", "-b"] "c" = arg ["-ac", "-bc"]
concatArgs :: (ShowArgs a, ShowArgs b) => a -> b -> Args
concatArgs as bs = do
    as' <- showArgs as
    bs' <- showArgs bs
    return $ map concat $ sequence [as', bs']