Base.hs 2.57 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 (..),
11
12
13
    Arg, Args,
    ShowArg (..), ShowArgs (..),
    arg, args,
Andrey Mokhov's avatar
Andrey Mokhov committed
14
    Condition (..),
Andrey Mokhov's avatar
Andrey Mokhov committed
15
    (<+>),
Andrey Mokhov's avatar
Andrey Mokhov committed
16
    filterOut,
17
    productArgs, concatArgs
18
19
    ) where

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
29
30
31
instance Show Stage where
    show = show . fromEnum

32
-- The returned string or list of strings is a part of an argument list
Andrey Mokhov's avatar
Andrey Mokhov committed
33
-- to be passed to a Builder
34
type Arg  = Action String
35
36
type Args = Action [String]

Andrey Mokhov's avatar
Andrey Mokhov committed
37
38
type Condition = Action Bool

39
40
41
42
instance Monoid a => Monoid (Action a) where
    mempty = return mempty
    mappend p q = mappend <$> p <*> q

43
class ShowArg a where
44
45
46
47
48
49
50
    showArg :: a -> Arg

instance ShowArg String where
    showArg = return

instance ShowArg a => ShowArg (Action a) where
    showArg = (showArg =<<)
51

52
-- Using the Creators' trick for overlapping String instances
Andrey Mokhov's avatar
Andrey Mokhov committed
53
54
class ShowArgs a where
    showArgs     :: a -> Args
55
    showListArgs :: [a] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
56
    showListArgs = mconcat . map showArgs
Andrey Mokhov's avatar
Andrey Mokhov committed
57

Andrey Mokhov's avatar
Andrey Mokhov committed
58
59
60
instance ShowArgs Char where
    showArgs c     = return [[c]]
    showListArgs s = return [s]
Andrey Mokhov's avatar
Andrey Mokhov committed
61

Andrey Mokhov's avatar
Andrey Mokhov committed
62
63
instance ShowArgs a => ShowArgs [a] where
    showArgs = showListArgs
Andrey Mokhov's avatar
Andrey Mokhov committed
64

Andrey Mokhov's avatar
Andrey Mokhov committed
65
66
instance ShowArgs a => ShowArgs (Action a) where
    showArgs = (showArgs =<<)
67

68
69
70
71
72
args :: ShowArgs a => a -> Args
args = showArgs

arg :: ShowArg a => a -> Args
arg = args . showArg
73

Andrey Mokhov's avatar
Andrey Mokhov committed
74
-- Combine two heterogeneous ShowArgs values
Andrey Mokhov's avatar
Andrey Mokhov committed
75
76
(<+>) :: (ShowArgs a, ShowArgs b) => a -> b -> Args
a <+> b = (<>) <$> showArgs a <*> showArgs b
77

Andrey Mokhov's avatar
Andrey Mokhov committed
78
79
infixr 6 <+>

Andrey Mokhov's avatar
Andrey Mokhov committed
80
-- Filter out given arg(s) from a collection
Andrey Mokhov's avatar
Andrey Mokhov committed
81
82
83
84
filterOut :: ShowArgs a => Args -> a -> Args
filterOut as exclude = do
    exclude' <- showArgs exclude
    filter (`notElem` exclude') <$> as
Andrey Mokhov's avatar
Andrey Mokhov committed
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
-- 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']