summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormatsubara0507 <>2020-02-13 11:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-02-13 11:29:00 (GMT)
commit7d8cdce9fb2da5865330618f59effb36b97c6e0a (patch)
tree3070c32267517682d87f7a50a439ffa9c3538d74
version 0.1.0HEAD0.1.0master
-rw-r--r--CHANGELOG.md3
-rw-r--r--LICENSE29
-rw-r--r--README.md104
-rw-r--r--Setup.hs2
-rw-r--r--example/Main.hs69
-rw-r--r--fallible.cabal47
-rw-r--r--src/Data/Fallible.hs87
7 files changed, 341 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..7c7f6a4
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,3 @@
+# Changelog for fallible
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..d5a53b4
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+BSD 3-Clause License
+
+Copyright (c) 2019, MATSUBARA Nobutada
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..671acbc
--- /dev/null
+++ b/README.md
@@ -0,0 +1,104 @@
+# fallible
+
+[![Build Status](https://travis-ci.com/matsubara0507/fallible.svg?branch=master)](https://travis-ci.com/matsubara0507/fallible)
+
+An interface for fallible data types like Maybe and Either.
+
+## Example
+
+Dealing with Maybe and Either gets a bit annoying when monadic actions are
+involved, often resulting in deep nests like this:
+
+```Haskell
+run :: String -> Token -> Bool -> IO ()
+run targetName token verbose = do
+ users <- getUsers token
+ case users of
+ Left err -> logDebug' err
+ Right us -> do
+ case userId <$> L.find isTarget us of
+ Nothing -> logDebug' emsg
+ Just tid -> do
+ channels <- getChannels token
+ case channels of
+ Left err -> logDebug' err
+ Right chs -> do
+ let chs' = filter (elem tid . channelMembers) chs
+ mapM_ (logDebug' . channelName) chs'
+```
+
+This package offers you several combinators to tidy up this eyesore. See
+[example/Main.hs](example/Main.hs):
+
+```Haskell
+import Data.Fallible
+import qualified Data.List as L
+
+run :: String -> Token -> Bool -> IO ()
+run targetName token verbose = evalContT $ do
+ users <- lift (getUsers token) !?= exit . logDebug'
+ targetId <- userId <$> L.find isTarget users ??? exit (logDebug' emsg)
+ channels <- lift (getChannels token) !?= exit . logDebug'
+ lift $ mapM_ (logDebug' . channelName) $
+ filter (elem targetId . channelMembers) channels
+ where
+ logDebug' = logDebug verbose
+ emsg = "user not found: " ++ targetName
+ isTarget user = userName user == targetName
+
+logDebug :: Bool -> String -> IO ()
+logDebug verbose msg = if verbose then putStrLn msg else pure ()
+```
+
+Notice the couple of operators, `(!?=)` and `(???)`:
+
+```haskell
+(!?=) :: Monad m => m (Either e a) -> (e -> m a) -> m a
+(!??) :: Monad m => m (Maybe a) -> m a -> m a
+(??=) :: Applicative f => Either e a -> (e -> f a) -> f a
+(???) :: Applicative f => Maybe a -> f a -> f a
+```
+
+As you can guess from their type signatures, they run the right side when the
+first arguments returns `Left` or `Nothing`. Then you can use whatever you like
+to handle failures -- exception, MaybeT, ExceptT, ContT etc.
+
+exec using ghci:
+
+```
+$ stack ghci
+>>> :l example/Main.hs
+*Main> run "Alice" "dummy" True
+general
+random
+secret
+*Main> run "Curry" "dummy" True
+general
+random
+owners
+*Main> run "Haskell" "dummy" True
+user not found: Haskell
+*Main> run "Haskell" "" True
+invalid token
+```
+
+## Become a beta tester
+
+### Stack
+
+write to stack.yaml:
+
+```yaml
+extra-deps:
+ github: matsubara0507/fallible
+ commit: XXXXXXX
+```
+
+### cabal
+
+```
+source-repository-package
+ type: git
+ location: https://github.com/matsubara0507/fallible
+ tag: XXXXXXX
+```
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/example/Main.hs b/example/Main.hs
new file mode 100644
index 0000000..9ce222d
--- /dev/null
+++ b/example/Main.hs
@@ -0,0 +1,69 @@
+module Main where
+
+import Data.Fallible
+import qualified Data.List as L
+
+main :: IO ()
+main = test
+ where
+ test = run "Alice" "dummy" False
+
+run :: String -> Token -> Bool -> IO ()
+run targetName token verbose = evalContT $ do
+ users <- lift (getUsers token) !?= exit . logDebug'
+ targetId <- userId <$> L.find isTarget users ??? exit (logDebug' emsg)
+ channels <- lift (getChannels token) !?= exit . logDebug'
+ lift $ mapM_ (logDebug' . channelName) $
+ filter (elem targetId . channelMembers) channels
+ where
+ logDebug' = logDebug verbose
+ emsg = "user not found: " ++ targetName
+ isTarget user = userName user == targetName
+
+logDebug :: Bool -> String -> IO ()
+logDebug verbose msg = if verbose then putStrLn msg else pure ()
+
+-- Dummy API
+
+type UserId = String
+
+data User = User
+ { userId :: UserId
+ , userName :: String
+ , userEmail :: String
+ , userAdmin :: Bool
+ } deriving (Show, Eq)
+
+data Channel = Channel
+ { channelId :: String
+ , channelName :: String
+ , channelMembers :: [UserId]
+ , channelPrivate :: Bool
+ } deriving (Show, Eq)
+
+type Error = String
+
+type Token = String
+
+getUsers :: Token -> IO (Either Error [User])
+getUsers "" = pure (Left "invalid token")
+getUsers _token = pure (Right _users)
+
+_users :: [User]
+_users =
+ [ User "u123456" "Alice" "alice@example.com" False
+ , User "u123457" "Bob" "bob@example.com" False
+ , User "u123458" "Curry" "curry@example.com" True
+ ]
+
+getChannels :: Token -> IO (Either Error [Channel])
+getChannels "" = pure (Left "invalid token")
+getChannels _token = pure (Right _channels)
+
+_channels :: [Channel]
+_channels =
+ [ Channel "c123456" "general" (map userId _users) False
+ , Channel "c123457" "random" (map userId _users) False
+ , Channel "c123458" "owners" (map userId $ filter userAdmin _users) True
+ , Channel "c123459" "secret" (map userId $ take 2 _users) True
+ ]
diff --git a/fallible.cabal b/fallible.cabal
new file mode 100644
index 0000000..b43a114
--- /dev/null
+++ b/fallible.cabal
@@ -0,0 +1,47 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 2749a57a85fe4df30b950899d02ac2874071071ac2711408960a8e7c8426bf08
+
+name: fallible
+version: 0.1.0
+description: Please see the README on GitHub at <https://github.com/matsubara0507/mixlogue#readme>
+category: Data
+homepage: https://github.com/matsubara0507/fallible#readme
+author: MATSUBARA Nobutada
+maintainer: t12307043@gunma-u.ac.jp
+copyright: MATSUBARA Nobutada
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ CHANGELOG.md
+
+library
+ exposed-modules:
+ Data.Fallible
+ other-modules:
+ Paths_fallible
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
+ build-depends:
+ base >=4.7 && <5
+ , transformers
+ default-language: Haskell2010
+
+test-suite fallible-example
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs:
+ example
+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
+ build-depends:
+ base >=4.7 && <5
+ , fallible
+ , transformers
+ default-language: Haskell2010
diff --git a/src/Data/Fallible.hs b/src/Data/Fallible.hs
new file mode 100644
index 0000000..3d2c182
--- /dev/null
+++ b/src/Data/Fallible.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Fallible
+ ( Fallible (..)
+ , (??=)
+ , (???)
+ , (!?=)
+ , (!??)
+ , catchFailure
+ , catchFailure_
+ , exit
+ , exitA
+ , module Cont
+ , lift
+ ) where
+
+import Control.Applicative
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Cont as Cont
+import Data.Functor.Identity
+import Data.Proxy
+import Data.Void
+
+-- | Types that may contain failures.
+class Applicative f => Fallible f where
+ type Failure f :: *
+
+ -- | Get a success or a failure.
+ --
+ -- @'tryFallible' (pure a) ≡ Right a@
+ tryFallible :: f a -> Either (Failure f) a
+
+instance Fallible Identity where
+ type Failure Identity = Void
+ tryFallible = Right . runIdentity
+
+instance Monoid e => Fallible (Const e) where
+ type Failure (Const e) = e
+ tryFallible = Left . getConst
+
+instance Fallible Proxy where
+ type Failure Proxy = ()
+ tryFallible _ = Left ()
+
+instance Fallible Maybe where
+ type Failure Maybe = ()
+ tryFallible = maybe (Left ()) Right
+
+instance Fallible (Either e) where
+ type Failure (Either e) = e
+ tryFallible = id
+
+(??=) :: (Applicative f, Fallible t) => t a -> (Failure t -> f a) -> f a
+t ??= k = either k pure $ tryFallible t
+{-# INLINE (??=) #-}
+infixl 1 ??=
+
+(???) :: (Applicative f, Fallible t) => t a -> f a -> f a
+t ??? k = t ??= const k
+{-# INLINE (???) #-}
+infixl 1 ???
+
+(!?=) :: (Monad m, Fallible t) => m (t a) -> (Failure t -> m a) -> m a
+t !?= k = t >>= (??=k)
+{-# INLINE (!?=) #-}
+infixl 1 !?=
+
+catchFailure :: (Monad m, Fallible t) => m (t a) -> (Failure t -> m a) -> m a
+catchFailure = (!?=)
+{-# INLINE catchFailure #-}
+
+(!??) :: (Monad m, Fallible t) => m (t a) -> m a -> m a
+t !?? k = t >>= (???k)
+{-# INLINE (!??) #-}
+infixl 1 !??
+
+catchFailure_ :: (Monad m, Fallible t) => m (t a) -> m a -> m a
+catchFailure_ = (!??)
+{-# INLINE catchFailure_ #-}
+
+exit :: m r -> ContT r m a
+exit = ContT . const
+{-# INLINE exit #-}
+
+exitA :: Applicative m => r -> ContT r m a
+exitA = exit . pure
+{-# INLINE exitA #-}