@@ -1,38 +1,21 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
22module Reporting.Task
3− ( Task, Task_
4− , try
3+ ( Task
54 , run
65 , throw
7− , mapError
8− , Env
9− , getPackageCacheDir
10− , getPackageCacheDirFor
11− , report
12− , getReporter
13− , getApproval
14− , silently
15− , getSilentRunner
16− , workerChan
17− , runHttp
6+ -- progress
7+ , notify
8+ , ask
9+ -- io
10+ , io
11+ , eio
12+ , withKey
1813 )
1914 where
2015
21−import Control.Concurrent (forkIO)
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
16+
3017import qualified System.Exit as Exit
31−import System.FilePath ((</>))
3218
33−import qualified Elm.Package as Pkg
34−import qualified Elm.PerUserCache as PerUserCache
35−import qualified Elm.Version as V
3619import qualified Reporting.Doc as D
3720import qualified Reporting.Exit as Exit
3821import qualified Reporting.Progress as Progress
@@ -42,148 +25,126 @@ import qualified Reporting.Progress as Progress
4225-- TASKS
4326
4427
45−type Task =
46− Task_ Exit.Exit
47−
48−
49−type Task_ e =
50− ExceptT e (R.ReaderT Env IO)
28+newtype Task a =
29+ Task
30+ (
31+ forall result.
32+ Env
33+ -> (a -> IO result)
34+ -> (Exit.Exit -> IO result)
35+ -> IO result
36+ )
5137
5238
5339data Env =
5440 Env
55− { _cacheDir :: FilePath
56− , _worker :: IO () -> IO ()
57− , _httpManager :: Http.Manager
58− , _tell :: Progress.Progress -> IO ()
59− , _ask :: D.Doc -> IO Bool
41+ { _tell :: Progress.Progress -> IO ()
42+ , _ask :: D.Doc -> IO Bool
6043 }
6144
6245
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−
8046run :: Progress.Reporter -> Task a -> IO ()
81−run reporter task =
82− do maybeAnswer <- try reporter task
83− case maybeAnswer of
84− Nothing -> Exit.exitFailure
85− Just _ -> return ()
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)
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+ )
12357
12458
125−getReporter :: Task (Progress.Progress -> IO ())
126−getReporter =
127− R.asks _tell
59+throw :: Exit.Exit -> Task a
60+throw exit =
61+ Task $ \_ _ err -> err exit
12862
12963
13064
131−-- APPROVAL
65+-- PROGRESS
13266
13367
134−getApproval :: D.Doc -> Task_ e Bool
135−getApproval doc =
136− do ask <- R.asks _ask
137− liftIO (ask doc)
68+notify :: Progress.Progress -> Task ()
69+notify progress =
70+ Task $ \(Env pTell _) ok _ -> pTell progress >>= ok
13871
13972
73+ask :: D.Doc -> Task Bool
74+ask question =
75+ Task $ \(Env _ pAsk) ok _ -> pAsk question >>= ok
14076
141−-- RUNNER
14277
14378
144−silently :: Task_ e a -> Task_ e a
145−silently task =
146− do runner <- getSilentRunner
147− result <- liftIO (runner task)
148− either throw return result
79+-- IO
14980
15081
151−getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
152−getSilentRunner =
153− do env <- R.ask
154− let silentEnv = env { _tell = \_ -> return () }
155− return $ \task -> R.runReaderT (runExceptT task) silentEnv
82+{-# INLINE io #-}
83+io :: IO a -> Task a
84+io work =
85+ Task $ \_ ok _ -> work >>= ok
15686
15787
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)
15895
159−-- THREAD POOL
16096
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
161104
162−workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
163−workerChan chan task =
164− do env <- R.ask
165105
166− liftIO $ _worker env $
167− do result <- R.runReaderT (runExceptT task) env
168− writeChan chan result
169106
107+-- INSTANCES
170108
171−initPool :: Int -> IO (IO () -> IO ())
172−initPool size =
173− do chan <- newChan
174109
175− replicateM_ size $ forkIO $ forever $
176− join (readChan chan)
110+instance 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
177118
178− return $ writeChan chan
179119
120+instance Applicative Task where
121+ {-# INLINE pure #-}
122+ pure a =
123+ Task $ \_ ok _ -> ok a
180124
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
181136
182−-- HTTP
183137
138+instance Monad Task where
139+ {-# INLINE return #-}
140+ return = pure
184141
185−runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
186−runHttp fetcher =
187− do (Env _ _ manager tell _) <- R.ask
188− result <- liftIO $ fetcher manager tell
189− either throwError return result
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