Initial commit

Author: natefaubion

.gitignore

@@ -0,0 +1,10 @@
+/bower_components/
+/node_modules/
+/.pulp-cache/
+/output/
+/.psc*
+/.psa*
+/.purs*
+/.vscode
+/package-lock.json
+/examples/*/app.js

.travis.yml

@@ -0,0 +1,16 @@
+language: node_js
+dist: trusty
+sudo: required
+node_js: stable
+install:
+  - npm install
+  - npm install -g bower
+  - bower install --production
+script:
+  - npm run -s build
+after_success:
+- >-
+  test $TRAVIS_TAG &&
+  echo $GITHUB_TOKEN | pulp login &&
+  echo y | pulp publish --no-push ||
+  git status

LICENSE

@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2017 Nathan Faubion
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

README.md

@@ -0,0 +1,230 @@
+# purescript-checked-exceptions
+
+Extensible checked exceptions using polymorphic variants
+
+[![Latest release](http://img.shields.io/github/release/natefaubion/purescript-checked-exceptions.svg)](https://github.com/natefaubion/purescript-checked-exceptions/releases)
+[![Build status](https://travis-ci.org/natefaubion/purescript-checked-exceptions.svg?branch=master)](https://travis-ci.org/natefaubion/purescript-checked-exceptions)
+
+## The ~~Expression~~ Exception Problem
+
+Given some function for making HTTP requests which propagates an `HttpError`
+for failures cases:
+
+```purescript
+get
+  ∷ ∀ m
+  . MonadHttp m
+  ⇒ String
+  → ExceptT HttpError m String
+```
+
+And another for writing files which propagates an `FsError` for failures cases:
+
+```purescript
+write
+  ∷ ∀ m
+  . MonadFs m
+  ⇒ Path
+  → String
+  → ExceptT FsError m Unit
+```
+
+What happens when we combine them?
+
+```purescript
+getPureScript
+  ∷ ∀ m
+  . MonadHttp m
+  ⇒ MonadFs m
+  ⇒ ExceptT _ m Unit
+getPureScript =
+  get "http://purescript.org" >>= write "~/purescript.html"
+```
+```
+Could not match type
+
+  FsError
+
+with type
+
+  HttpError
+```
+
+Before we can get anywhere, we must unify the error types.
+
+```purescript
+getPureScript
+  ∷ ∀ m
+  . MonadHttp m
+  ⇒ MonadFs m
+  ⇒ ExceptT (Either HttpError FsError) m Unit
+getPureScript = do
+  resp <- withExceptT Left (get "http://purescript.org")
+  rethrow Right (write "~/purescript.html" resp)
+```
+
+This gets very tedious, very quickly, because every new exception type we
+introduce breaks code we've already written.
+
+## Polymorphic Variants to the Rescue
+
+[`Variant`](https://github.com/natefaubion/purescript-variant) lets us define
+_structural_ sum types. Row types in a `Record` point to _fields_, while row
+types in a `Variant` point to _tags_. That means we only have to care about
+the cases we want to use, and they work together regardless of which module
+defined them.
+
+We'll start with a little bit of sugar (this helps the types go down easy):
+
+```purescript
+type RowApply (f :: # Type -> # Type) (a :: # Type) = f a
+
+infixr 0 type RowApply as +
+```
+
+We'll define our `HttpError` variants with _rows_ instead of the usual `data`
+declaration:
+
+```purescript
+type HttpServerError r = (httpServerError ∷ String | r)
+type HttpNotFound    r = (httpNotFound ∷ Unit | r)
+type HttpOther       r = (httpOther ∷ { status ∷ Int, body ∷ String } | r)
+```
+
+And add constructors which lift them into `Variant`:
+
+```purescript
+httpServerError ∷ ∀ r. String → Variant (HttpServerError + r)
+httpServerError = inj (SProxy ∷ SProxy "httpServerError")
+
+httpNotFound ∷ ∀ r. Variant (HttpNotFound + r)
+httpNotFound = inj (SProxy ∷ SProxy "httpNotFound") unit
+
+httpOther ∷ ∀ r. Int → String → Variant (HttpOther + r)
+httpOther status body = inj (SProxy ∷ SProxy "httpOther") { status, body }
+```
+
+We can then define a helpful alias for all of our HTTP exceptions:
+
+```purescript
+type HttpError r =
+  ( HttpServerError
+  + HttpNotFound
+  + HttpOther
+  + r
+  )
+```
+
+Now in another module we might do the same for FS exceptions:
+
+```purescript
+type FsPermissionDenied r = (fsPermissionDenied ∷ Unit | r)
+type FsFileNotFound r     = (fsFileNotFound ∷ Path | r)
+
+fsPermissionDenied ∷ ∀ r. Variant (FsPermissionDenied + r)
+fsPermissionDenied = inj (SProxy ∷ SProxy "fsPermissionDenied") unit
+
+fsFileNotFound ∷ ∀ r. Path → Variant (FsFileNotFound + r)
+fsFileNotFound = inj (SProxy ∷ SProxy "fsFileNotFound")
+
+type FsError r =
+  ( FsPermissionDenied
+  + FsFileNotFound
+  + r
+  )
+```
+
+Let's go back to our original example, but instead of `ExceptT` we will
+substitute `ExceptV`:
+
+```purescript
+type ExceptV exc = ExceptT (Variant exc)
+```
+
+```purescript
+get
+  ∷ ∀ r m
+  . MonadHttp m
+  ⇒ String
+  → ExceptV (HttpError + r) m String
+
+write
+  ∷ ∀ r m
+  . MonadFs m
+  ⇒ Path
+  → String
+  → ExceptV (FsError + r) m Unit
+```
+
+When we go to combine them, _it just works_:
+
+```purescript
+getPureScript
+  ∷ ∀ r m
+  . MonadHttp m
+  ⇒ MonadFs m
+  ⇒ ExceptV (HttpError + FsError + r) m Unit
+getPureScript =
+  get "http://purescript.org" >>= write "~/purescript.html"
+```
+
+Additionally, these types are completely inferrable:
+
+```
+Wildcard type definition has the inferred type
+
+  ( httpServerError :: String
+  , httpNotFound :: Unit
+  , httpOther :: { status :: Int
+                 , body :: String
+                 }
+  , fsFileNotFound :: String
+  , fsPermissionDenied :: Unit
+  | t0
+  )
+```
+
+## Handling Errors
+
+This library exports the `handleError` function. Given a record of exception
+handlers, it will catch and route the corresponding exceptions, eliminating
+them from the type.
+
+```purescript
+getPureScript # handleError
+  { httpServerError: \error -> log $ "Server error:" <> error
+  , httpNotFound: \_ -> log "Not found"
+  }
+```
+
+```
+Wildcard type definition has the inferred type
+
+  ( fsFileNotFound :: String
+  , fsPermissionDenied :: Unit
+  , httpOther :: { status :: Int
+                 , body :: String
+                 }
+  | t0
+  )
+```
+
+This lets us prove that _all_ exceptions have been handled, which means
+we can safely remove the `ExceptV` wrapper using the `safe` combinator.
+
+```purescript
+getPureScriptSafe
+  :: forall m
+   . MonadHttp m
+  => MonadFs m
+  => MonadLog m
+  -> m Unit
+getPureScriptSafe =
+  safe $ getPureScript # handleError
+    { httpServerError: ...
+    , httpNotFound: ...
+    , httpOther: ...
+    , fsFileNotFound: ...
+    , fsPermissionDenied ...
+    }
+```

bower.json

@@ -0,0 +1,22 @@
+{
+  "name": "purescript-checked-exceptions",
+  "authors": [
+    "Nathan Faubion <[email protected]>"
+  ],
+  "license": "MIT",
+  "repository": {
+    "type": "git",
+    "url": "git://github.com/natefaubion/purescript-checked-exceptions.git"
+  },
+  "ignore": [
+    "**/.*",
+    "node_modules",
+    "bower_components",
+    "output"
+  ],
+  "dependencies": {
+    "purescript-prelude": "^3.1.1",
+    "purescript-transformers": "^3.5.0",
+    "purescript-variant": "^4.1.0"
+  }
+}

