Skip to content

Commit a837f01

Browse files
thomashoneymanthomashoneyman
authored
Migrate from ContT to Aff (#208)
1 parent ff2aecd commit a837f01

File tree

7 files changed

+155
-192
lines changed

7 files changed

+155
-192
lines changed

‎client/spago.dhall

+4-1
Original file line numberDiff line numberDiff line change
@@ -4,12 +4,15 @@ You can edit this file as you like.
44
-}
55
{ name = "try-purescript"
66
, dependencies =
7-
[ "arrays"
7+
[ "aff"
8+
, "affjax"
9+
, "arrays"
810
, "bifunctors"
911
, "console"
1012
, "const"
1113
, "contravariant"
1214
, "control"
15+
, "debug"
1316
, "distributive"
1417
, "effect"
1518
, "either"

‎client/src/Main.purs

+51-52
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,6 @@ module Main where
22

33
import Prelude
44

5-
import Control.Monad.Cont.Trans (ContT(..), runContT)
65
import Control.Monad.Except.Trans (runExceptT)
76
import Data.Array (mapMaybe)
87
import Data.Array as Array
@@ -11,6 +10,8 @@ import Data.Foldable (elem, fold, for_, intercalate, traverse_)
1110
import Data.FoldableWithIndex (forWithIndex_)
1211
import Data.Maybe (Maybe(..), fromMaybe)
1312
import Effect (Effect)
13+
import Effect.Aff (Aff, launchAff_)
14+
import Effect.Class (liftEffect)
1415
import Effect.Console (error)
1516
import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn5, mkEffectFn1, runEffectFn1, runEffectFn2, runEffectFn5)
1617
import Foreign (renderForeignError)
@@ -132,31 +133,32 @@ compile = do
132133
displayLoadingMessage
133134
clearAnnotations
134135

135-
runContT (runExceptT (API.compile Config.compileUrl code)) \res_ ->
136+
launchAff_ $ runExceptT (API.compile Config.compileUrl code) >>= \res_ ->
136137
case res_ of
137-
Left err -> displayPlainText err
138+
Left err -> liftEffect $ displayPlainText err
138139
Right res -> do
139-
cleanUpMarkers
140+
liftEffect cleanUpMarkers
140141

141142
case res of
142143
Right (CompileSuccess (SuccessResult { js, warnings })) -> do
143-
showJs <- isShowJsChecked
144-
if showJs
145-
then do hideLoadingMessage
146-
displayPlainText js
147-
else runContT (runExceptT $ runLoader loader (JS js)) \sources -> do
148-
hideLoadingMessage
149-
for_ warnings \warnings_ -> do
150-
let toAnnotation (CompileWarning{ errorCode, position, message }) =
151-
position <#> \(ErrorPosition pos) ->
152-
{ row: pos.startLine - 1
153-
, column: pos.startColumn - 1
154-
, type: "warning"
155-
, text: message
156-
}
157-
runEffectFn1 setAnnotations (mapMaybe toAnnotation warnings_)
158-
for_ sources (execute (JS js))
159-
Right (CompileFailed (FailedResult { error })) -> do
144+
showJs <- liftEffect isShowJsChecked
145+
if showJs then liftEffect do
146+
hideLoadingMessage
147+
displayPlainText js
148+
else do
149+
sources <- runExceptT $ runLoader loader (JS js)
150+
liftEffect hideLoadingMessage
151+
for_ warnings \warnings_ -> liftEffect do
152+
let toAnnotation (CompileWarning{ errorCode, position, message }) =
153+
position <#> \(ErrorPosition pos) ->
154+
{ row: pos.startLine - 1
155+
, column: pos.startColumn - 1
156+
, type: "warning"
157+
, text: message
158+
}
159+
runEffectFn1 setAnnotations (mapMaybe toAnnotation warnings_)
160+
for_ sources (liftEffect <<< execute (JS js))
161+
Right (CompileFailed (FailedResult { error })) -> liftEffect do
160162
hideLoadingMessage
161163
case error of
162164
CompilerErrors errs -> do
@@ -180,7 +182,7 @@ compile = do
180182
pos.endLine
181183
pos.endColumn
182184
OtherError err -> displayPlainText err
183-
Left errs -> do
185+
Left errs -> liftEffect do
184186
hideLoadingMessage
185187
displayPlainText "Unable to parse the response from the server"
186188
traverse_ (error <<< renderForeignError) errs
@@ -196,7 +198,6 @@ execute js modules = do
196198
setupEditor :: forall r. { code :: String | r } -> Effect Unit
197199
setupEditor { code } = do
198200
loadOptions
199-
200201
setTextAreaContent code
201202
runEffectFn1 setEditorContent code
202203

@@ -214,34 +215,32 @@ setupEditor { code } = do
214215
compile
215216

216217
JQuery.select "#gist_save" >>= JQuery.on "click" \e _ ->
217-
publishNewGist
218+
launchAff_ publishNewGist
218219

219220
compile
220221
cacheCurrentCode
221222

222223
loadFromGist
223224
:: String
224-
-> ({ code :: String } -> Effect Unit)
225-
-> Effect Unit
226-
loadFromGist id_ k = do
227-
runContT (runExceptT (getGistById id_ >>= \gi -> tryLoadFileFromGist gi "Main.purs")) $
228-
case _ of
229-
Left err -> do
230-
window >>= alert err
231-
k { code: "" }
232-
Right code -> k { code }
225+
-> Aff { code :: String }
226+
loadFromGist id = do
227+
runExceptT (getGistById id >>= \gi -> tryLoadFileFromGist gi "Main.purs") >>= case _ of
228+
Left err -> do
229+
liftEffect $ window >>= alert err
230+
pure { code: "" }
231+
Right code ->
232+
pure { code }
233233

234234
withSession
235235
:: String
236-
-> ({ code :: String } -> Effect Unit)
237-
-> Effect Unit
238-
withSession sessionId k = do
239-
state <- tryRetrieveSession sessionId
236+
-> Aff { code :: String }
237+
withSession sessionId = do
238+
state <- liftEffect $ tryRetrieveSession sessionId
240239
case state of
241-
Just state' -> k state'
240+
Just state' -> pure state'
242241
Nothing -> do
243-
gist <- fromMaybe Config.mainGist <$> getQueryStringMaybe "gist"
244-
loadFromGist gist k
242+
gist <- liftEffect $ fromMaybe Config.mainGist <$> getQueryStringMaybe "gist"
243+
loadFromGist gist
245244

246245
-- | Cache the current code in the session state
247246
cacheCurrentCode :: Effect Unit
@@ -254,22 +253,21 @@ cacheCurrentCode = do
254253
Nothing -> error "No session ID"
255254

256255
-- | Create a new Gist using the current content
257-
publishNewGist :: Effect Unit
256+
publishNewGist :: Aff Unit
258257
publishNewGist = do
259-
ok <- window >>= confirm (intercalate "\n"
258+
ok <- liftEffect $ window >>= confirm (intercalate "\n"
260259
[ "Do you really want to publish this code as an anonymous Gist?"
261260
, ""
262261
, "Note: this code will be available to anyone with a link to the Gist."
263262
])
264263
when ok do
265-
content <- getTextAreaContent
266-
runContT (runExceptT (uploadGist content)) $
267-
case _ of
268-
Left err -> do
269-
window >>= alert "Failed to create gist"
270-
error ("Failed to create gist: " <> err)
271-
Right gistId -> do
272-
setQueryStrings (Object.singleton "gist" gistId)
264+
content <- liftEffect $ getTextAreaContent
265+
runExceptT (uploadGist content) >>= case _ of
266+
Left err -> liftEffect do
267+
window >>= alert "Failed to create gist"
268+
error ("Failed to create gist: " <> err)
269+
Right gistId -> liftEffect do
270+
setQueryStrings (Object.singleton "gist" gistId)
273271

274272
-- | Navigate to the specified URL.
275273
navigateTo :: String -> Effect Unit
@@ -308,5 +306,6 @@ main = JQuery.ready do
308306
viewMode <- JQueryExtras.filter jq ":checked" >>= JQueryExtras.getValueMaybe
309307
changeViewMode viewMode
310308

311-
runContT (do sessionId <- ContT createSessionIdIfNecessary
312-
ContT (withSession sessionId)) setupEditor
309+
createSessionIdIfNecessary \sessionId -> launchAff_ do
310+
code <- withSession sessionId
311+
liftEffect $ setupEditor code

‎client/src/Try/API.js

-23
This file was deleted.

‎client/src/Try/API.purs

+29-35
Original file line numberDiff line numberDiff line change
@@ -13,17 +13,19 @@ module Try.API
1313

1414
import Prelude
1515

16+
import Affjax (URL, printError)
17+
import Affjax as AX
18+
import Affjax.RequestBody as AXRB
19+
import Affjax.ResponseFormat as AXRF
20+
import Affjax.StatusCode (StatusCode(..))
1621
import Control.Alt ((<|>))
17-
import Control.Monad.Cont.Trans (ContT(ContT))
18-
import Control.Monad.Except (runExcept)
19-
import Control.Monad.Except.Trans (ExceptT(ExceptT))
22+
import Control.Monad.Except (ExceptT(..), runExcept)
2023
import Data.Either (Either(..))
2124
import Data.Generic.Rep (class Generic)
2225
import Data.List.NonEmpty (NonEmptyList)
23-
import Data.Maybe (Maybe)
24-
import Effect (Effect)
25-
import Effect.Uncurried (EffectFn1, EffectFn3, EffectFn4, mkEffectFn1, runEffectFn3, runEffectFn4)
26-
import Foreign (Foreign, ForeignError)
26+
import Data.Maybe (Maybe(..))
27+
import Effect.Aff (Aff)
28+
import Foreign (ForeignError, unsafeToForeign)
2729
import Foreign.Class (class Decode, decode)
2830
import Foreign.Generic (defaultOptions, genericDecode)
2931
import Foreign.Generic.Class (Options, SumEncoding(..))
@@ -123,31 +125,23 @@ instance decodeCompileResult :: Decode CompileResult where
123125
CompileSuccess <$> genericDecode decodingOptions f
124126
<|> CompileFailed <$> genericDecode decodingOptions f
125127

126-
foreign import get_
127-
:: EffectFn3
128-
String
129-
(EffectFn1 String Unit)
130-
(EffectFn1 String Unit)
131-
Unit
132-
133-
-- | A wrapper for `get` which uses `ContT`.
134-
get :: String -> ExceptT String (ContT Unit Effect) String
135-
get uri = ExceptT (ContT \k -> runEffectFn3 get_ uri (mkEffectFn1 (k <<< Right)) (mkEffectFn1 (k <<< Left)))
136-
137-
-- | POST the specified code to the Try PureScript API, and wait for
138-
-- | a response.
139-
foreign import compile_
140-
:: EffectFn4
141-
String
142-
String
143-
(EffectFn1 Foreign Unit)
144-
(EffectFn1 String Unit)
145-
Unit
146-
147-
-- | A wrapper for `compileApi` which uses `ContT`.
148-
compile
149-
:: String
150-
-> String
151-
-> ExceptT String (ContT Unit Effect)
152-
(Either (NonEmptyList ForeignError) CompileResult)
153-
compile endpoint code = ExceptT (ContT \k -> runEffectFn4 compile_ endpoint code (mkEffectFn1 (k <<< Right <<< runExcept <<< decode)) (mkEffectFn1 (k <<< Left)))
128+
get :: URL -> ExceptT String Aff String
129+
get url = ExceptT $ AX.get AXRF.string url >>= case _ of
130+
Left e ->
131+
pure $ Left $ printError e
132+
Right { status } | status >= StatusCode 400 ->
133+
pure $ Left $ "Received error status code: " <> show status
134+
Right { body } ->
135+
pure $ Right body
136+
137+
-- | POST the specified code to the Try PureScript API, and wait for a response.
138+
compile :: String -> String -> ExceptT String Aff (Either (NonEmptyList ForeignError) CompileResult)
139+
compile endpoint code = ExceptT $ AX.post AXRF.json (endpoint <> "/compile") (Just requestBody) >>= case _ of
140+
Left e ->
141+
pure $ Left $ printError e
142+
Right { status } | status >= StatusCode 400 ->
143+
pure $ Left $ "Received error status code: " <> show status
144+
Right { body } ->
145+
pure $ Right $ runExcept (decode (unsafeToForeign body))
146+
where
147+
requestBody = AXRB.String code

‎client/src/Try/Gist.js

+3-42
Original file line numberDiff line numberDiff line change
@@ -1,48 +1,9 @@
11
"use strict";
22

3-
exports.getGistById_ = function(id, done, fail) {
4-
$.ajax({
5-
url: 'https://api.github.com/gists/' + id,
6-
dataType: 'json'
7-
}).done(done).fail(function(err) {
8-
fail("Unable to load Gist metadata");
9-
});
10-
}
11-
12-
exports.tryLoadFileFromGist_ = function(gistInfo, filename, done, fail) {
3+
exports.rawUrl_ = function (gistInfo, filename) {
134
if (gistInfo.files && gistInfo.files.hasOwnProperty(filename)) {
14-
var url = gistInfo.files[filename].raw_url;
15-
16-
return $.ajax({
17-
url: url,
18-
dataType: 'text'
19-
}).done(done).fail(function(err) {
20-
fail(err.statusText);
21-
});
5+
return gistInfo.files[filename].raw_url;
226
} else {
23-
fail("Gist does not contain a file named " + filename);
7+
return null;
248
}
259
};
26-
27-
exports.uploadGist_ = function(content, done, fail) {
28-
var data = {
29-
"description": "Published with try.purescript.org",
30-
"public": false,
31-
"files": {
32-
"Main.purs": {
33-
"content": content
34-
}
35-
}
36-
};
37-
38-
$.ajax({
39-
url: 'https://api.github.com/gists',
40-
type: 'POST',
41-
dataType: 'json',
42-
data: JSON.stringify(data)
43-
}).success(function(e) {
44-
done(e.id);
45-
}).error(function(e) {
46-
fail(e);
47-
});
48-
};

0 commit comments

Comments
 (0)