265/show ffi errors to user

client/spago.dhall

@@ -38,6 +38,7 @@
   , "transformers"
   , "tuples"
   , "unfoldable"
+  , "validation"
   , "web-html"
   ]
 , packages = ./packages.dhall

client/src/Try/API.purs

@@ -19,13 +19,14 @@ import Affjax.RequestBody as AXRB
 import Affjax.ResponseFormat as AXRF
 import Affjax.StatusCode (StatusCode(..))
 import Control.Alt ((<|>))
-import Control.Monad.Except (ExceptT(..))
+import Control.Monad.Except (ExceptT(..), throwError, withExceptT)
 import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
 import Data.Either (Either(..))
 import Data.Maybe (Maybe(..))
 import Data.Traversable (traverse)
 import Effect.Aff (Aff)
 import Effect.Aff.Class (class MonadAff, liftAff)
+import Try.App (AppT(..), Error(..))
 
 -- | The range of text associated with an error
 type ErrorPosition =
@@ -88,23 +89,29 @@ instance decodeJsonCompileResult :: DecodeJson CompileResult where
     map CompileSuccess (decodeJson json)
       <|> map CompileFailed (decodeJson json)
 
-get :: URL -> ExceptT String Aff String
-get url = ExceptT $ AX.get AXRF.string url >>= 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 body
+get :: URL -> AppT Aff String
+get url = AppT $ withExceptT FetchError
+  $ ExceptT
+  $ AX.get AXRF.string url >>= 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 body
 
 -- | POST the specified code to the Try PureScript API, and wait for a response.
-compile :: forall m. MonadAff m => String -> String -> ExceptT String m (Either String CompileResult)
-compile endpoint code = ExceptT $ liftAff $ 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 $ decodeJson body
+compile :: forall m. MonadAff m => String -> String -> AppT m CompileResult
+compile endpoint code = do
+  result <- liftAff $ AX.post AXRF.json (endpoint <> "/compile") requestBody
+  case result of
+    Left e ->
+      throwError $ FetchError $ printError e
+    Right { status } | status >= StatusCode 400 ->
+      throwError $ FetchError $ "Received error status code: " <> show status
+    Right { body } ->
+      case decodeJson body of
+        Left err -> throwError $ FetchError ""
+        Right decoded -> pure decoded
   where
   requestBody = Just $ AXRB.string code

client/src/Try/App.purs

@@ -0,0 +1,82 @@
+module Try.App
+  ( AppT(..)
+  , Error(..)
+  , ParAppT
+  , displayError
+  , runAppT
+  ) where
+
+import Prelude
+
+import Control.Monad.Error.Class (class MonadThrow)
+import Control.Monad.Except (ExceptT(..))
+import Control.Monad.Except as ExceptT
+import Control.Parallel as Parallel
+import Control.Parallel.Class (class Parallel)
+import Data.Array.NonEmpty (NonEmptyArray)
+import Data.Array.NonEmpty as NonEmpty
+import Data.Either as Either
+import Data.Foldable (length)
+import Data.Functor.Compose (Compose(..))
+import Data.Newtype as Newtype
+import Data.String (joinWith)
+import Data.Validation.Semigroup (V)
+import Data.Validation.Semigroup as V
+import Effect.Aff.Class (class MonadAff)
+import Effect.Class (class MonadEffect)
+
+data Error
+  = FetchError String
+  | FFIErrors (NonEmptyArray String)
+
+instance semigroupError :: Semigroup Error where
+  append (FFIErrors errs) (FFIErrors errs') = FFIErrors (errs <> errs')
+  append err _ = err
+
+displayError :: Error -> String
+displayError = case _ of
+  FetchError err -> err
+  FFIErrors errs -> do
+    let dependencies
+          | length errs == 1 = "dependency" 
+          | otherwise = "dependencies"
+    "FFI " <> dependencies <> " not provided: " <> joinWith ", " (NonEmpty.toArray errs)
+
+newtype AppT (m :: Type -> Type) a = AppT (ExceptT Error m a)
+
+derive newtype instance functorApp :: Functor m => Functor (AppT m)
+derive newtype instance applyApp :: Monad m => Apply (AppT m)
+derive newtype instance applicativeApp :: Monad m => Applicative (AppT m)
+derive newtype instance bindApp :: Monad m => Bind (AppT m)
+derive newtype instance monadApp :: Monad m => Monad (AppT m)
+derive newtype instance monadEffectApp :: MonadEffect m => MonadEffect (AppT m)
+derive newtype instance monadAffApp :: MonadAff m => MonadAff (AppT m)
+derive newtype instance monadThrowApp :: Monad m => MonadThrow Error (AppT m)
+
+runAppT :: forall m. AppT m ~> ExceptT Error m
+runAppT (AppT x) = x
+
+newtype ParAppT m a = ParAppT (Compose m (V Error) a)
+
+derive newtype instance functorParApp :: Functor m => Functor (ParAppT m)
+derive newtype instance applyParApp :: Apply m => Apply (ParAppT m)
+derive newtype instance applicativeParApp :: Applicative m => Applicative (ParAppT m)
+
+runParAppT :: forall f. ParAppT f ~> Compose f (V Error)
+runParAppT (ParAppT x) = x
+
+instance parallelParAppApp :: Parallel f m => Parallel (ParAppT f) (AppT m) where
+  parallel =
+    ParAppT
+      <<< Compose
+      <<< map (Either.either V.invalid pure)
+      <<< Parallel.parallel
+      <<< ExceptT.runExceptT
+      <<< runAppT
+  sequential =
+    AppT
+      <<< ExceptT
+      <<< map (V.toEither)
+      <<< Parallel.sequential
+      <<< Newtype.unwrap
+      <<< runParAppT

