git.iko.soy/elk
on 7b60982 help sign in
elk/builder/src/Reporting/Task.hs
97 lines 1.5 kB history raw
1{-# LANGUAGE Rank2Types #-}
2module Reporting.Task
3 ( Task
4 , run
5 , throw
6 --
7 , io
8 , eio
9 )
10 where
14-- TASKS
17newtype Task x a =
18 Task
19 (
20 forall result. (a -> IO result) -> (x -> IO result) -> IO result
21 )
24run :: Task x a -> IO (Either x a)
25run (Task task) =
26 task (return . Right) (return . Left)
29throw :: x -> Task x a
30throw x =
31 Task $ \_ err -> err x
35-- IO
38{-# INLINE io #-}
39io :: IO a -> Task x a
40io work =
41 Task $ \ok _ -> work >>= ok
44eio :: (x -> y) -> IO (Either x a) -> Task y a
45eio func work =
46 Task $ \ok err ->
47 do result <- work
48 case result of
49 Right a -> ok a
50 Left x -> err (func x)
54-- INSTANCES
57instance Functor (Task x) where
58 {-# INLINE fmap #-}
59 fmap func (Task taskA) =
60 Task $ \ok err ->
61 let
62 okA arg = ok (func arg)
63 in
64 taskA okA err
67instance Applicative (Task x) where
68 {-# INLINE pure #-}
69 pure a =
70 Task $ \ok _ -> ok a
72 {-# INLINE (<*>) #-}
73 (<*>) (Task taskFunc) (Task taskArg) =
74 Task $ \ok err ->
75 let
76 okFunc func =
77 let
78 okArg arg = ok (func arg)
79 in
80 taskArg okArg err
81 in
82 taskFunc okFunc err
85instance Monad (Task x) where
86 {-# INLINE return #-}
87 return = pure
89 {-# INLINE (>>=) #-}
90 (>>=) (Task taskA) callback =
91 Task $ \ok err ->
92 let
93 okA a =
94 case callback a of
95 Task taskB -> taskB ok err
96 in
97 taskA okA err