Migrate to argonaut-codecs from foreign-generic (#212)

Author: thomashoneyman

ci/build.sh

@@ -13,8 +13,7 @@ case $COMPONENT in
     cd client
     npm install
     # Use production config, since we want to use these bundles for deploys
-    npm config set trypurescript-client:configpath "config/prod/*.purs"
-    npm run build
+    npm run build:production
     ;;
   *)
     echo >&2 "Unrecognised component: $COMPONENT"

client/.travis.yml

@@ -1,10 +1,10 @@
 language: node_js
-dist: trusty
+dist: bionic
 sudo: required
-node_js: 6
+node_js: 12
 install:
   - npm install -g bower
   - npm install
   - bower install --production
 script:
-  - npm run -s bundle
+  - npm run -s test

client/package.json

@@ -6,9 +6,9 @@
   },
   "scripts": {
     "clean": "rimraf output",
-    "test": "spago test --path $npm_package_config_configpath",
-    "build": "spago build --path $npm_package_config_configpath",
-    "bundle": "spago bundle-app --path $npm_package_config_configpath --purs-args '--censor-lib --strict' --to public/js/index.js"
+    "test": "spago test --path config/dev/Try.Config.purs",
+    "build": "spago build --path config/dev/Try.Config.purs",
+    "build:production": "spago bundle-app --path config/prod/Try.Config.purs --purs-args '--censor-lib --strict' --to public/js/index.js"
   },
   "devDependencies": {
     "purescript": "^0.13.6",

client/spago.dhall

@@ -6,25 +6,19 @@ You can edit this file as you like.
 , dependencies =
   [ "aff"
   , "affjax"
+  , "argonaut-codecs"
   , "arrays"
   , "assert"
   , "bifunctors"
   , "console"
   , "const"
-  , "contravariant"
   , "control"
   , "debug"
-  , "distributive"
   , "effect"
   , "either"
-  , "enums"
   , "exceptions"
-  , "exists"
   , "foldable-traversable"
-  , "foreign"
-  , "foreign-generic"
   , "foreign-object"
-  , "free"
   , "functions"
   , "functors"
   , "generics-rep"
@@ -33,28 +27,21 @@ You can edit this file as you like.
   , "integers"
   , "jquery"
   , "js-timers"
-  , "lazy"
   , "math"
   , "maybe"
   , "node-fs"
   , "ordered-collections"
   , "parallel"
   , "prelude"
   , "profunctor"
-  , "proxy"
   , "psci-support"
-  , "quickcheck"
   , "random"
   , "refs"
   , "semirings"
-  , "st"
   , "strings"
-  , "tailrec"
   , "transformers"
   , "tuples"
-  , "typelevel-prelude"
   , "unfoldable"
-  , "validation"
   , "web-html"
   ]
 , packages = ./packages.dhall

client/src/Main.purs

@@ -6,20 +6,19 @@ import Control.Monad.Except.Trans (runExceptT)
 import Data.Array (mapMaybe)
 import Data.Array as Array
 import Data.Either (Either(..))
-import Data.Foldable (elem, fold, for_, intercalate, traverse_)
+import Data.Foldable (elem, fold, for_, intercalate)
 import Data.FoldableWithIndex (forWithIndex_)
 import Data.Maybe (Maybe(..), fromMaybe)
 import Effect (Effect)
 import Effect.Aff (Aff, launchAff_)
 import Effect.Class (liftEffect)
 import Effect.Console (error)
 import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn5, mkEffectFn1, runEffectFn1, runEffectFn2, runEffectFn5)
-import Foreign (renderForeignError)
 import Foreign.Object (Object)
 import Foreign.Object as Object
 import JQuery as JQuery
 import JQuery.Extras as JQueryExtras
-import Try.API (CompileError(..), CompileResult(..), CompileWarning(..), CompilerError(..), ErrorPosition(..), FailedResult(..), SuccessResult(..))
+import Try.API (CompileError(..), CompileResult(..), CompilerError)
 import Try.API as API
 import Try.Config as Config
 import Try.Gist (getGistById, tryLoadFileFromGist, uploadGist)
@@ -43,7 +42,7 @@ displayErrors errs = do
   column2 <- JQuery.select "#column2"
   JQueryExtras.empty column2
 
-  forWithIndex_ errs \i (CompilerError{ message }) -> do
+  forWithIndex_ errs \i { message } -> do
     h1 <- JQuery.create "<h1>"
     JQuery.addClass "error-banner" h1
     JQuery.setText ("Error " <> show (i + 1) <> " of " <> show (Array.length errs)) h1
@@ -140,7 +139,11 @@ compile = do
         liftEffect cleanUpMarkers
 
         case res of
-          Right (CompileSuccess (SuccessResult { js, warnings })) -> do
+          Left err -> liftEffect do
+            hideLoadingMessage
+            displayPlainText "Unable to parse the response from the server"
+            error err
+          Right (CompileSuccess { js, warnings }) -> do
             showJs <- liftEffect isShowJsChecked
             if showJs then liftEffect do
               hideLoadingMessage
