Command.hs 4.95 KB
Newer Older
1
module System.Console.Haskeline.Command(
judah's avatar
judah committed
2
3
                        -- * Commands
                        Effect(..),
4
                        KeyMap(..), 
judah's avatar
judah committed
5
6
7
                        CmdM(..),
                        Command,
                        KeyCommand,
8
9
10
                        KeyConsumed(..),
                        withoutConsuming,
                        keyCommand,
judah's avatar
judah committed
11
12
13
                        (>|>),
                        (>+>),
                        try,
judah's avatar
judah committed
14
15
                        effect,
                        clearScreenCmd,
judah's avatar
judah committed
16
                        finish,
17
                        failCmd,
judah's avatar
judah committed
18
                        simpleCommand,
19
                        charCommand,
judah's avatar
judah committed
20
                        setState,
judah's avatar
judah committed
21
                        change,
22
                        changeFromChar,
judah's avatar
judah committed
23
                        (+>),
judah's avatar
judah committed
24
                        useChar,
25
                        choiceCmd,
26
                        keyChoiceCmd,
judah's avatar
judah committed
27
28
                        keyChoiceCmdM,
                        doBefore
judah's avatar
judah committed
29
                        ) where
judah's avatar
judah committed
30

31
import Data.Char(isPrint)
32
33
import Control.Applicative(Applicative(..))
import Control.Monad(ap, mplus, liftM)
34
import Control.Monad.Trans.Class
35
import System.Console.Haskeline.LineState
36
import System.Console.Haskeline.Key
37

38
data Effect = LineChange (Prefix -> LineChars)
judah's avatar
judah committed
39
40
              | PrintLines [String]
              | ClearScreen
41
              | RingBell
42

judah's avatar
judah committed
43
44
45
46
lineChange :: LineState s => s -> Effect
lineChange = LineChange . flip lineChars

data KeyMap a = KeyMap {lookupKM :: Key -> Maybe (KeyConsumed a)}
47

48
data KeyConsumed a = NotConsumed a | Consumed a
49

judah's avatar
judah committed
50
instance Functor KeyMap where
judah's avatar
judah committed
51
    fmap f km = KeyMap $ fmap (fmap f) . lookupKM km
52

judah's avatar
judah committed
53
54
55
instance Functor KeyConsumed where
    fmap f (NotConsumed x) = NotConsumed (f x)
    fmap f (Consumed x) = Consumed (f x)
56
57


judah's avatar
judah committed
58
59
60
61
62
63
data CmdM m a   = GetKey (KeyMap (CmdM m a))
                | DoEffect Effect (CmdM m a)
                | CmdM (m (CmdM m a))
                | Result a

type Command m s t = s -> CmdM m t
judah's avatar
judah committed
64

65
66
67
68
instance Monad m => Functor (CmdM m) where
    fmap = liftM

instance Monad m => Applicative (CmdM m) where
69
    pure  = Result
70
71
    (<*>) = ap

judah's avatar
judah committed
72
instance Monad m => Monad (CmdM m) where
73
    return = pure
74

judah's avatar
judah committed
75
76
77
78
    GetKey km >>= g = GetKey $ fmap (>>= g) km
    DoEffect e f >>= g = DoEffect e (f >>= g)
    CmdM f >>= g = CmdM $ liftM (>>= g) f
    Result x >>= g = g x
judah's avatar
judah committed
79

judah's avatar
judah committed
80
81
82
83
84
85
86
87
88
89
90
91
92
93
type KeyCommand m s t = KeyMap (Command m s t)

instance MonadTrans CmdM where
    lift m = CmdM $ do
        x <- m
        return $ Result x

keyCommand :: KeyCommand m s t -> Command m s t
keyCommand km = \s -> GetKey $ fmap ($ s) km

useKey :: Key -> a -> KeyMap a
useKey k x = KeyMap $ \k' -> if k==k' then Just (Consumed x) else Nothing

-- TODO: could just be a monadic action that returns a Char.
judah's avatar
judah committed
94
useChar :: (Char -> Command m s t) -> KeyCommand m s t
judah's avatar
judah committed
95
96
97
98
useChar act = KeyMap $ \k -> case k of
                    Key m (KeyChar c) | isPrint c && m==noModifier
                        -> Just $ Consumed (act c)
                    _ -> Nothing
judah's avatar
judah committed
99

100
withoutConsuming :: Command m s t -> KeyCommand m s t
judah's avatar
judah committed
101
withoutConsuming = KeyMap . const . Just . NotConsumed
judah's avatar
judah committed
102

judah's avatar
judah committed
103
104
choiceCmd :: [KeyMap a] -> KeyMap a
choiceCmd = foldl orKM nullKM
105
106
107
    where
        nullKM = KeyMap $ const Nothing
        orKM (KeyMap f) (KeyMap g) = KeyMap $ \k -> f k `mplus` g k
108

109
110
111
keyChoiceCmd :: [KeyCommand m s t] -> Command m s t
keyChoiceCmd = keyCommand . choiceCmd

judah's avatar
judah committed
112
113
keyChoiceCmdM :: [KeyMap (CmdM m a)] -> CmdM m a
keyChoiceCmdM = GetKey . choiceCmd
114
115

infixr 6 >|>
judah's avatar
judah committed
116
117
(>|>) :: Monad m => Command m s t -> Command m t u -> Command m s u
f >|> g = \x -> f x >>= g
118

119
infixr 6 >+>
judah's avatar
judah committed
120
121
(>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u
km >+> g = fmap (>|> g) km
122

123
124
-- attempt to run the command (predicated on getting a valid key); but if it fails, just keep
-- going.
judah's avatar
judah committed
125
126
try :: Monad m => KeyCommand m s s -> Command m s s
try f = keyChoiceCmd [f,withoutConsuming return]
127

128
infixr 6 +>
judah's avatar
judah committed
129
(+>) :: Key -> a -> KeyMap a
judah's avatar
judah committed
130
(+>) = useKey
judah's avatar
judah committed
131

judah's avatar
judah committed
132
finish :: (Monad m, Result s) => Command m s (Maybe String)
judah's avatar
judah committed
133
finish = return . Just . toResult
134

judah's avatar
judah committed
135
136
failCmd :: Monad m => Command m s (Maybe a)
failCmd _ = return Nothing
137

judah's avatar
judah committed
138
139
effect :: Effect -> CmdM m ()
effect e = DoEffect e $ Result ()
140

judah's avatar
judah committed
141
clearScreenCmd :: Command m s s
judah's avatar
judah committed
142
clearScreenCmd = DoEffect ClearScreen . Result
143

judah's avatar
judah committed
144
145
146
147
148
149
150
simpleCommand :: (LineState s, Monad m) => (s -> m (Either Effect s))
        -> Command m s s
simpleCommand f = \s -> do
    et <- lift (f s)
    case et of
        Left e -> effect e >> return s
        Right t -> setState t
151

152
153
charCommand :: (LineState s, Monad m) => (Char -> s -> m (Either Effect s))
                    -> KeyCommand m s s
judah's avatar
judah committed
154
charCommand f = useChar $ simpleCommand . f
155

judah's avatar
judah committed
156
157
setState :: (Monad m, LineState s) => Command m s s
setState s = effect (lineChange s) >> return s
judah's avatar
judah committed
158

judah's avatar
judah committed
159
change :: (LineState t, Monad m) => (s -> t) -> Command m s t
judah's avatar
judah committed
160
change = (setState .)
161

162
changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t
judah's avatar
judah committed
163
164
165
166
changeFromChar f = useChar $ change . f

doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u
doBefore cmd = fmap (cmd >|>)