package.json

@@ -0,0 +1,11 @@
+{
+  "private": true,
+  "scripts": {
+    "build": "pulp build -- --strict --censor-lib"
+  },
+  "devDependencies": {
+    "pulp": "^12.0.0",
+    "purescript": "^0.11.7",
+    "purescript-psa": "^0.5.0"
+  }
+}

src/Control/Monad/Except/Checked.purs

@@ -0,0 +1,53 @@
+-- | ## Extensible checked exceptions with polymorphic variants
+-- |
+-- | This module provides helpers for using `Variant` with `ExceptT`. When
+-- | combined, we get a mechanism for extensible, checked exceptions. That
+-- | is, exceptions can be defined and used anywhere, and handled as needed.
+-- | Handling an exception eliminates it from the type, giving us proof
+-- | that it no longer occurs.
+module Control.Monad.Except.Checked
+  ( ExceptV
+  , handleError
+  , safe
+  ) where
+
+import Prelude
+
+import Control.Monad.Except (ExceptT, lift, throwError)
+import Data.Either (either, fromRight)
+import Data.Newtype (unwrap)
+import Data.Variant (class VariantMatchCases, Variant, onMatch)
+import Partial.Unsafe (unsafePartial)
+import Type.Row (class RowToList)
+
+type ExceptV exc = ExceptT (Variant exc)
+
+-- | Catches and eliminates exceptions given a record of handlers.
+-- | Unhandled exceptions are re-propragated. Record fields map
+-- | to the label for the exception being handled.
+-- |
+-- | An example for handling HTTP exceptions might be:
+-- | ```purescript
+-- | request # handleError
+-- |   { httpNotFound: \_ -> ...
+-- |   , httpServerError: \error -> ...
+-- |   }
+-- | ```
+handleError
+  ∷ ∀ m handlers excHandled excIn excOut rl a
+  . RowToList handlers rl
+  ⇒ VariantMatchCases rl excHandled (ExceptV excOut m a)
+  ⇒ Union excHandled excOut excIn
+  ⇒ Monad m
+  ⇒ { | handlers }
+  → ExceptV excIn m a
+  → ExceptV excOut m a
+handleError cases = unwrap >>> lift >=> either (onMatch cases throwError) pure
+
+-- | Safely removes the `ExceptT` layer when all exceptions have been handled.
+safe
+  ∷ ∀ m a
+  . Functor m
+  ⇒ ExceptV () m a
+  → m a
+safe = unsafePartial $ unwrap >>> map fromRight