@@ -149,43 +152,39 @@ compile = do
               sources <- runExceptT $ runLoader loader (JS js)
               liftEffect hideLoadingMessage
               for_ warnings \warnings_ -> liftEffect do
-                let toAnnotation (CompileWarning{ errorCode, position, message }) =
-                      position <#> \(ErrorPosition pos) ->
-                        { row: pos.startLine - 1
-                        , column: pos.startColumn - 1
-                        , type: "warning"
-                        , text: message
-                        }
+                let
+                  toAnnotation { errorCode, position, message } =
+                    position <#> \pos ->
+                      { row: pos.startLine - 1
+                      , column: pos.startColumn - 1
+                      , type: "warning"
+                      , text: message
+                      }
                 runEffectFn1 setAnnotations (mapMaybe toAnnotation warnings_)
               for_ sources (liftEffect <<< execute (JS js))
-          Right (CompileFailed (FailedResult { error })) -> liftEffect do
+          Right (CompileFailed { error }) -> liftEffect do
             hideLoadingMessage
             case error of
               CompilerErrors errs -> do
                 displayErrors errs
-
-                let toAnnotation (CompilerError{ position, message }) =
-                      position <#> \(ErrorPosition pos) ->
-                        { row: pos.startLine - 1
-                        , column: pos.startColumn - 1
-                        , type: "error"
-                        , text: message
-                        }
+                let
+                  toAnnotation { position, message } =
+                    position <#> \pos ->
+                      { row: pos.startLine - 1
+                      , column: pos.startColumn - 1
+                      , type: "error"
+                      , text: message
+                      }
                 runEffectFn1 setAnnotations (mapMaybe toAnnotation errs)
-
-                for_ errs \(CompilerError{ position }) ->
-                  for_ position \(ErrorPosition pos) ->
+                for_ errs \{ position } ->
+                  for_ position \pos ->
                     runEffectFn5 addMarker
                       "error"
                       pos.startLine
                       pos.startColumn
                       pos.endLine
                       pos.endColumn
               OtherError err -> displayPlainText err
-          Left errs -> liftEffect do
-            hideLoadingMessage
-            displayPlainText "Unable to parse the response from the server"
-            traverse_ (error <<< renderForeignError) errs
 
 -- | Execute the compiled code in a new iframe.
 execute :: JS -> Object JS -> Effect Unit

client/src/Try/API.purs

@@ -19,111 +19,74 @@ import Affjax.RequestBody as AXRB
 import Affjax.ResponseFormat as AXRF
 import Affjax.StatusCode (StatusCode(..))
 import Control.Alt ((<|>))
-import Control.Monad.Except (ExceptT(..), runExcept)
+import Control.Monad.Except (ExceptT(..))
+import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
+import Data.Argonaut.Encode (encodeJson)
 import Data.Either (Either(..))
-import Data.Generic.Rep (class Generic)
-import Data.List.NonEmpty (NonEmptyList)
 import Data.Maybe (Maybe(..))
+import Data.Traversable (traverse)
 import Effect.Aff (Aff)
-import Foreign (ForeignError, unsafeToForeign)
-import Foreign.Class (class Decode, decode)
-import Foreign.Generic (defaultOptions, genericDecode)
-import Foreign.Generic.Class (Options, SumEncoding(..))
-
-decodingOptions :: Options
-decodingOptions = defaultOptions { unwrapSingleConstructors = true }
 
 -- | The range of text associated with an error
-newtype ErrorPosition = ErrorPosition
+type ErrorPosition =
   { startLine :: Int
   , endLine :: Int
   , startColumn :: Int
   , endColumn :: Int
   }
 
-derive instance genericErrorPosition :: Generic ErrorPosition _
-
-instance decodeErrorPosition :: Decode ErrorPosition where
-  decode = genericDecode decodingOptions
-
-newtype CompilerError = CompilerError
+type CompilerError =
   { message :: String
   , position :: Maybe ErrorPosition
   }
 
-derive instance genericCompilerError :: Generic CompilerError _
-
-instance decodeCompilerError :: Decode CompilerError where
-  decode = genericDecode decodingOptions
-
 -- | An error reported from the compile API.
 data CompileError
   = CompilerErrors (Array CompilerError)
   | OtherError String
 
-derive instance genericCompileError :: Generic CompileError _
-
-instance decodeCompileError :: Decode CompileError where
-  decode = genericDecode
-    (defaultOptions
-      { sumEncoding =
-          TaggedObject
-            { tagFieldName: "tag"
-            , contentsFieldName: "contents"
-            , constructorTagTransform: identity
-            }
-      })
-
-newtype Suggestion = Suggestion
+instance decodeJsonCompileError :: DecodeJson CompileError where
+  decodeJson = decodeJson >=> \obj -> do
+    contents <- obj .: "contents"
+    obj .: "tag" >>= case _ of
+      "OtherError" ->
+        map OtherError $ decodeJson contents
+      "CompilerErrors" ->
+        map CompilerErrors $ traverse decodeJson =<< decodeJson contents
+      _ ->
+        Left "Tag must be one of: OtherError, CompilerErrors"
+
+type Suggestion =
   { replacement :: String
   , replaceRange :: Maybe ErrorPosition
   }
 
