git.iko.soy/elk
on 436f495 help sign in
elk/builder/src/Reporting/Task.hs
150 lines 2.5 kB history raw
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Reporting.Task
3 ( Task
4 , run
5 , throw
6 -- progress
7 , notify
8 , ask
9 -- io
10 , io
11 , eio
12 , withKey
13 )
14 where
17import qualified System.Exit as Exit
19import qualified Reporting.Doc as D
20import qualified Reporting.Exit as Exit
21import qualified Reporting.Progress as Progress
25-- TASKS
28newtype Task a =
29 Task
30 (
31 forall result.
32 Env
33 -> (a -> IO result)
34 -> (Exit.Exit -> IO result)
35 -> IO result
36 )
39data Env =
40 Env
41 { _tell :: Progress.Progress -> IO ()
42 , _ask :: D.Doc -> IO Bool
43 }
46run :: Progress.Reporter -> Task a -> IO ()
47run (Progress.Reporter pTell pAsk pEnd) (Task task) =
48 task (Env pTell pAsk)
49 (\_ ->
50 do pEnd Nothing
51 return ()
52 )
53 (\exit ->
54 do pEnd (Just exit)
55 Exit.exitFailure
56 )
59throw :: Exit.Exit -> Task a
60throw exit =
61 Task $ \_ _ err -> err exit
65-- PROGRESS
68notify :: Progress.Progress -> Task ()
69notify progress =
70 Task $ \(Env pTell _) ok _ -> pTell progress >>= ok
73ask :: D.Doc -> Task Bool
74ask question =
75 Task $ \(Env _ pAsk) ok _ -> pAsk question >>= ok
79-- IO
82{-# INLINE io #-}
83io :: IO a -> Task a
84io work =
85 Task $ \_ ok _ -> work >>= ok
88eio :: (x -> Exit.Exit) -> IO (Either x a) -> Task a
89eio func work =
90 Task $ \_ ok err ->
91 do result <- work
92 case result of
93 Right a -> ok a
94 Left e -> err (func e)
97withKey :: (Progress.Key -> IO (Either Exit.Exit a)) -> Task a
98withKey callback =
99 Task $ \(Env pTell _) ok err ->
100 do result <- callback (Progress.Key pTell)
101 case result of
102 Right a -> ok a
103 Left e -> err e
107-- INSTANCES
110instance Functor Task where
111 {-# INLINE fmap #-}
112 fmap func (Task taskA) =
113 Task $ \env ok err ->
114 let
115 okA arg = ok (func arg)
116 in
117 taskA env okA err
120instance Applicative Task where
121 {-# INLINE pure #-}
122 pure a =
123 Task $ \_ ok _ -> ok a
125 {-# INLINE (<*>) #-}
126 (<*>) (Task taskFunc) (Task taskArg) =
127 Task $ \env ok err ->
128 let
129 okFunc func =
130 let
131 okArg arg = ok (func arg)
132 in
133 taskArg env okArg err
134 in
135 taskFunc env okFunc err
138instance Monad Task where
139 {-# INLINE return #-}
140 return = pure
142 {-# INLINE (>>=) #-}
143 (>>=) (Task taskA) callback =
144 Task $ \env ok err ->
145 let
146 okA a =
147 case callback a of
148 Task taskB -> taskB env ok err
149 in
150 taskA env okA err