client/src/Try/Container.purs

@@ -6,10 +6,13 @@ import Ace (Annotation)
 import Control.Monad.Except (runExceptT)
 import Data.Array (fold)
 import Data.Array as Array
-import Data.Either (Either(..), hush)
-import Data.Foldable (for_, oneOf)
+import Data.Array.NonEmpty (NonEmptyArray)
+import Data.Array.NonEmpty as NonEmpty
+import Data.Either (Either(..))
+import Data.Foldable (for_, length, oneOf)
 import Data.FoldableWithIndex (foldMapWithIndex)
 import Data.Maybe (Maybe(..), fromMaybe, isNothing)
+import Data.String (joinWith)
 import Data.Symbol (SProxy(..))
 import Effect (Effect)
 import Effect.Aff (Aff, makeAff)
@@ -24,6 +27,7 @@ import Halogen.HTML.Events as HE
 import Halogen.HTML.Properties as HP
 import Try.API (CompileError(..), CompileResult(..), CompilerError, ErrorPosition)
 import Try.API as API
+import Try.App (Error(..), displayError, runAppT)
 import Try.Config as Config
 import Try.Editor (MarkerType(..), toStringMarkerType)
 import Try.Editor as Editor
@@ -57,6 +61,7 @@ type State =
   { settings :: Settings
   , sourceFile :: Maybe SourceFile
   , compiled :: Maybe (Either String CompileResult)
+  , ffiErrors :: Maybe (NonEmptyArray String)
   }
 
 data ViewMode
@@ -106,6 +111,7 @@ component = H.mkComponent
     { settings: defaultSettings
     , sourceFile: Nothing
     , compiled: Nothing
+    , ffiErrors: Nothing
     }
 
   handleAction :: Action -> H.HalogenM State Action Slots o Aff Unit
@@ -160,17 +166,17 @@ component = H.mkComponent
           pure text
       _ <- H.query _editor unit $ H.tell $ Editor.SetAnnotations []
       _ <- H.query _editor unit $ H.tell $ Editor.RemoveMarkers
-      runExceptT (API.compile Config.compileUrl code) >>= case _ of
-        Left err -> do
+      runExceptT (runAppT (API.compile Config.compileUrl code)) >>= case _ of
+        Left (FetchError err) -> do
           H.liftEffect teardownIFrame
           H.modify_ _ { compiled = Just (Left err) }
-
-        Right (Left err) -> do
+        
+        Left err -> do
           H.liftEffect teardownIFrame
-          H.liftEffect $ error err
-          H.modify_ _ { compiled = Just (Left err) }
+          H.liftEffect $ error $ displayError err
+          H.modify_ _ { compiled = Just (Left (displayError err)) }
 
-        Right (Right res@(CompileFailed { error })) -> do
+        Right (res@(CompileFailed { error })) -> do
           H.liftEffect teardownIFrame
           H.modify_ _ { compiled = Just (Right res) }
           case error of
@@ -184,22 +190,27 @@ component = H.mkComponent
                   _ <- H.query _editor unit $ H.tell $ Editor.AddMarker MarkerError pos
                   pure unit
 
-        Right (Right res@(CompileSuccess { js, warnings })) -> do
+        Right (res@(CompileSuccess { js, warnings })) -> do
           { settings } <- H.get
           if settings.showJs then
             H.liftEffect teardownIFrame
           else do
-            mbSources <- H.liftAff $ map hush $ runExceptT $ runLoader loader (JS js)
             for_ warnings \warnings_ -> do
               let anns = Array.mapMaybe (toAnnotation MarkerWarning) warnings_
               _ <- H.query _editor unit $ H.tell $ Editor.SetAnnotations anns
               pure unit