-derive instance genericSuggestion :: Generic Suggestion _
-
-instance decodeSuggestion :: Decode Suggestion where
-  decode = genericDecode decodingOptions
-
-newtype CompileWarning = CompileWarning
+type CompileWarning =
   { errorCode :: String
   , message :: String
   , position :: Maybe ErrorPosition
   , suggestion :: Maybe Suggestion
   }
 
-derive instance genericCompileWarning :: Generic CompileWarning _
-
-instance decodeCompileWarning :: Decode CompileWarning where
-  decode = genericDecode decodingOptions
-
-newtype SuccessResult = SuccessResult
+type SuccessResult =
   { js :: String
   , warnings :: Maybe (Array CompileWarning)
   }
 
-derive instance genericSuccessResult :: Generic SuccessResult _
-
-instance decodeSuccessResult :: Decode SuccessResult where
-  decode = genericDecode decodingOptions
-
-newtype FailedResult = FailedResult
-  { error :: CompileError }
-
-derive instance genericFailedResult :: Generic FailedResult _
-
-instance decodeFailedResult :: Decode FailedResult where
-  decode = genericDecode decodingOptions
+type FailedResult =
+  { error :: CompileError
+  }
 
 -- | The result of calling the compile API.
 data CompileResult
   = CompileSuccess SuccessResult
   | CompileFailed FailedResult
 
 -- | Parse the result from the compile API and verify it
-instance decodeCompileResult :: Decode CompileResult where
-  decode f =
-    CompileSuccess <$> genericDecode decodingOptions f
-    <|> CompileFailed <$> genericDecode decodingOptions f
+instance decodeJsonCompileResult :: DecodeJson CompileResult where
+  decodeJson json =
+    map CompileSuccess (decodeJson json)
+      <|> map CompileFailed (decodeJson json)
 
 get :: URL -> ExceptT String Aff String
 get url = ExceptT $ AX.get AXRF.string url >>= case _ of
@@ -135,13 +98,13 @@ get url = ExceptT $ AX.get AXRF.string url >>= case _ of
     pure $ Right body
 
 -- | POST the specified code to the Try PureScript API, and wait for a response.
-compile :: String -> String -> ExceptT String Aff (Either (NonEmptyList ForeignError) CompileResult)
-compile endpoint code = ExceptT $ AX.post AXRF.json (endpoint <> "/compile") (Just requestBody) >>= case _ of
+compile :: String -> String -> ExceptT String Aff (Either String CompileResult)
+compile endpoint code = ExceptT $ AX.post AXRF.json (endpoint <> "/compile") requestBody >>= case _ of
   Left e ->
     pure $ Left $ printError e
   Right { status } | status >= StatusCode 400 ->
     pure $ Left $ "Received error status code: " <> show status
   Right { body } ->
-    pure $ Right $ runExcept (decode (unsafeToForeign body))
+    pure $ Right $ decodeJson body
   where
-  requestBody = AXRB.String code
+  requestBody = Just $ AXRB.Json $ encodeJson code

client/src/Try/Gist.purs

@@ -14,12 +14,12 @@ import Affjax.ResponseFormat as AXRF
 import Affjax.StatusCode (StatusCode(..))
 import Control.Monad.Except.Trans (ExceptT(..))
 import Data.Argonaut.Core (Json, caseJsonObject, stringify, toString)
+import Data.Argonaut.Encode (encodeJson)
 import Data.Either (Either(..))
 import Data.Function.Uncurried (Fn2, runFn2)
 import Data.Maybe (Maybe(..))
 import Data.Nullable (Nullable, toMaybe)
 import Effect.Aff (Aff)
-import Foreign.Generic (encodeJSON)
 import Foreign.Object as Object
 import Unsafe.Coerce (unsafeCoerce)
 
@@ -51,7 +51,7 @@ uploadGist content = ExceptT $ AX.post AXRF.json "https://api.github.com/gists"
         _ -> Left "Key id was not a string."
 
   where
-  requestBody = Just $ AXRB.string $ encodeJSON
+  requestBody = Just $ AXRB.json $ encodeJson
     { description: "Published with try.purescript.org"
     , public: false
     , files: { "Main.purs": { content } }

client/src/Try/Types.purs

@@ -2,11 +2,10 @@ module Try.Types
   ( JS(..)
   ) where
 
+import Data.Argonaut.Encode (class EncodeJson)
 import Data.Newtype (class Newtype)
-import Foreign.Class (class Encode)
 
 newtype JS = JS String
 
 derive instance newtypeJS :: Newtype JS _
-
-derive newtype instance encodeJS :: Encode JS
+derive newtype instance encodeJsonJS :: EncodeJson JS