diff --git a/client/spago.dhall b/client/spago.dhall index d8c65090..7d9e551a 100644 --- a/client/spago.dhall +++ b/client/spago.dhall @@ -38,6 +38,7 @@ , "transformers" , "tuples" , "unfoldable" + , "validation" , "web-html" ] , packages = ./packages.dhall diff --git a/client/src/Try/API.purs b/client/src/Try/API.purs index afe533c6..e2f52f01 100644 --- a/client/src/Try/API.purs +++ b/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 diff --git a/client/src/Try/App.purs b/client/src/Try/App.purs new file mode 100644 index 00000000..d19aae3c --- /dev/null +++ b/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 diff --git a/client/src/Try/Container.purs b/client/src/Try/Container.purs index 4909aafd..6044012d 100644 --- a/client/src/Try/Container.purs +++ b/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 "" (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 "" (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" diff --git a/client/src/Try/Loader.purs b/client/src/Try/Loader.purs index ea845766..f8d7a4d2 100644 --- a/client/src/Try/Loader.purs +++ b/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,7 +20,7 @@ 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 @@ -29,6 +28,7 @@ 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 "") 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 "") 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 "") # bindFlipped _.deps # Array.nubBy (comparing _.name) # go ms' - -ffiDep :: String -> JS -ffiDep name = JS $ "throw new Error('FFI dependency not provided: " <> name <> "');"