-            for_ mbSources \sources -> do
-              let eventData = Object.insert "<file>" (JS js) sources
-              H.liftAff $ makeAff \f -> do 
-                runEffectFn3 setupIFrame eventData (f (Right unit)) (f (Left $ Aff.error "Could not load iframe"))
-                mempty
-            H.modify_ _ { compiled = Just (Right res) }
+            eitherSources <- H.liftAff $ runExceptT $ runAppT $ runLoader loader (JS js)
+            case eitherSources of
+              Left (FFIErrors errs) -> do
+                H.modify_ _ { ffiErrors = Just errs }
+              Left err ->
+                H.modify_ _ { compiled = Just (Left (displayError err)) }
+              Right sources -> do
+                let eventData = Object.insert "<file>" (JS js) sources
+                H.liftAff $ makeAff \f -> do 
+                  runEffectFn3 setupIFrame eventData (f (Right unit)) (f (Left $ Aff.error "Could not load iframe"))
+                  mempty
+                H.modify_ _ { compiled = Just (Right res) }
 
     HandleEditor (Editor.TextChanged text) -> do
       _ <- H.fork $ handleAction $ Cache text
@@ -213,6 +224,7 @@ component = H.mkComponent
       [ HH.div
           [ HP.id_ "body" ]
           [ renderMenu
+          , renderFFIErrors
           , renderMobileBanner
           , renderEditor
           ]
@@ -353,6 +365,14 @@ component = H.mkComponent
         [ HP.class_ $ HH.ClassName "mobile-only mobile-banner" ]
         [ HH.text "Your screen size is too small. Code editing has been disabled." ]
 
+    renderFFIErrors = maybeElem state.ffiErrors \errs -> do
+      let dependencies
+            | length errs == 1 = "dependency" 
+            | otherwise = "dependencies"
+      HH.div
+        [ HP.class_ $ HH.ClassName "error-banner" ]
+        [ HH.text $ "FFI " <> dependencies <> " not provided: " <> joinWith ", " (NonEmpty.toArray errs) ]
+
     renderEditor =
       HH.div
         [ HP.id_ "editor_view"

client/src/Try/Loader.purs

@@ -7,7 +7,6 @@ module Try.Loader
 import Prelude
 
 import Control.Bind (bindFlipped)
-import Control.Monad.Except (ExceptT)
 import Control.Parallel (parTraverse)
 import Data.Array as Array
 import Data.Array.NonEmpty as NonEmpty
@@ -21,14 +20,15 @@ import Data.String.Regex.Flags (noFlags)
 import Data.String.Regex.Unsafe (unsafeRegex)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
-import Effect.Aff (Aff)
+import Effect.Aff (Aff, throwError)
 import Effect.Class (liftEffect)
 import Effect.Ref (Ref)
 import Effect.Ref as Ref
 import Effect.Unsafe (unsafePerformEffect)
 import Foreign.Object (Object)
 import Foreign.Object as Object
 import Try.API as API
+import Try.App (AppT, Error(..))
 import Try.Shim (shims)
 import Try.Types (JS(..))
 
@@ -75,9 +75,9 @@ parseDeps current = Array.mapMaybe go <<< String.split (Pattern "\n") <<< unwrap
         , path: Nothing
         }
 
-newtype Loader = Loader (JS -> ExceptT String Aff (Object JS))
+newtype Loader = Loader (JS -> AppT Aff (Object JS))
 
-runLoader :: Loader -> JS -> ExceptT String Aff (Object JS)
+runLoader :: Loader -> JS -> AppT Aff (Object JS)
 runLoader (Loader k) = k
 
 makeLoader :: String -> Loader
@@ -92,7 +92,7 @@ makeLoader rootPath = Loader (go Object.empty <<< parseDeps "<file>")
   getModule :: String -> Effect (Maybe Module)
   getModule a = Object.lookup a <$> Ref.read moduleCache
 
-  load :: Dependency -> ExceptT String Aff Module
+  load :: Dependency -> AppT Aff Module
   load { name, path } = do
     cached <- liftEffect $ getModule name
     case cached of
@@ -112,11 +112,11 @@ makeLoader rootPath = Loader (go Object.empty <<< parseDeps "<file>")
                   deps = { name: _, path: Nothing } <$> shim.deps
                 pure { name, path, deps, src }
               Nothing ->
-                pure { name, path, deps: [], src: ffiDep name }
+                throwError (FFIErrors (NonEmpty.singleton name))
         liftEffect $ putModule name mod
         pure mod
 
-  go :: Object JS -> Array Dependency -> ExceptT String Aff (Object JS)
+  go :: Object JS -> Array Dependency -> AppT Aff (Object JS)
   go ms []   = pure ms
   go ms deps = do
     modules <- parTraverse load deps
@@ -130,6 +130,3 @@ makeLoader rootPath = Loader (go Object.empty <<< parseDeps "<file>")
       # bindFlipped _.deps
       # Array.nubBy (comparing _.name)
       # go ms'
-
-ffiDep :: String -> JS
-ffiDep name = JS $ "throw new Error('FFI dependency not provided: " <> name <> "');"