git.iko.soy/elk
on master help sign in
Have the Task type do less work / use CPS implementation
58a25d5Evan Czaplicki
builder/src/Reporting/Task.hs+96−135
compare with master
unifiedsplit
@@ -1,38 +1,21 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Reporting.Task
2module Reporting.Task
3− ( Task, Task_
3+ ( Task
4− , try
5 , run
4 , run
6 , throw
5 , throw
7− , mapError
6+ -- progress
8− , Env
7+ , notify
9− , getPackageCacheDir
8+ , ask
10− , getPackageCacheDirFor
9+ -- io
11− , report
10+ , io
12− , getReporter
11+ , eio
13− , getApproval
12+ , withKey
14− , silently
15− , getSilentRunner
16− , workerChan
17− , runHttp
18 )
13 )
19 where
14 where
20
15
21−import Control.Concurrent (forkIO)
16+
22−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
23−import Control.Monad (forever, join, replicateM_)
24−import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
25−import qualified Control.Monad.Reader as R
26−import Control.Monad.Trans (liftIO)
27−import qualified Network.HTTP.Client as Http
28−import qualified Network.HTTP.Client.TLS as Http
29−import qualified System.Directory as Dir
30import qualified System.Exit as Exit
17import qualified System.Exit as Exit
31−import System.FilePath ((</>))
32
18
33−import qualified Elm.Package as Pkg
34−import qualified Elm.PerUserCache as PerUserCache
35−import qualified Elm.Version as V
36import qualified Reporting.Doc as D
19import qualified Reporting.Doc as D
37import qualified Reporting.Exit as Exit
20import qualified Reporting.Exit as Exit
38import qualified Reporting.Progress as Progress
21import qualified Reporting.Progress as Progress
@@ -42,148 +25,126 @@ import qualified Reporting.Progress as Progress
42-- TASKS
25-- TASKS
43
26
44
27
45−type Task =
28+newtype Task a =
46− Task_ Exit.Exit
29+ Task
47−
30+ (
48−
31+ forall result.
49−type Task_ e =
32+ Env
50− ExceptT e (R.ReaderT Env IO)
33+ -> (a -> IO result)
34+ -> (Exit.Exit -> IO result)
35+ -> IO result
36+ )
51
37
52
38
53data Env =
39data Env =
54 Env
40 Env
55− { _cacheDir :: FilePath
56− , _worker :: IO () -> IO ()
57− , _httpManager :: Http.Manager
58− , _tell :: Progress.Progress -> IO ()
41+ { _tell :: Progress.Progress -> IO ()
59− , _ask :: D.Doc -> IO Bool
42+ , _ask :: D.Doc -> IO Bool
60 }
43 }
61
44
62
45
63−try :: Progress.Reporter -> Task a -> IO (Maybe a)
64−try (Progress.Reporter tell ask end) task =
65− do root <- PerUserCache.getPackageRoot
66− pool <- initPool 4
67− httpManager <- Http.newManager Http.tlsManagerSettings
68− let env = Env root pool httpManager tell ask
69− result <- R.runReaderT (runExceptT task) env
70− case result of
71− Left err ->
72− do end (Just err)
73− return Nothing
74−
75− Right answer ->
76− do end Nothing
77− return (Just answer)
78−
79−
80run :: Progress.Reporter -> Task a -> IO ()
46run :: Progress.Reporter -> Task a -> IO ()
81−run reporter task =
47+run (Progress.Reporter pTell pAsk pEnd) (Task task) =
82− do maybeAnswer <- try reporter task
48+ task (Env pTell pAsk)
83− case maybeAnswer of
49+ (\_ ->
50+ do pEnd Nothing
51+ return ()
52+ )
53+ (\exit ->
54+ do pEnd (Just exit)
84− Nothing -> Exit.exitFailure
55+ Exit.exitFailure
85− Just _ -> return ()
56+ )
86−
87−
88−throw :: e -> Task_ e a
89−throw =
90− throwError
91−
92−
93−mapError :: (x -> y) -> Task_ x a -> Task_ y a
94−mapError =
95− withExceptT
96−
97−
98−
99−-- CACHING
100−
101−
102−getPackageCacheDir :: Task_ e FilePath
103−getPackageCacheDir =
104− R.asks _cacheDir
105−
106−
107−getPackageCacheDirFor :: Pkg.Name -> V.Version -> Task_ e FilePath
108−getPackageCacheDirFor name version =
109− do cacheDir <- getPackageCacheDir
110− let dir = cacheDir </> Pkg.toFilePath name </> V.toChars version
111− liftIO (Dir.createDirectoryIfMissing True dir)
112− return dir
113−
114−
115−
116−-- REPORTER
117−
118−
119−report :: Progress.Progress -> Task_ e ()
120−report progress =
121− do tell <- R.asks _tell
122− liftIO (tell progress)
123
57
124
58
125−getReporter :: Task (Progress.Progress -> IO ())
59+throw :: Exit.Exit -> Task a
126−getReporter =
60+throw exit =
127− R.asks _tell
61+ Task $ \_ _ err -> err exit
128
62
129
63
130
64
131−-- APPROVAL
65+-- PROGRESS
132
66
133
67
134−getApproval :: D.Doc -> Task_ e Bool
68+notify :: Progress.Progress -> Task ()
135−getApproval doc =
69+notify progress =
136− do ask <- R.asks _ask
70+ Task $ \(Env pTell _) ok _ -> pTell progress >>= ok
137− liftIO (ask doc)
138
71
139
72
73+ask :: D.Doc -> Task Bool
74+ask question =
75+ Task $ \(Env _ pAsk) ok _ -> pAsk question >>= ok
140
76
141−-- RUNNER
142
77
143
78
144−silently :: Task_ e a -> Task_ e a
79+-- IO
145−silently task =
146− do runner <- getSilentRunner
147− result <- liftIO (runner task)
148− either throw return result
149
80
150
81
151−getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
82+{-# INLINE io #-}
152−getSilentRunner =
83+io :: IO a -> Task a
153− do env <- R.ask
84+io work =
154− let silentEnv = env { _tell = \_ -> return () }
85+ Task $ \_ ok _ -> work >>= ok
155− return $ \task -> R.runReaderT (runExceptT task) silentEnv
156
86
157
87
88+eio :: (x -> Exit.Exit) -> IO (Either x a) -> Task a
89+eio 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)
158
95
159−-- THREAD POOL
160
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
161
104
162−workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
163−workerChan chan task =
164− do env <- R.ask
165
105
166− liftIO $ _worker env $
167− do result <- R.runReaderT (runExceptT task) env
168− writeChan chan result
169
106
107+-- INSTANCES
170
108
171−initPool :: Int -> IO (IO () -> IO ())
172−initPool size =
173− do chan <- newChan
174
109
175− replicateM_ size $ forkIO $ forever $
110+instance Functor Task where
176− join (readChan chan)
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
177
118
178− return $ writeChan chan
179
119
120+instance Applicative Task where
121+ {-# INLINE pure #-}
122+ pure a =
123+ Task $ \_ ok _ -> ok a
180
124
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
181
136
182−-- HTTP
183
137
138+instance Monad Task where
139+ {-# INLINE return #-}
140+ return = pure
184
141
185−runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
142+ {-# INLINE (>>=) #-}
186−runHttp fetcher =
143+ (>>=) (Task taskA) callback =
187− do (Env _ _ manager tell _) <- R.ask
144+ Task $ \env ok err ->
188− result <- liftIO $ fetcher manager tell
145+ let
189− either throwError return result
146+ okA a =
147+ case callback a of
148+ Task taskB -> taskB env ok err
149+ in
150+ taskA env okA err