packages feed

oops (empty) → 0.1.0.0

raw patch · 8 files changed

+946/−0 lines, 8 filesdep +Globdep +QuickCheckdep +base

Dependencies added: Glob, QuickCheck, base, base-compat, doctest, doctest-discover, hedgehog, hedgehog-quickcheck, hspec, hw-hspec-hedgehog, lens, mtl, oops, template-haskell, transformers

Files

+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2023 John Ky+Copyright (c) 2019 Tom Harding++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.
+ doctest/DoctestDriver.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = do+  sourceFiles <- glob "src/**/*.hs"+  doctest+    $ "-XHaskell2010"+    : sourceFiles
+ oops.cabal view
@@ -0,0 +1,92 @@+cabal-version: 3.0++name:                   oops+version:                0.1.0.0+synopsis:               Combinators for handling errors of many types in a composable way+description:            Combinators for handling errors of many types in a composable way.+homepage:               https://www.github.com/i-am-tom/oops+license:                MIT+license-file:           LICENSE+author:                 Tom Harding+maintainer:             tomjharding@live.co.uk+copyright:              2019 Tom Harding+                        2023 John Ky+category:               Data+                        Control+tested-with:            GHC == 9.4.3, GHC == 9.2.2, GHC == 9.0.2, GHC == 8.10.7++source-repository head+  type: git+  location: https://github.com/haskell-works/oops++common base                           { build-depends: base                           >= 4.12       && < 5      }++common base-compat                    { build-depends: base-compat                    >= 0.10.5     && < 0.13   }+common Glob                           { build-depends: Glob                           >= 0.10.2     && < 0.11   }+common doctest                        { build-depends: doctest                        >= 0.16.2     && < 0.21   }+common doctest-discover               { build-depends: doctest-discover               >= 0.2        && < 0.3    }+common doctest-prop                   { build-depends: doctest-prop                   >= 0.2.0.1    && < 0.3    }+common hedgehog-quickcheck            { build-depends: hedgehog-quickcheck                                      }+common hedgehog                       { build-depends: hedgehog                                                 }+common hspec                          { build-depends: hspec                                                    }+common hw-hspec-hedgehog              { build-depends: hw-hspec-hedgehog                                        }+common lens                           { build-depends: lens                                                     }+common mtl                            { build-depends: mtl                                                      }+common QuickCheck                     { build-depends: QuickCheck                                               }+common template-haskell               { build-depends: template-haskell                                         }+common transformers                   { build-depends: transformers                                             }++common project-config+  default-language:     Haskell2010+  ghc-options:          -Wall++library+  import:               base, project-config,+                        mtl,+                        QuickCheck,+                        transformers,+  exposed-modules:      Control.Monad.Oops+                        Control.Monad.Oops.Classic+                        Data.Variant+  hs-source-dirs:       src+  default-language:     Haskell2010++test-suite doctest+  import:               base, project-config,+                        base-compat,+                        doctest,+                        doctest-discover,+                        Glob,+                        lens,+                        QuickCheck,+                        template-haskell,+  type:                 exitcode-stdio-1.0+  build-tool-depends:   doctest-discover:doctest-discover+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  main-is:              DoctestDriver.hs+  hs-source-dirs:       doctest+  default-language:     Haskell2010+  build-depends:        oops++  x-doctest-components: lib++test-suite test+  import:               base, project-config,+                        base-compat,+                        doctest-discover,+                        doctest,+                        hedgehog-quickcheck,+                        hedgehog,+                        hspec,+                        hw-hspec-hedgehog,+                        lens,+                        QuickCheck,+                        template-haskell,+  type:                 exitcode-stdio-1.0+  build-tool-depends:   hspec-discover:hspec-discover+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  main-is:              Spec.hs+  hs-source-dirs:       test+  default-language:     Haskell2010+  build-depends:        oops+  other-modules:        Data.VariantSpec
+ src/Control/Monad/Oops.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE EmptyCase              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++module Control.Monad.Oops+  ( -- * MTL/transformer utilities+    catchFM,+    catchM,++    throwFM,+    throwM,++    snatchFM,+    snatchM,++    runOops,+    suspendM,++    catchAndExitFailureM,++    throwLeftM,+    throwNothingM,++    recoverM,+    recoverOrVoidM,++  ) where++import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.Except (ExceptT(ExceptT))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Trans.Except (mapExceptT, runExceptT)+import Data.Function ((&))+import Data.Functor.Identity (Identity (..))+import Data.Variant (Catch, CatchF(..), CouldBe, CouldBeF(..), Variant, VariantF, preposterous)+import Data.Void (Void, absurd)++import qualified System.Exit as IO++-- | When working in some monadic context, using 'catch' becomes trickier. The+-- intuitive behaviour is that each 'catch' shrinks the variant in the left+-- side of my 'MonadError', but this is therefore type-changing: as we can only+-- 'throwError' and 'catchError' with a 'MonadError' type, this is impossible!+--+-- To get round this problem, we have to specialise to 'ExceptT', which allows+-- us to map over the error type and change it as we go. If the error we catch+-- is the one in the variant that we want to handle, we pluck it out and deal+-- with it. Otherwise, we "re-throw" the variant minus the one we've handled.+catchFM :: forall x e e' f m a. ()+  => Monad m+  => CatchF x e e'+  => (f x -> ExceptT (VariantF f e') m a)+  -> ExceptT (VariantF f e ) m a+  -> ExceptT (VariantF f e') m a+catchFM recover xs = mapExceptT (>>= go) xs+  where+    go = \case+      Right success -> pure (Right success)+      Left  failure -> case catchF @x failure of+        Right hit  -> runExceptT (recover hit)+        Left  miss -> pure (Left miss)++-- | Just the same as 'catchFM', but specialised for our plain 'Variant' and+-- sounding much less like a radio station.+catchM :: forall x e e' m a. ()+  => Monad m+  => Catch x e e'+  => (x -> ExceptT (Variant e') m a)+  -> ExceptT (Variant e ) m a+  -> ExceptT (Variant e') m a+catchM recover xs+  = catchFM (recover . runIdentity) xs++-- | Same as 'catchFM' except the error is not removed from the type.+-- This is useful for writing recursive computations or computations that+-- rethrow the same error type.+snatchFM+  :: forall x e f m a. ()+  => Monad m+  => e `CouldBe` x+  => (f x -> ExceptT (VariantF f e) m a)+  -> ExceptT (VariantF f e) m a+  -> ExceptT (VariantF f e) m a+snatchFM recover xs = mapExceptT (>>= go) xs+  where+    go = \case+      Right success -> pure (Right success)+      Left  failure -> case snatchF @_ @_ @x failure of+        Right hit  -> runExceptT (recover hit)+        Left  miss -> pure (Left miss)+++-- | Same as 'catchM' except the error is not removed from the type.+-- This is useful for writing recursive computations or computations that+-- rethrow the same error type.+snatchM :: forall x e m a. ()+  => Monad m+  => e `CouldBe` x+  => (x -> ExceptT (Variant e) m a)+  -> ExceptT (Variant e) m a+  -> ExceptT (Variant e) m a+snatchM recover xs = snatchFM (recover . runIdentity) xs++-- | Throw an error into a variant 'MonadError' context. Note that this /isn't/+-- type-changing, so this can work for any 'MonadError', rather than just+-- 'ExceptT'.+throwFM :: forall x e f m a. ()+  => MonadError (VariantF f e) m+  => e `CouldBe` x+  => f x+  -> m a+throwFM = throwError . throwF++-- | Same as 'throwFM', but without the @f@ context. Given a value of some type+-- within a 'Variant' within a 'MonadError' context, "throw" the error.+throwM :: forall x e m a. ()+  => MonadError (Variant e) m+  => e `CouldBe` x+  => x+  -> m a+throwM = throwFM . Identity++-- | Add 'ExceptT (Variant '[])' to the monad transformer stack.+runOops :: ()+  => Monad m+  => ExceptT (Variant '[]) m a+  -> m a+runOops f = either (absurd . preposterous) pure =<< runExceptT f++-- | Suspend the 'ExceptT` monad transformer from the top of the stack so that the+-- stack can be manipulated without the 'ExceptT` layer.+suspendM :: forall x m a n b. ()+  => (m (Either x a) -> n (Either x b))+  -> ExceptT x m a+  -> ExceptT x n b+suspendM f = ExceptT . f . runExceptT++-- | Catch the specified exception.  If that exception is caught, exit the program.+catchAndExitFailureM :: forall x e m a. ()+  => MonadIO m+  => ExceptT (Variant (x : e)) m a+  -> ExceptT (Variant e) m a+catchAndExitFailureM = catchM @x (const (liftIO IO.exitFailure))++-- | When the expression of type 'Either x a' evaluates to 'Left x', throw the 'x',+-- otherwise return 'a'.+throwLeftM :: forall x e m a. ()+  => MonadError (Variant e) m+  => CouldBeF e x+  => Monad m+  => Either x a+  -> m a+throwLeftM = either throwM pure++-- | When the expression of type 'Maybe a' evaluates to 'Nothing', throw '()',+-- otherwise return 'a'.+throwNothingM :: ()+  => MonadError (Variant e) m+  => CouldBeF e ()+  => Monad m+  => Maybe a+  -> m a+throwNothingM = maybe (throwM ()) pure++-- | Catch the specified exception and return it instead.+-- The evaluated computation must return the same type that is being caught.+recoverM :: forall x e m a. ()+  => Monad m+  => (x -> a)+  -> ExceptT (Variant (x : e)) m a+  -> ExceptT (Variant e) m a+recoverM g f = f & catchM (pure . g)++-- | Catch the specified exception and return it instead.  The evaluated computation+-- must return `Void` (ie. it never returns)+recoverOrVoidM :: forall x e m. ()+  => Monad m+  => ExceptT (Variant (x : e)) m Void+  -> ExceptT (Variant e) m x+recoverOrVoidM f = either pure absurd =<< (fmap Right f & catchM @x (pure . Left))
+ src/Control/Monad/Oops/Classic.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE EmptyCase              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}++module Control.Monad.Oops.Classic+  ( -- * MTL/transformer utilities+    catchFM,+    catchM,++    snatchFM,+    snatchM,++    Oops.throwFM,+    Oops.throwM,++    Oops.runOops,+    Oops.suspendM,++    Oops.catchAndExitFailureM,++    Oops.throwLeftM,+    Oops.throwNothingM,++    Oops.recoverM,+    Oops.recoverOrVoidM,++  ) where++import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.Except (ExceptT(ExceptT))+import Data.Variant ( Catch, CatchF, CouldBe, Variant, VariantF )++import qualified Control.Monad.Oops as Oops++-- | When working in some monadic context, using 'catch' becomes trickier. The+-- intuitive behaviour is that each 'catch' shrinks the variant in the left+-- side of my 'MonadError', but this is therefore type-changing: as we can only+-- 'throwError' and 'catchError' with a 'MonadError' type, this is impossible!+--+-- To get round this problem, we have to specialise to 'ExceptT', which allows+-- us to map over the error type and change it as we go. If the error we catch+-- is the one in the variant that we want to handle, we pluck it out and deal+-- with it. Otherwise, we "re-throw" the variant minus the one we've handled.+catchFM :: forall x e e' f m a. ()+  => Monad m+  => CatchF x e e'+  => ExceptT (VariantF f e ) m a+  -> (f x -> ExceptT (VariantF f e') m a)+  -> ExceptT (VariantF f e') m a+catchFM = flip Oops.catchFM++-- | Just the same as 'catchFM', but specialised for our plain 'Variant' and+-- sounding much less like a radio station.+catchM :: forall x e e' m a. ()+  => Monad m+  => Catch x e e'+  => ExceptT (Variant e ) m a+  -> (x -> ExceptT (Variant e') m a)+  -> ExceptT (Variant e') m a+catchM = flip Oops.catchM++-- | Same as 'catchFM' except the error is not removed from the type.+-- This is useful for writing recursive computations or computations that+-- rethrow the same error type.+snatchFM+  :: forall x e f m a. ()+  => Monad m+  => e `CouldBe` x+  => ExceptT (VariantF f e) m a+  -> (f x -> ExceptT (VariantF f e) m a)+  -> ExceptT (VariantF f e) m a+snatchFM = flip Oops.snatchFM++-- | Same as 'catchM' except the error is not removed from the type.+-- This is useful for writing recursive computations or computations that+-- rethrow the same error type.+snatchM :: forall x e m a. ()+  => Monad m+  => e `CouldBe` x+  => ExceptT (Variant e) m a+  -> (x -> ExceptT (Variant e) m a)+  -> ExceptT (Variant e) m a+snatchM = flip Oops.snatchM
+ src/Data/Variant.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE EmptyCase              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module      : Data.Variant+Description : Generalised coproducts and methods for working with them.+Copyright   : (c) Tom Harding, 2019+License     : MIT+Maintainer  : tom.harding@habito.com+Stability   : experimental++Traditionally in Haskell, we use @Either a b@ to represent a choice of two+types. If we want to represent /three/ types, we use @Either a (Either b c)@,+and this nesting can continue as far as it needs to. However, this approach+comes with some difficulties: it's quite difficult to manipulate, and makes for+some rather unwieldy type signatures.++Thankfully, though, GHC provides us with GADTs, and they allow us to construct+a type that encompasses a coproduct of any number of arguments: the 'Variant'.+Just as @Left 3@ and @Right True@ are of type @Either Int Bool@, we can write+@Here 3@ and @There (Here True)@ to do the same thing (ignoring 'Identity'+wrappers). We can think of the 'Here' and 'There' constructors as an "index":+the index of the type we're storing is the number of occurrences of 'There'.++$setup+>>> :set -XTypeOperators -XDataKinds -XTypeApplications++> > > :t [ Here (Identity 'a'), There (There (Here (Identity True))) ]+[ Here (Identity 'a'), There (There (Here (Identity True))) ]+  :: [VariantF Identity (Char : x : Bool : xs)]+-}+module Data.Variant+  ( -- * Generalised coproducts+    VariantF (..)+  , Variant++    -- * Scott encodings+  , variantF+  , variant++    -- * Church encodings+  , case_+  , caseF++    -- * Injections+  , CouldBeF (..)+  , CouldBe  (..)+  , CouldBeAnyOfF+  , CouldBeAnyOf++    -- * Projections+  , CatchF (..)+  , Catch  (..)++    -- * Conversions to and from @Either@s+  , EithersF (..)+  , Eithers  (..)++    -- * Folds+  , FoldF (..)+  , Fold  (..)++    -- * Void conversions+  ,  preposterous+  , postposterous+  ) where++import Data.Bifunctor (first)+import Data.Function ((&))+import Data.Functor.Identity (Identity (..))+import Data.Kind (Constraint, Type)+import Data.Void (Void, absurd)+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Test.QuickCheck.Arbitrary (Arbitrary (..))++-- | The type @VariantF f '[x, y, z]@ is /either/ @f x@, @f y@, or @f z@. The+-- We construct these with @Here@, @There . Here@, and @There . There . Here@+-- respectively, and we can think o fthe number of 'There'-nestings as being+-- the index of our chosen type in the type-level list of options.+--+-- Often, however, we'll want to avoid being too explicit about our list of+-- types, preferring instead to describe it with constraints. See the methods+-- below for more information!+--+-- > > > :t [ Here (pure "Hello"), There (Here (pure True)) ]+-- [ Here (pure "Hello"), There (Here (pure True)) ]+--   :: Applicative f => [VariantF f ([Char] : Bool : xs)]+data VariantF (f :: k -> Type) (xs :: [k]) where+  Here  ::          f x  -> VariantF f (x ': xs)+  There :: VariantF f xs -> VariantF f (x ': xs)++type family AllF (c :: Type -> Constraint) (f :: k -> Type) (xs :: [k]) :: Constraint where+  AllF c f '[     ]  = ()+  AllF c f (x ': xs) = (c (f x), AllF c f xs)++deriving instance AllF Eq   f xs => Eq   (VariantF f xs)+deriving instance AllF Show f xs => Show (VariantF f xs)+deriving instance (AllF Eq f xs, AllF Ord f xs) => Ord (VariantF f xs)++instance (AllF Semigroup f xs) => Semigroup (VariantF f xs) where+  Here  x <> Here  y = Here  (x <> y)+  Here  _ <> There y = There  y+  There x <> Here  _ = There  x+  There x <> There y = There (x <> y)++instance (Monoid (f x), Semigroup (VariantF f (x ': xs)))+    => Monoid (VariantF f (x ': xs)) where+  mempty = Here mempty++-- | Often, you'll want to have a choice of types that /aren't/ all wrapped in+-- a functor. For this, we provide the 'Variant' type synonym, as well as+-- equivalents of all the functions below. These functions take care of+-- wrapping and unwrapping the 'Identity' wrapper, too, so it should be+-- invisible to users.+type Variant (xs :: [Type])+  = VariantF Identity xs++-- | Remove the first possibility from a variant. One nice possibility here is+-- a function that tells us whether the first type was the one in our variant:+-- @variantF Left Right@. For example:+--+-- >>> :set -XDataKinds+-- >>> variantF Left Right (Here (Identity True) :: Variant '[Bool])+-- Left (Identity True)+--+-- >>> variantF Left Right (There (Here (Identity 3)) :: Variant '[Bool, Int])+-- Right (Here (Identity 3))+variantF :: (f x -> r) -> (VariantF f xs -> r) -> VariantF f (x ': xs) -> r+variantF here there = \case Here x -> here x; There xs -> there xs++-- | Same as 'VariantF', but the value will be unwrapped (not in 'Identity') if+-- found.+--+-- >>> variant Left Right (Here (Identity True) :: Variant '[Bool])+-- Left True+--+-- >>> variant Left Right (There (Here (Identity 3)) :: Variant '[Bool, Int])+-- Right (Here (Identity 3))+variant :: (x -> r) -> (Variant xs -> r) -> Variant (x ': xs) -> r+variant here there = variantF (here . runIdentity) there++class CaseF (xs :: [Type]) (f :: Type -> Type) (r :: Type) (o :: Type)+    | xs f r -> o, o -> f r xs where+  caseF' :: Either r (VariantF f xs) -> o++instance CaseF '[x] f r ((f x -> r) -> r) where+  caseF' (Left   r) _ = r+  caseF' (Right xs) f = xs & variantF f \_ ->+    error $ "Impossible case - something isn't happy when performing the "+         <> "exhaustivity check as this case shouldn't need a pattern-match."++instance CaseF (y ': zs) f r ((f y -> r) -> o)+    => CaseF (x ': y ': zs) f r ((f x -> r) -> (f y -> r) -> o) where+  caseF' xs f = caseF' (xs >>= variantF (Left . f) Right)++-- | The 'either' function provides us with a way of folding an 'Either' by+-- providing a function for each possible constructor: 'Left' and 'Right'. In+-- our case, we could have any number of functions to supply, depending on how+-- many types are in our type-level index.+--+-- This function specialises depending on the variant provided:+--+-- > > > :t caseF (throw True :: Variant '[Bool])+-- caseF (throw True :: Variant '[Bool]) :: (Identity Bool -> r) -> r+--+-- > > > :t caseF (throwF (pure True) :: VariantF IO '[Int, Bool])+-- caseF (throwF (pure True) :: VariantF IO '[Int, Bool])+--   :: (IO Int -> o) -> (IO Bool -> o) -> o+caseF :: CaseF xs f r fold => VariantF f xs -> fold+caseF = caseF' . Right++class Case (xs :: [Type]) (r :: Type) (o :: Type)+    | xs r -> o, o -> r xs where+  case_' :: Either r (Variant xs) -> o++instance Case '[x] r ((x -> r) -> r) where+  case_' (Left   r) _ = r+  case_' (Right xs) f = xs & variantF (f . runIdentity) \_ ->+    error $ "Impossible case - something isn't happy when performing the "+         <> "exhaustivity check as this case shouldn't need a pattern-match."++instance Case (y ': zs) r ((y -> r) -> o)+    => Case (x ': y ': zs) r ((x -> r) -> (y -> r) -> o) where+  case_' xs f = case_' (xs >>= variantF (Left . f . runIdentity) Right)++-- | Same as 'caseF', but without the functor wrappers. Again, this function+-- will specialise according to the provided variant:+--+-- > > > :t case_ (throw True :: Variant '[Bool, Int])+-- case_ (throw True :: Variant '[Bool, Int])+--   :: (Bool -> o) -> (Int -> o) -> o+--+-- You can also use @TypeApplications@ to check the specialisation for a+-- particular variant:+--+-- > > > :t case_ @'[Int, Bool, String]+-- case_ @'[Int, Bool, String]+--   :: Variant '[Int, Bool, String]+--      -> (Int -> o) -> (Bool -> o) -> ([Char] -> o) -> o+case_ :: Case xs r fold => Variant xs -> fold+case_ = case_' . Right++type family TypeNotFound (x :: k) :: l where+  TypeNotFound x+    = TypeError ( 'Text "Uh oh! I couldn't find " ':<>: 'ShowType x+        ':<>: 'Text " inside the variant!"+        ':$$: 'Text "If you're pretty sure I'm wrong, perhaps the variant "+        ':<>: 'Text "type is ambiguous;"+        ':$$: 'Text "could you add some annotations?" )++-- | When dealing with larger (or polymorphic) variants, it becomes difficult+-- (or impossible) to construct 'VariantF' values explicitly. In that case, the+-- 'throwF' function gives us a polymorphic way to lift values into variants.+--+-- >>> throwF (pure "Hello") :: VariantF Maybe '[Bool, Int, Double, String]+-- There (There (There (Here (Just "Hello"))))+--+-- >>> throwF (pure True) :: VariantF Maybe '[Bool, Int, Double, String]+-- Here (Just True)+--+-- >>> throwF (pure True) :: VariantF IO '[Int, Double, String]+-- ...+-- ... • Uh oh! I couldn't find Bool inside the variant!+-- ...   If you're pretty sure I'm wrong, perhaps the variant type is ambiguous;+-- ...   could you add some annotations?+-- ...+class CouldBeF (xs :: [k]) (x :: k) where+  throwF :: f x -> VariantF f xs+  snatchF :: VariantF f xs -> Either (VariantF f xs) (f x)++instance CouldBeF (x ': xs) x where+  throwF = Here+  snatchF = \case+    Here  x  -> Right x+    There xs -> Left (There xs)++-- instance {-# INCOHERENT #-} (y ~ z, CatchF x xs ys)+--     => CatchF x (y ': xs) (z ': ys) where+--   catchF = \case+--     There xs -> first There (catchF xs)+--     Here  _  ->+--       error $ "Impossible case - something isn't happy when performing the "+--            <> "exhaustivity check as this case shouldn't need a pattern-match."++instance {-# OVERLAPPABLE #-} CouldBeF xs x+    => CouldBeF (y ': xs) x where+  throwF = There . throwF+  snatchF = \case+    There xs -> first There (snatchF xs)+    Here  _  ->+      error $ "Impossible case - something isn't happy when performing the "+           <> "exhaustivity check as this case shouldn't need a pattern-match."++instance TypeNotFound x => CouldBeF '[] x where+  throwF = error "Impossible!"+  snatchF = error "Impossible!"++-- | Just as with 'CouldBeF', we can "throw" values /not/ in a functor context+-- into a regular 'Variant'.+--+-- >>> throw (3 :: Int) :: Variant '[Bool, Int, Double, String]+-- There (Here (Identity 3))+--+-- >>> throw "Woo!" :: Variant '[Bool, Int, Double, String]+-- There (There (There (Here (Identity "Woo!"))))+class CouldBeF xs x => CouldBe (xs :: [Type]) (x :: Type) where+  throw :: x -> Variant xs+  snatch :: Variant xs -> Either (Variant xs) x++instance CouldBeF xs x => CouldBe xs x where+  throw = throwF . Identity+  snatch = fmap runIdentity . snatchF++type family All (cs :: [Constraint]) = (c :: Constraint) | c -> cs where+  All  '[] = ()+  All (c ': cs) = (c, All cs)++type family Map (f :: k -> l) (xs :: [k]) = (ys :: [l]) where+  Map f (x ': xs) = f x ': (Map f xs)+  Map f '[] = '[]++-- | As with 'CouldBeAnyOf', we can also constrain a variant to represent+-- several possible types, as we might with several 'CouldBeF' constraints,+-- using one type-level list.+type e `CouldBeAnyOfF` xs = All (Map (CouldBeF e) xs)++-- | Listing larger variants' constraints might amplify the noise of+-- functions' signatures. The 'CouldBeAnyOfF' constraint lets us specify+-- several types a variant may contain in a single type-level list, as opposed+-- to several independent constraints. So, we could replace,+--+-- f :: (e `CouldBe` Int, e `CouldBe` Bool, e `CouldBe` Char) => VariantF IO e+--+-- with the equivalent constraint,+--+-- f :: e `CouldBeAnyOf` '[Int, Bool, Char] => VariantF IO e+--+-- As 'CouldBeAnyOf' is just short-hand, we can use 'throw' just like when we+-- have 'CouldBe' constraints:+--+-- >>> :set -XTypeOperators+-- >>> :{+-- f :: e `CouldBeAnyOf` '[Int, Bool, Char] => Variant e+-- f = throw 'c'+-- :}+--+-- ... and eliminate constraints in just the same way:+--+-- >>> :{+-- g :: e `CouldBeAnyOf` '[Int, Bool] => Either (Variant e) Char+-- g = catch @Char f+-- :}+type e `CouldBeAnyOf` xs = All (Map (CouldBe e) xs)++-- | This is an odd constraint, as you should rarely need to /see/ it. GHC's+-- partial instantiation tricks should mean that mentions of this class "cancel+-- out" mentions of 'CouldBeF'. As an example, let's imagine a function that+-- represents some business logic that potentially "throws" either an 'Int' or+-- 'Bool' while it runs:+--+-- >>> :set -XFlexibleContexts -XMonoLocalBinds -XTypeOperators+-- >>> :{+-- f :: (e `CouldBe` Int, e `CouldBe` Bool) => VariantF IO e+-- f = throwF (pure True)+-- :}+--+-- As we can see, there are two constraints here. However, if we "catch" one of+-- these possible errors, we don't just add the 'CatchF' constraint: we /cancel+-- out/ the constraint corresponding to the type we caught:+--+-- >>> :{+-- g :: e `CouldBe` Int => Either (VariantF IO e) (IO Bool)+-- g = catchF @Bool f+-- :}+--+-- This means that constraints only propagate for __uncaught__ exceptions, just+-- as Java functions only need declare exceptions they /haven't/ caught. Once+-- we've caught all the errors, the constraint disappears! This can be a nice+-- way to work if you combine it with something like @ExceptT@.+class CatchF x xs ys | xs x -> ys, xs ys -> x, x ys -> xs where+  catchF :: VariantF f xs -> Either (VariantF f ys) (f x)++instance CatchF x (x ': xs) xs where+  catchF = \case+    Here  x  -> Right x+    There xs -> Left  xs++instance {-# INCOHERENT #-} (y ~ z, CatchF x xs ys)+    => CatchF x (y ': xs) (z ': ys) where+  catchF = \case+    There xs -> first There (catchF xs)+    Here  _  ->+      error $ "Impossible case - something isn't happy when performing the "+           <> "exhaustivity check as this case shouldn't need a pattern-match."++-- | 'throwF' is to 'catchF' as 'throw' is to @catch@. This function allows us+-- to discharge constraints for 'Variant' types. We can revisit the 'catchF'+-- example without the functor wrapper:+--+-- >>> :{+-- f :: (e `CouldBe` Int, e `CouldBe` Bool) => Variant e+-- f = throw True+-- :}+--+-- ... and be similarly excited when we make one of the constraints disappear:+--+-- >>> :{+-- g :: e `CouldBe` Int => Either (Variant e) Bool+-- g = catch @Bool f+-- :}+class CatchF x xs ys => Catch (x :: Type) (xs :: [Type]) (ys :: [Type]) where+  catch :: Variant xs -> Either (Variant ys) x++instance CatchF x xs ys => Catch x xs ys where+  catch = fmap runIdentity . catchF++-- | Occasionally, we might want to use our "nested 'Either'" analogue for+-- whatever reason. For that situation the functions here allow you to swap+-- between the two representations.+--+-- > > > :t toEithersF @IO @'[String, Int, Bool]+-- toEithersF @IO @'[String, Int, Bool]+--   :: VariantF IO '[String, Int, Bool]+--      -> Either (IO [Char]) (Either (IO Int) (IO Bool))+--+-- In order to maintain the round-tripping property (see below), the functional+-- dependency only goes from the variant to the nested either. This is because+-- the opposite doesn't always necessarily make sense.+--+-- If @Variant '[a, b]@ is converted to @Either a b@, it would seem sensible to+-- say the opposite is equally as mechanical. However, consider a nesting like+-- @Either a (Either b c)@: should this translate to @Variant '[a, b, c]@ or+-- @Variant '[a, Either b c]@? There's not a unique mapping in this direction,+-- so we can't add the functional dependency.+class EithersF (f :: Type -> Type) (xs :: [Type]) (o :: Type)+    | f xs -> o, o f -> xs where+  toEithersF   :: VariantF f xs -> o+  fromEithersF :: o -> VariantF f xs++instance EithersF f '[x] (f x) where+  toEithersF = variantF id \_ ->+    error $ "Impossible case - something isn't happy when performing the "+         <> "exhaustivity check as this case shouldn't need a pattern-match."++  fromEithersF = Here++instance (Functor f, EithersF f (y ': xs) zs)+    => EithersF f (x ': y ': xs) (Either (f x) zs) where+  toEithersF = variantF Left (Right . toEithersF)+  fromEithersF = either Here (There . fromEithersF)++-- | The @f@-less analogue of 'EithersF'. The same properties as described+-- above will hold, with the same issues around 'fromEithers' result inference.+--+-- > > > :t toEithers @'[String, Int, Bool]+-- toEithers @'[String, Int, Bool]+--   :: Variant '[String, Int, Bool] -> Either [Char] (Either Int Bool)+--+-- The round-tripping property is also conserved:+class Eithers (xs :: [Type]) (o :: Type) | xs -> o where+  toEithers   :: Variant xs -> o+  fromEithers :: o -> Variant xs++instance Eithers '[x] x where+  toEithers = variant id \_ ->+    error $ "Impossible case - something isn't happy when performing the "+         <> "exhaustivity check as this case shouldn't need a pattern-match."++  fromEithers = Here . Identity++instance Eithers (y ': xs) zs => Eithers (x ': y ': xs) (Either x zs) where+  toEithers   = variant Left (Right . toEithers)+  fromEithers = either (Here . Identity) (There . fromEithers)++-- | A constraint-based fold requires a polymorphic function relying on a+-- shared constraint between all members of the variant. If that's a lot of+-- words, let's see a little example:+--+-- >>> foldF @Show (throwF ["hello"] :: VariantF [] '[(), String, Bool]) show+-- "[\"hello\"]"+--+-- If everything in our variant is 'Show'-friendly, we can fold it with the+-- 'show' function, and we just show whatever is in there!+class FoldF (c :: Type -> Constraint) (xs :: [Type]) where+  foldF :: VariantF f xs -> (forall x. c x => f x -> m) -> m++instance FoldF c '[] where+  foldF xs _ = absurd (preposterous xs)++instance (c x, FoldF c xs) => FoldF c (x ': xs) where+  foldF (Here  x ) f = f x+  foldF (There xs) f = foldF @c xs f++-- | Similarly, we can fold the wrapper-less version in the same way. As an+-- example, if all the types are the same, we can pull out whatever value is in+-- there using the fold interface.+--+-- >>> :set -XRankNTypes -XScopedTypeVariables+-- >>> :{+-- fold' :: forall x xs. Fold ((~) x) xs => Variant xs -> x+-- fold' xs = fold @((~) x) xs id+-- :}+--+-- If all the types in the list are the same, and we can turn values of that+-- type into some result and return it.+class FoldF c xs => Fold (c :: Type -> Constraint) (xs :: [Type]) where+  fold :: Variant xs -> (forall x. c x => x -> m) -> m++instance FoldF c xs => Fold c xs where+  fold xs f = foldF @c xs (f . runIdentity)++-- | A choice of zero types is an uninhabited type! This means we can convert+-- it to 'Void'...+preposterous :: VariantF f '[] -> Void+preposterous = \case++-- | ... and it also means we can convert back!+postposterous :: Void -> VariantF f '[]+postposterous = \case++instance (EithersF f xs nested, Arbitrary nested) => Arbitrary (VariantF f xs) where+  arbitrary = fmap fromEithersF arbitrary
+ test/Data/VariantSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module Data.VariantSpec (spec) where++import HaskellWorks.Hspec.Hedgehog (require)+import Hedgehog ((===), forAll, property)+import Test.Hspec (describe, it, Spec)++import qualified Data.Variant as DV+import qualified Hedgehog.Gen.QuickCheck as G++{- HLINT ignore "Redundant do"        -}++spec :: Spec+spec = describe "Data.VariantSpec" $ do+  it "VariantF" $ require $ property $ do+    x <-forAll $ G.arbitrary @(DV.VariantF Maybe '[Int, String])++    DV.fromEithersF (DV.toEithersF x) === x+  it "Variant" $ require $ property $ do+    x <-forAll $ G.arbitrary @(DV.Variant '[Int, String, Bool])++    DV.fromEithersF (DV.toEithersF x) === x
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}