@@ -1,78 +1,34 @@
1−{-# LANGUAGE OverloadedStrings, Rank2Types #-}
1+{-# LANGUAGE Rank2Types #-}
22module Reporting.Task
33 ( Task
44 , run
55 , throw
6− -- progress
7− , notify
8− , ask
9− -- io
6+ --
107 , io
118 , eio
12− , withKey
139 )
1410 where
1511
1612
17−import qualified System.Exit as Exit
18−
19−import qualified Reporting.Doc as D
20−import qualified Reporting.Exit as Exit
21−import qualified Reporting.Progress as Progress
22−
23−
2413
2514-- TASKS
2615
2716
28−newtype Task a =
17+newtype Task x a =
2918 Task
3019 (
31− forall result.
32− Env
33− -> (a -> IO result)
34− -> (Exit.Exit -> IO result)
35− -> IO result
20+ forall result. (a -> IO result) -> (x -> IO result) -> IO result
3621 )
3722
3823
39−data Env =
40− Env
41− { _tell :: Progress.Progress -> IO ()
42− , _ask :: D.Doc -> IO Bool
43− }
44−
45−
46−run :: Progress.Reporter -> Task a -> IO ()
47−run (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− )
57−
58−
59−throw :: Exit.Exit -> Task a
60−throw exit =
61− Task $ \_ _ err -> err exit
62−
24+run :: Task x a -> IO (Either x a)
25+run (Task task) =
26+ task (return . Right) (return . Left)
6327
6428
65−-- PROGRESS
66−
67−
68−notify :: Progress.Progress -> Task ()
69−notify progress =
70− Task $ \(Env pTell _) ok _ -> pTell progress >>= ok
71−
72−
73−ask :: D.Doc -> Task Bool
74−ask question =
75− Task $ \(Env _ pAsk) ok _ -> pAsk question >>= ok
29+throw :: x -> Task x a
30+throw x =
31+ Task $ \_ err -> err x
7632
7733
7834
@@ -80,71 +36,62 @@ ask question =
8036
8137
8238{-# INLINE io #-}
83−io :: IO a -> Task a
39+io :: IO a -> Task x a
8440io work =
85− Task $ \_ ok _ -> work >>= ok
41+ Task $ \ok _ -> work >>= ok
8642
8743
88−eio :: (x -> Exit.Exit) -> IO (Either x a) -> Task a
44+eio :: (x -> y) -> IO (Either x a) -> Task y a
8945eio func work =
90− Task $ \_ ok err ->
46+ Task $ \ok err ->
9147 do result <- work
9248 case result of
9349 Right a -> ok a
94− Left e -> err (func e)
95−
96−
97−withKey :: (Progress.Key -> IO (Either Exit.Exit a)) -> Task a
98−withKey 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
50+ Left x -> err (func x)
10451
10552
10653
10754-- INSTANCES
10855
10956
110−instance Functor Task where
57+instance Functor (Task x) where
11158 {-# INLINE fmap #-}
11259 fmap func (Task taskA) =
113− Task $ \env ok err ->
60+ Task $ \ok err ->
11461 let
11562 okA arg = ok (func arg)
11663 in
117− taskA env okA err
64+ taskA okA err
11865
11966
120−instance Applicative Task where
67+instance Applicative (Task x) where
12168 {-# INLINE pure #-}
12269 pure a =
123− Task $ \_ ok _ -> ok a
70+ Task $ \ok _ -> ok a
12471
12572 {-# INLINE (<*>) #-}
12673 (<*>) (Task taskFunc) (Task taskArg) =
127− Task $ \env ok err ->
74+ Task $ \ok err ->
12875 let
12976 okFunc func =
13077 let
13178 okArg arg = ok (func arg)
13279 in
133− taskArg env okArg err
80+ taskArg okArg err
13481 in
135− taskFunc env okFunc err
82+ taskFunc okFunc err
13683
13784
138−instance Monad Task where
85+instance Monad (Task x) where
13986 {-# INLINE return #-}
14087 return = pure
14188
14289 {-# INLINE (>>=) #-}
14390 (>>=) (Task taskA) callback =
144− Task $ \env ok err ->
91+ Task $ \ok err ->
14592 let
14693 okA a =
14794 case callback a of
148− Task taskB -> taskB env ok err
95+ Task taskB -> taskB ok err
14996 in
150− taskA env okA err
97+ taskA okA err