haskus-utils-variant 2.6.1 → 3.0

raw patch · 12 files changed

+1238/−2777 lines, 12 filesdep ~basedep ~haskus-utils-datadep ~haskus-utils-typesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, haskus-utils-data, haskus-utils-types

API changes (from Hackage documentation)

Files

• haskus-utils-variant.cabal +13/−12
• src/lib/Haskus/Utils/ContFlow.hs +52/−37
• src/lib/Haskus/Utils/EADT.hs +57/−71
• src/lib/Haskus/Utils/EGADT.hs +121/−0
• src/lib/Haskus/Utils/Variant.hs +170/−137
• src/lib/Haskus/Utils/Variant/Cont.hs +0/−99
• src/lib/Haskus/Utils/Variant/Excepts.hs +401/−0
• src/lib/Haskus/Utils/Variant/Flow.hs +0/−346
• src/lib/Haskus/Utils/Variant/OldFlow.hs +0/−1984
• src/lib/Haskus/Utils/Variant/VEither.hs +240/−0
• src/lib/Haskus/Utils/VariantF.hs +101/−84
• src/tests/EADT.hs +83/−7

@@ -1,12 +1,12 @@ name:                haskus-utils-variant-version:             2.6.1+version:             3.0 synopsis:            Variant and EADT license:             BSD3 license-file:        LICENSE author:              Sylvain Henry maintainer:          sylvain@haskus.fr-homepage:            http://www.haskus.org-copyright:           Sylvain Henry 2018+homepage:            https://www.haskus.org+copyright:           Sylvain Henry 2020 category:            System build-type:          Simple cabal-version:       1.20@@ -17,19 +17,19 @@  source-repository head   type: git-  location: git://github.com/haskus/haskus-utils.git+  location: git://github.com/haskus/packages.git  library   exposed-modules:     Haskus.Utils.ContFlow     Haskus.Utils.Variant-    Haskus.Utils.Variant.OldFlow-    Haskus.Utils.Variant.Flow-    Haskus.Utils.Variant.Cont+    Haskus.Utils.Variant.VEither+    Haskus.Utils.Variant.Excepts     Haskus.Utils.Variant.Syntax     Haskus.Utils.VariantF     Haskus.Utils.EADT     Haskus.Utils.EADT.TH+    Haskus.Utils.EGADT    other-modules: @@ -39,10 +39,9 @@    ,  deepseq    ,  exceptions                >= 0.9    ,  template-haskell-   ,  haskus-utils-types        >= 1.4.1-   ,  haskus-utils-data+   ,  haskus-utils-types        >= 1.5+   ,  haskus-utils-data         >= 1.2 -  build-tools:    ghc-options:          -Wall   default-language:     Haskell2010   hs-source-dirs:       src/lib@@ -58,8 +57,10 @@       ,  EADT     build-depends:-         base+         base                    >= 4.9 && < 5.0       ,  haskus-utils-variant+      ,  haskus-utils-types+      ,  haskus-utils-data       ,  tasty                   >= 0.11       ,  tasty-quickcheck        >= 0.8       ,  doctest                 >= 0.16@@ -71,7 +72,7 @@    ghc-options:         -Wall -threaded    default-language:    Haskell2010    build-depends:-         base+         base                    >= 4.9 && < 5.0       ,  haskus-utils-variant       ,  criterion       ,  QuickCheck

@@ -11,74 +11,89 @@ -- | Continuation based control-flow module Haskus.Utils.ContFlow    ( ContFlow (..)+   , ContTuple+   , (>:>)+   , (>-:>)+   , (>%:>)    , (>::>)    , (>:-:>)    , (>:%:>)-   , ContListToTuple-   , ContTupleToList-   , StripR-   , AddR+   , ToMultiCont    , MultiCont (..)    ) where  import Haskus.Utils.Tuple-import Haskus.Utils.Types  -- | A continuation based control-flow-newtype ContFlow (xs :: [*]) r = ContFlow (ContListToTuple xs r -> r)+newtype ContFlow (xs :: [*]) r = ContFlow (ContTuple xs r -> r)  -- | Convert a list of types into the actual data type representing the -- continuations.-type family ContListToTuple (xs :: [*]) r where-   ContListToTuple xs r = ListToTuple (AddR xs r)+type family ContTuple (xs :: [*]) r where+   ContTuple xs r = Tuple (ToMultiCont xs r) --- | Convert a tuple of continuations into a list of types-type family ContTupleToList t r :: [*] where-   ContTupleToList t r = StripR (TupleToList t) r+type family ToMultiCont xs r where+   ToMultiCont '[] r       = '[]+   ToMultiCont (x ': xs) r = (x -> r) ': ToMultiCont xs r -type family AddR f r where-   AddR '[] r       = '[]-   AddR (x ': xs) r = (x -> r) ': AddR xs r+-- | A multi-continuable type+class MultiCont a where+   type MultiContTypes a :: [*] -type family StripR f r where-   StripR '[] r              = '[]-   StripR ((x -> r) ': xs) r = x ': StripR xs r-   StripR ((x -> w) ': xs) r =-      TypeError ( 'Text "Invalid continuation return type `"-                  ':<>: 'ShowType w ':<>: 'Text "', expecting `"-                  ':<>: 'ShowType r ':<>: 'Text "'")+   -- | Convert a data into a multi-continuation+   toCont :: a -> ContFlow (MultiContTypes a) r +   -- | Convert a data into a multi-continuation (monadic)+   toContM :: Monad m => m a -> ContFlow (MultiContTypes a) (m r)+++-- | Bind a multi-continuable type to a tuple of continuations+(>:>) :: MultiCont a => a -> ContTuple (MultiContTypes a) r -> r+{-# INLINABLE (>:>) #-}+(>:>) a !cs = toCont a >::> cs++infixl 0 >:>++-- | Bind a single-continuable type to a 1-tuple of continuations+(>-:>) :: (MultiCont a, MultiContTypes a ~ '[b]) => a -> (b -> r) -> r+{-# INLINABLE (>-:>) #-}+(>-:>) a c = toCont a >:-:> c++infixl 0 >-:>++-- | Bind a multi-continuable type to a tuple of continuations and+-- reorder fields if necessary+(>%:>) ::+   ( MultiCont a+   , ReorderTuple ts (ContTuple (MultiContTypes a) r)+   ) => a -> ts -> r+{-# INLINABLE (>%:>) #-}+(>%:>) a !cs = toCont a >:%:> cs++infixl 0 >%:>++ -- | Bind a flow to a tuple of continuations-(>::>) :: ContFlow xs r -> ContListToTuple xs r -> r-{-# INLINE (>::>) #-}+(>::>) :: ContFlow xs r -> ContTuple xs r -> r+{-# INLINABLE (>::>) #-} (>::>) (ContFlow f) !cs = f cs  infixl 0 >::>  -- | Bind a flow to a 1-tuple of continuations (>:-:>) :: ContFlow '[a] r -> (a -> r) -> r-{-# INLINE (>:-:>) #-}-(>:-:>) (ContFlow f) c = f (Single c)+{-# INLINABLE (>:-:>) #-}+(>:-:>) (ContFlow f) c = f (Unit c)  infixl 0 >:-:>  -- | Bind a flow to a tuple of continuations and -- reorder fields if necessary (>:%:>) :: forall ts xs r.-   ( ReorderTuple ts (ContListToTuple xs r)+   ( ReorderTuple ts (ContTuple xs r)    ) => ContFlow xs r -> ts -> r-{-# INLINE (>:%:>) #-}+{-# INLINABLE (>:%:>) #-} (>:%:>) (ContFlow f) !cs = f (tupleReorder cs)  infixl 0 >:%:>---class MultiCont a where-   type MultiContTypes a :: [*]--   -- | Convert a data into a multi-continuation-   toCont :: a -> ContFlow (MultiContTypes a) r--   -- | Convert a data into a multi-continuation (monadic)-   toContM :: Monad m => m a -> ContFlow (MultiContTypes a) (m r)

@@ -17,19 +17,13 @@  -- | Extensible ADT module Haskus.Utils.EADT-   ( EADT+   ( EADT (..)    , (:<:)    , (:<<:)    , pattern VF    , appendEADT    , liftEADT    , popEADT-   , AlterEADT-   , alterEADT-   , AlgEADT-   , algEADT-   , eadtToCont-   , eadtToContM    , contToEADT    , contToEADTM    -- * Reexport@@ -42,12 +36,10 @@ import Haskus.Utils.Variant import Haskus.Utils.Functor import Haskus.Utils.Types.List+import Haskus.Utils.Types.Constraint import Haskus.Utils.Types import Haskus.Utils.ContFlow -import GHC.Exts (Constraint)-import Control.DeepSeq- -- $setup -- >>> :set -XDataKinds -- >>> :set -XTypeApplications@@ -56,37 +48,57 @@ -- >>> :set -XTypeFamilies -- >>> :set -XPatternSynonyms -- >>> :set -XDeriveFunctor+-- >>> -- >>> import Data.Functor.Classes+-- >>> -- >>> data ConsF a e = ConsF a e deriving (Functor) -- >>> data NilF    e = NilF      deriving (Functor)+-- >>> -- >>> instance Eq a => Eq1 (ConsF a) where liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2 -- >>> instance Eq1 NilF where liftEq _ _ _ = True+-- >>> -- >>> :{ -- >>> pattern Cons :: ConsF a :<: xs => a -> EADT xs -> EADT xs -- >>> pattern Cons a l = VF (ConsF a l) -- >>> pattern Nil :: NilF :<: xs => EADT xs -- >>> pattern Nil = VF NilF--- >>> type List a = EADT '[ConsF a, NilF]+-- >>> type ListF a = VariantF '[NilF, ConsF a]+-- >>> type List a = EADT '[NilF, ConsF a] -- >>> :}----- | An extensible ADT ----- >>> VF NilF == (VF NilF :: EADT '[ConsF Int, NilF])--- True+-- >>> -- >>> let a = Cons "Hello" (Cons "World" Nil) :: List String -- >>> let b = Cons "Bonjour" (Cons "Monde" Nil) :: List String -- >>> a == b -- False -- >>> a == a -- True-type EADT xs = Fix (VariantF xs) --- TODO: GHC 8.6--- Replace EADT with a newtype isomorphic to Fix.--- Use "DerivingVia" to derive instances from "Fix"-deriving newtype instance NFData (VariantF xs (EADT xs)) => NFData (EADT xs) +-- | An extensible ADT+newtype EADT fs+   = EADT (VariantF fs (EADT fs))++type instance Base (EADT fs) = VariantF fs++instance Functor (VariantF fs) => Recursive (EADT fs) where+   project (EADT a) = a++instance Functor (VariantF fs) => Corecursive (EADT fs) where+   embed = EADT++instance Eq1 (VariantF fs) => Eq (EADT fs) where+  EADT a == EADT b = eq1 a b++instance Ord1 (VariantF fs) => Ord (EADT fs) where+  compare (EADT a) (EADT b) = compare1 a b++instance Show1 (VariantF fs) => Show (EADT fs) where+  showsPrec d (EADT a) =+    showParen (d >= 11)+      $ showString "EADT "+      . showsPrec1 11 a+ -- | Constructor `f` is in `xs` type family f :<: xs where    f :<: xs = EADTF' f (EADT xs) xs@@ -109,7 +121,7 @@    ( e ~ EADT cs  -- allow easy use of TypeApplication to set the EADT type    , f :<: cs     -- constraint synonym ensuring `f` is in `cs`    ) => f (EADT cs) -> EADT cs-pattern VF x = Fix (VariantF (VSilent x))+pattern VF x = EADT (VariantF (VSilent x))    -- `VSilent` matches a variant value without checking the membership: we    -- already do it with :<: @@ -119,15 +131,15 @@    , ApplyAll (EADT zs) zs ~ Concat (ApplyAll (EADT zs) xs) (ApplyAll (EADT zs) ys)    , Functor (VariantF xs)    ) => EADT xs -> EADT zs-appendEADT (Fix v) = Fix (appendVariantF @ys (fmap (appendEADT @ys) v))+appendEADT (EADT v) = EADT (appendVariantF @ys (fmap (appendEADT @ys) v))  -- | Lift an EADT into another liftEADT :: forall e as bs.-   ( e ~ Fix (VariantF bs)+   ( e ~ EADT bs    , LiftVariantF as bs e    , Functor (VariantF as)    ) => EADT as -> EADT bs-liftEADT = cata (Fix . liftVariantF)+liftEADT = cata (EADT . liftVariantF)  -- | Pop an EADT value popEADT :: forall f xs e.@@ -135,57 +147,31 @@    , e ~ EADT xs    , f e :< ApplyAll e xs    ) => EADT xs -> Either (VariantF (Remove f xs) (EADT xs)) (f (EADT xs))-popEADT (Fix v) = popVariantF v--type AlterEADT c xs = AlterVariantF c (EADT xs) xs---- | Alter an EADT value-alterEADT :: forall c xs.-   ( AlterEADT c xs-   ) => (forall f. c f => f (EADT xs) -> f (EADT xs)) -> EADT xs -> EADT xs-alterEADT f (Fix v) = Fix (alterVariantF @c @(EADT xs) f v)--type AlgEADT c r xs = AlgVariantF c (EADT xs) r xs---- | Apply an algebra to an EADT value-algEADT :: forall c r xs.-   ( AlgEADT c r xs-   ) => (forall f. c f => f (EADT xs) -> r) -> EADT xs -> r-algEADT f (Fix v) = algVariantF @c @(EADT xs) @r f v---- | Convert an EADT into a multi-continuation-eadtToCont ::-   ( ContVariant (ApplyAll (Fix (VariantF xs)) xs)-   ) => Fix (VariantF xs) -> ContFlow (ApplyAll (Fix (VariantF xs)) xs) r-eadtToCont (Fix v) = variantFToCont v---- | Convert an EADT into a multi-continuation-eadtToContM ::-   ( ContVariant (ApplyAll (Fix (VariantF xs)) xs)-   , Monad m-   ) => m (Fix (VariantF xs))-     -> ContFlow (ApplyAll (Fix (VariantF xs)) xs) (m r)-eadtToContM f = variantFToContM (unfix <$> f)+popEADT (EADT v) = popVariantF v --- Orphan instance...--- instance ContVariant (ApplyAll (EADT xs) xs) => MultiCont (EADT xs) where---    type MultiContTypes (EADT xs) = ApplyAll (EADT xs) xs---    toCont  = eadtToCont---    toContM = eadtToContM+-- | MultiCont instance+--+-- >>> let f x = toCont x >::> (const "[]", \(ConsF u us) -> u ++ ":" ++ f us)+-- >>> f a+-- "Hello:World:[]"+instance (Functor (VariantF xs), ContVariant (ApplyAll (EADT xs) xs)) => MultiCont (EADT xs) where+   type MultiContTypes (EADT xs) = ApplyAll (EADT xs) xs+   toCont  (EADT v) = variantFToCont v+   toContM f        = variantFToContM (project <$> f)  -- | Convert a multi-continuation into an EADT contToEADT ::-   ( ContVariant (ApplyAll (Fix (VariantF xs)) xs)-   ) => ContFlow (ApplyAll (Fix (VariantF xs)) xs)-                 (V (ApplyAll (Fix (VariantF xs)) xs))-     -> Fix (VariantF xs)-contToEADT c = Fix (contToVariantF c)+   ( ContVariant (ApplyAll (EADT xs) xs)+   ) => ContFlow (ApplyAll (EADT xs) xs)+                 (V (ApplyAll (EADT xs) xs))+     -> EADT xs+contToEADT c = EADT (contToVariantF c)  -- | Convert a multi-continuation into an EADT contToEADTM ::-   ( ContVariant (ApplyAll (Fix (VariantF xs)) xs)+   ( ContVariant (ApplyAll (EADT xs) xs)    , Monad f-   ) => ContFlow (ApplyAll (Fix (VariantF xs)) xs)-                 (f (V (ApplyAll (Fix (VariantF xs)) xs)))-     -> f (Fix (VariantF xs))-contToEADTM f = Fix <$> contToVariantFM f+   ) => ContFlow (ApplyAll (EADT xs) xs)+                 (f (V (ApplyAll (EADT xs) xs)))+     -> f (EADT xs)+contToEADTM f = EADT <$> contToVariantFM f

@@ -0,0 +1,121 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Haskus.Utils.EGADT where++import Unsafe.Coerce++import Haskus.Utils.Monad+import Haskus.Utils.Variant+import Haskus.Utils.VariantF+import Haskus.Utils.Types++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeApplications+-- >>> :set -XTypeOperators+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeFamilies+-- >>> :set -XPatternSynonyms+-- >>> :set -XDeriveFunctor+-- >>> :set -XGADTs+-- >>> :set -XPolyKinds+-- >>> :set -XPartialTypeSignatures+-- >>>+-- >>> :{+-- >>> data LamF (ast :: Type -> Type) t where+-- >>>   LamF :: ( ast a -> ast b ) -> LamF ast ( a -> b )+-- >>> +-- >>> data AppF ast t where+-- >>>   AppF :: ast ( a -> b ) -> ast a -> AppF ast b+-- >>>+-- >>> data VarF ast t where+-- >>>   VarF :: String -> VarF ast Int+-- >>>+-- >>> type AST a = EGADT '[LamF,AppF,VarF] a+-- >>>+-- >>> :}+--+-- >>> let y = VF @(AST Int) (VarF "a")+-- >>> :t y+-- y :: EGADT '[LamF, AppF, VarF] Int+--+-- >>> :{+-- >>> case y of+-- >>>   VF (VarF x) -> print x+-- >>>   _           -> putStrLn "Not a VarF"+-- >>> :}+-- "a"+--+-- >>> :{+-- >>> f :: AST Int -> AST Int+-- >>> f (VF (VarF x)) = VF (VarF "zz")+-- >>> f _             = error "Unhandled case"+-- >>> :}+--+-- >>> let z = VF (AppF (VF (LamF f)) (VF (VarF "a")))+-- >>> :t z+-- z :: EGADT '[LamF, AppF, VarF] Int+--+++-- | An EADT with an additional type parameter+newtype EGADT fs t = EGADT (HVariantF fs (EGADT fs) t)++newtype HVariantF (fs :: [ (k -> Type) -> ( k -> Type) ]) (ast :: k -> Type) (t :: k)+  = HVariantF (VariantF (ApplyAll ast fs) t)++toHVariantAt+  :: forall i fs ast a+  .  KnownNat i+  => (Index i fs) ast a -> VariantF (ApplyAll ast fs) a+{-# INLINABLE toHVariantAt #-}+toHVariantAt a = VariantF (Variant (natValue' @i) (unsafeCoerce a))++fromHVariantAt+  :: forall i fs ast a+  .  KnownNat i+  => VariantF (ApplyAll ast fs) a -> Maybe ((Index i fs) ast a)+{-# INLINABLE fromHVariantAt #-}+fromHVariantAt (VariantF (Variant t a)) = do+  guard (t == natValue' @i)+  return (unsafeCoerce a)++type instance HBase (EGADT xs) = HVariantF xs++instance HFunctor (HVariantF xs) => HRecursive (EGADT xs) where+  hproject (EGADT a) = a++instance HFunctor (HVariantF xs) => HCorecursive (EGADT xs) where+  hembed = EGADT++type family f :<! fs :: Constraint where+  f :<! fs = ( MemberAtIndex (IndexOf f fs) f fs )++type family MemberAtIndex (i :: Nat) f fs :: Constraint where+  MemberAtIndex i f fs = ( KnownNat i, Index i fs ~ f )++type family (:<<!) xs ys :: Constraint where+  '[]       :<<! ys = ()+  (x ': xs) :<<! ys = (x :<! ys, xs :<<! ys)++-- | Pattern-match in an extensible GADT+pattern VF :: forall e a f fs.+  ( e ~ EGADT fs a  -- allow easy use of TypeApplication to set the EGADT type+  , f :<! fs+  ) => f (EGADT fs) a -> EGADT fs a+pattern VF x <- ( ( \ ( EGADT (HVariantF v) ) -> fromHVariantAt @(IndexOf f fs) @fs v ) -> Just x )+  where+    VF x = EGADT (HVariantF (toHVariantAt @(IndexOf f fs) @fs x))

@@ -103,11 +103,12 @@    , toVariant'    , LiftVariant'    , PopVariant+   , showsVariant    ) where  import Unsafe.Coerce-import GHC.Exts (Any,Constraint)+import GHC.Exts (Any) import Data.Typeable import Control.DeepSeq @@ -167,7 +168,7 @@    , Eq x    ) => Eq (V (x ': xs))    where-      {-# INLINE (==) #-}+      {-# INLINABLE (==) #-}       (==) v1@(Variant t1 _) v2@(Variant t2 _)          | t1 /= t2  = False          | otherwise = case (popVariantHead v1, popVariantHead v2) of@@ -193,7 +194,7 @@    showVariantValue :: a -> ShowS  instance ShowVariantValue (V '[]) where-   {-# INLINE showVariantValue #-}+   {-# INLINABLE showVariantValue #-}    showVariantValue _ = showString "undefined"  instance@@ -202,7 +203,7 @@    , Typeable x    ) => ShowVariantValue (V (x ': xs))    where-   {-# INLINE showVariantValue #-}+   {-# INLINABLE showVariantValue #-}    showVariantValue v = case popVariantHead v of          Right x -> showString "V @"                     . showsPrec 10 (typeOf x)@@ -210,21 +211,41 @@                     . showsPrec 11 x          Left xs -> showVariantValue xs -instance-   ( Show (V xs)-   , Typeable xs+-- | Haskell code corresponding to a Variant+--+-- >>> showsVariant 0 (V @Double 5.0 :: V '[Int,String,Double]) ""+-- "V @Double 5.0 :: V '[Int, [Char], Double]"+showsVariant ::+   ( Typeable xs    , ShowTypeList (V xs)    , ShowVariantValue (V xs)-   ) => Show (V xs)+   ) => Int -> V xs -> ShowS+showsVariant d v = showParen (d /= 0) $+   showVariantValue v+   . showString " :: "+   -- disabled until GHC fixes #14341+   -- . showsPrec 0 (typeOf v)+   -- workaround:+   . showString "V "+   . showList__ (showTypeList v)++instance Show (V '[]) where+   {-# INLINABLE showsPrec #-}+   showsPrec _ _ = undefined+++-- | Show instance+--+-- >>> show (V @Int 10  :: V '[Int,String,Double])+-- "10"+instance+   ( Show x+   , Show (V xs)+   ) => Show (V (x ': xs))    where-      showsPrec d v = showParen (d /= 0) $-         showVariantValue v-         . showString " :: "-         -- disabled until GHC fixes #14341-         -- . showsPrec 0 (typeOf v)-         -- workaround:-         . showString "V "-         . showList__ (showTypeList v)+      showsPrec d v = case popVariantHead v of+         Right x -> showsPrec d x+         Left xs -> showsPrec d xs  -- | Show a list of ShowS showList__ :: [ShowS] -> ShowS@@ -242,11 +263,11 @@    showTypeList :: a -> [ShowS]  instance ShowTypeList (V '[]) where-   {-# INLINE showTypeList #-}+   {-# INLINABLE showTypeList #-}    showTypeList _ = []  instance (Typeable x, ShowTypeList (V xs)) => ShowTypeList (V (x ': xs)) where-   {-# INLINE showTypeList #-}+   {-# INLINABLE showTypeList #-}    showTypeList _ = showsPrec 0 (typeOf (undefined :: x)) : showTypeList (undefined :: V xs)  -- | Get Variant index@@ -279,7 +300,7 @@ -- | Set the value with the given indexed type -- -- >>> toVariantAt @1 10 :: V '[Word,Int,Double]--- V @Int 10 :: V '[Word, Int, Double]+-- 10 -- toVariantAt :: forall (n :: Nat) (l :: [*]).    ( KnownNat n@@ -290,7 +311,7 @@ -- | Set the first value -- -- >>> toVariantHead 10 :: V '[Int,Float,Word]--- V @Int 10 :: V '[Int, Float, Word]+-- 10 -- toVariantHead :: forall x xs. x -> V (x ': xs) {-# INLINABLE toVariantHead #-}@@ -300,8 +321,8 @@ -- -- >>> let x = V @Int 10 :: V '[Int,String,Float] -- >>> let y = toVariantTail @Double x--- >>> y--- V @Int 10 :: V '[Double, Int, [Char], Float]+-- >>> :t y+-- y :: V '[Double, Int, String, Float] -- toVariantTail :: forall x xs. V xs -> V (x ': xs) {-# INLINABLE toVariantTail #-}@@ -343,11 +364,11 @@ -- -- >>> let x = V @Word 10 :: V '[Int,Word,Float] -- >>> popVariantAt @0 x--- Left (V @Word 10 :: V '[Word, Float])+-- Left 10 -- >>> popVariantAt @1 x -- Right 10 -- >>> popVariantAt @2 x--- Left (V @Word 10 :: V '[Int, Word])+-- Left 10 -- popVariantAt :: forall (n :: Nat) l.     ( KnownNat n@@ -363,7 +384,7 @@ -- -- >>> let x = V @Word 10 :: V '[Int,Word,Float] -- >>> popVariantHead x--- Left (V @Word 10 :: V '[Word, Float])+-- Left 10 -- -- >>> let y = V @Int 10 :: V '[Int,Word,Float] -- >>> popVariantHead y@@ -380,10 +401,10 @@ -- >>> import Data.Char (toUpper) -- >>> let x = V @String "Test" :: V '[Int,String,Float] -- >>> mapVariantAt @1 (fmap toUpper) x--- V @[Char] "TEST" :: V '[Int, [Char], Float]+-- "TEST" -- -- >>> mapVariantAt @0 (+1) x--- V @[Char] "Test" :: V '[Int, [Char], Float]+-- "Test" mapVariantAt :: forall (n :: Nat) a b l.    ( KnownNat n    , a ~ Index n l@@ -401,7 +422,7 @@ -- >>> let f s = if s == "Test" then Just (42 :: Word) else Nothing -- >>> let x = V @String "Test" :: V '[Int,String,Float] -- >>> mapVariantAtM @1 f x--- Just (V @Word 42 :: V '[Int, Word, Float])+-- Just 42 -- -- >>> let y = V @String "NotTest" :: V '[Int,String,Float] -- >>> mapVariantAtM @1 f y@@ -409,16 +430,22 @@ -- -- Example with `IO`: ----- >>> mapVariantAtM @0 print x--- V @[Char] "Test" :: V '[(), [Char], Float]+-- >>> v <- mapVariantAtM @0 print x ----- >>> mapVariantAtM @1 print x+-- >>> :t v+-- v :: V '[(), String, Float]+--+-- >>> v <- mapVariantAtM @1 print x -- "Test"--- V @() () :: V '[Int, (), Float] ----- >>> mapVariantAtM @2 print x--- V @[Char] "Test" :: V '[Int, [Char], ()]+-- >>> :t v+-- v :: V '[Int, (), Float] --+-- >>> v <- mapVariantAtM @2 print x+-- +-- >>> :t v+-- v :: V '[Int, [Char], ()]+-- mapVariantAtM :: forall (n :: Nat) a b l m .    ( KnownNat n    , Applicative m@@ -466,10 +493,10 @@ -- -- >>> let f = mapVariantHeadTail (+5) (appendVariant @'[Double,Char]) -- >>> f (V @Int 10 :: V '[Int,Word,Float])--- V @Int 15 :: V '[Int, Word, Float, Double, Char]+-- 15 -- -- >>> f (V @Word 20 :: V '[Int,Word,Float])--- V @Word 20 :: V '[Int, Word, Float, Double, Char]+-- 20 -- mapVariantHeadTail :: (x -> y) -> (V xs -> V ys) -> V (x ': xs) -> V (y ': ys) {-# INLINABLE mapVariantHeadTail #-}@@ -504,7 +531,7 @@    popVariant' :: V xs -> Either (V (Remove a xs)) a  instance PopVariant a '[] where-   {-# INLINE popVariant' #-}+   {-# INLINABLE popVariant' #-}    popVariant' _ = undefined  instance forall a xs n xs' y ys.@@ -516,7 +543,7 @@       , xs ~ (y ': ys)       ) => PopVariant a (y ': ys)    where-      {-# INLINE popVariant' #-}+      {-# INLINABLE popVariant' #-}       popVariant' (Variant t a)          = case natValue' @n of             0             -> Left (Variant t a) -- no 'a' left in xs@@ -528,7 +555,7 @@    splitVariant' :: V xs -> Either (V rs) (V as)  instance SplitVariant as rs '[] where-   {-# INLINE splitVariant' #-}+   {-# INLINABLE splitVariant' #-}    splitVariant' _ = undefined  instance forall as rs xs x n m.@@ -539,7 +566,7 @@    , KnownNat n    ) => SplitVariant as rs (x ': xs)    where-      {-# INLINE splitVariant' #-}+      {-# INLINABLE splitVariant' #-}       splitVariant' (Variant 0 v)          = case natValue' @n of             -- we assume that if `x` isn't in `as`, it is in `rs`@@ -652,11 +679,11 @@ -- -- >>> let x = toVariantAt @0 10 :: V '[Int,String,Int] -- >>> mapVariantFirst @Int (+32) x--- V @Int 42 :: V '[Int, [Char], Int]+-- 42 -- -- >>> let y = toVariantAt @2 10 :: V '[Int,String,Int] -- >>> mapVariantFirst @Int (+32) y--- V @Int 10 :: V '[Int, [Char], Int]+-- 10 -- mapVariantFirst :: forall a b n l.    ( Member a l@@ -671,25 +698,25 @@ -- -- >>> let f s = if s == (42 :: Int) then Just "Yeah!" else Nothing -- >>> mapVariantFirstM f (toVariantAt @0 42 :: V '[Int,Float,Int])--- Just (V @[Char] "Yeah!" :: V '[[Char], Float, Int])+-- Just "Yeah!" -- -- >>> mapVariantFirstM f (toVariantAt @2 42 :: V '[Int,Float,Int])--- Just (V @Int 42 :: V '[[Char], Float, Int])+-- Just 42 -- -- >>> mapVariantFirstM f (toVariantAt @0 10 :: V '[Int,Float,Int]) -- Nothing -- -- >>> mapVariantFirstM f (toVariantAt @2 10 :: V '[Int,Float,Int])--- Just (V @Int 10 :: V '[[Char], Float, Int])+-- Just 10 -- -- Example with `IO`: -- -- >>> mapVariantFirstM @Int print (toVariantAt @0 42 :: V '[Int,Float,Int]) -- 42--- V @() () :: V '[(), Float, Int]+-- () -- -- >>> mapVariantFirstM @Int print (toVariantAt @2 42 :: V '[Int,Float,Int])--- V @Int 42 :: V '[(), Float, Int]+-- 42 -- mapVariantFirstM :: forall a b n l m.    ( Member a l@@ -703,11 +730,11 @@    mapVariant' :: (a -> b) -> V cs -> V (ReplaceNS is b cs)  instance MapVariantIndexes a b '[] is where-   {-# INLINE mapVariant' #-}+   {-# INLINABLE mapVariant' #-}    mapVariant' = undefined  instance MapVariantIndexes a b cs '[] where-   {-# INLINE mapVariant' #-}+   {-# INLINABLE mapVariant' #-}    mapVariant' _ v = v  instance forall a b cs is i.@@ -715,7 +742,7 @@    , a ~ Index i cs    , KnownNat i    ) => MapVariantIndexes a b cs (i ': is) where-   {-# INLINE mapVariant' #-}+   {-# INLINABLE mapVariant' #-}    mapVariant' f v = mapVariant' @a @b @(ReplaceN i b cs) @is f (mapVariantAt @i f v)  type MapVariant a b cs =@@ -729,10 +756,10 @@ -- -- >>> let add1 = mapVariant @Int (+1) -- >>> add1 (toVariantAt @0 10 :: V '[Int,Float,Int,Double])--- V @Int 11 :: V '[Int, Float, Int, Double]+-- 11 -- -- >>> add1 (toVariantAt @2 10 :: V '[Int,Float,Int, Double])--- V @Int 11 :: V '[Int, Float, Int, Double]+-- 11 -- mapVariant :: forall a b cs.    ( MapVariant a b cs@@ -744,10 +771,10 @@ -- -- >>> let add1 = mapNubVariant @Int (+1) -- >>> add1 (toVariantAt @0 10 :: V '[Int,Float,Int,Double])--- V @Int 11 :: V '[Int, Float, Double]+-- 11 -- -- >>> add1 (toVariantAt @2 10 :: V '[Int,Float,Int, Double])--- V @Int 11 :: V '[Int, Float, Double]+-- 11 -- mapNubVariant :: forall a b cs ds rs.    ( MapVariant a b cs@@ -765,10 +792,10 @@ -- >>> newtype Even = Even Int deriving (Show) -- >>> let f x = if even x then V (Even x) else V (Odd x) :: V '[Odd, Even] -- >>> foldMapVariantAt @1 f (V @Int 10 :: V '[Float,Int,Double])--- V @Even (Even 10) :: V '[Float, Odd, Even, Double]+-- Even 10 -- -- >>> foldMapVariantAt @1 f (V @Float 0.5 :: V '[Float,Int,Double])--- V @Float 0.5 :: V '[Float, Odd, Even, Double]+-- 0.5 -- foldMapVariantAt :: forall (n :: Nat) l l2 .    ( KnownNat n@@ -837,10 +864,10 @@ -- >>> newtype Even = Even Int deriving (Show) -- >>> let f x = if even x then V (Even x) else V (Odd x) :: V '[Odd, Even] -- >>> foldMapVariant @Int f (V @Int 10 :: V '[Float,Int,Double])--- V @Even (Even 10) :: V '[Float, Odd, Even, Double]+-- Even 10 -- -- >>> foldMapVariant @Int f (V @Float 0.5 :: V '[Float,Int,Double])--- V @Float 0.5 :: V '[Float, Odd, Even, Double]+-- 0.5 -- foldMapVariant :: forall a cs ds i.    ( i ~ IndexOf a cs@@ -870,7 +897,7 @@    alterVariant' :: (forall a. c a => a -> a) -> Word -> Any -> Any  instance AlterVariant c '[] where-   {-# INLINE alterVariant' #-}+   {-# INLINABLE alterVariant' #-}    alterVariant' _ = undefined  instance@@ -878,7 +905,7 @@    , c x    ) => AlterVariant c (x ': xs)    where-      {-# INLINE alterVariant' #-}+      {-# INLINABLE alterVariant' #-}       alterVariant' f t v =          case t of             0 -> unsafeCoerce (f (unsafeCoerce v :: x))@@ -911,7 +938,7 @@    traverseVariant' :: (forall a . (Monad m, c a) => a -> m a) -> Word -> Any -> m Any  instance TraverseVariant c '[] m where-   {-# INLINE traverseVariant' #-}+   {-# INLINABLE traverseVariant' #-}    traverseVariant' _ = undefined  instance@@ -920,7 +947,7 @@    , Monad m    ) => TraverseVariant c (x ': xs) m    where-      {-# INLINE traverseVariant' #-}+      {-# INLINABLE traverseVariant' #-}       traverseVariant' f t v =          case t of             0 -> unsafeCoerce <$> f (unsafeCoerce v :: x)@@ -951,37 +978,42 @@   -class ReduceVariant c r (b :: [*]) where+class ReduceVariant c (b :: [*]) where    reduceVariant' :: (forall a. c a => a -> r) -> Word -> Any -> r -instance ReduceVariant c r '[] where-   {-# INLINE reduceVariant' #-}+instance ReduceVariant c '[] where+   {-# INLINABLE reduceVariant' #-}    reduceVariant' _ = undefined  instance-   ( ReduceVariant c r xs+   ( ReduceVariant c xs    , c x-   ) => ReduceVariant c r (x ': xs)+   ) => ReduceVariant c (x ': xs)    where-      {-# INLINE reduceVariant' #-}+      {-# INLINABLE reduceVariant' #-}       reduceVariant' f t v =          case t of             0 -> f (unsafeCoerce v :: x)-            n -> reduceVariant' @c @r @xs f (n-1) v+            n -> reduceVariant' @c @xs f (n-1) v  -- | Reduce a variant to a single value by using a class function. You need to -- specify the constraints required by the modifying function. ----- Usage:---    reduceVariant @Show show v+-- >>> let v = V "Yes" :: V '[String,Bool,Char]+-- >>> reduceVariant @Show show v+-- "\"Yes\"" ---reduceVariant :: forall c r (a :: [*]).-   ( ReduceVariant c r a-   ) => (forall x. c x => x -> r) -> V a  -> r+-- >>> let n = V (10 :: Int) :: V '[Int,Word,Integer]+-- >>> reduceVariant @Integral fromIntegral n :: Int+-- 10+reduceVariant :: forall c (a :: [*]) r.+   ( ReduceVariant c a+   ) => (forall x. c x => x -> r) -> V a -> r {-# INLINABLE reduceVariant #-}-reduceVariant f (Variant t a) = reduceVariant' @c @r @a f t a+reduceVariant f (Variant t a) = reduceVariant' @c @a f t a  + ----------------------------------------------------------- -- Conversions between variants -----------------------------------------------------------@@ -1011,7 +1043,7 @@    liftVariant' :: V xs -> V ys  instance LiftVariant' '[] ys where-   {-# INLINE liftVariant' #-}+   {-# INLINABLE liftVariant' #-}    liftVariant' _ = undefined  instance forall xs ys x.@@ -1019,7 +1051,7 @@       , KnownNat (IndexOf x ys)       ) => LiftVariant' (x ': xs) ys    where-      {-# INLINE liftVariant' #-}+      {-# INLINABLE liftVariant' #-}       liftVariant' (Variant t a)          | t == 0    = Variant (natValue' @(IndexOf x ys)) a          | otherwise = liftVariant' @xs (Variant (t-1) a)@@ -1056,7 +1088,7 @@    toFlattenVariant :: Word -> a -> rs  instance Flattenable (V '[]) rs where-   {-# INLINE toFlattenVariant #-}+   {-# INLINABLE toFlattenVariant #-}    toFlattenVariant _ _ = undefined  instance forall xs ys rs.@@ -1064,7 +1096,7 @@    , KnownNat (Length xs)    ) => Flattenable (V (V xs ': ys)) (V rs)    where-   {-# INLINE toFlattenVariant #-}+   {-# INLINABLE toFlattenVariant #-}    toFlattenVariant i v = case popVariantHead v of       Right (Variant n a) -> Variant (i+n) a       Left vys            -> toFlattenVariant (i+natValue @(Length xs)) vys@@ -1090,7 +1122,7 @@    joinVariant :: V xs -> m (V (ExtractM m xs))  instance JoinVariant m '[] where-   {-# INLINE joinVariant #-}+   {-# INLINABLE joinVariant #-}    joinVariant _ = undefined  instance forall m xs a.@@ -1098,7 +1130,7 @@    , ExtractM m (m a ': xs) ~ (a ': ExtractM m xs)    , JoinVariant m xs    ) => JoinVariant m (m a ': xs) where-   {-# INLINE joinVariant #-}+   {-# INLINABLE joinVariant #-}    joinVariant (Variant 0 a) = (Variant 0 . unsafeCoerce) <$> (unsafeCoerce a :: m a)    joinVariant (Variant n a) = prependVariant @'[a] <$> joinVariant (Variant (n-1) a :: V xs) @@ -1116,11 +1148,11 @@   instance NFData (V '[]) where-   {-# INLINE rnf #-}+   {-# INLINABLE rnf #-}    rnf _ = ()  instance (NFData x, NFData (V xs)) => NFData (V (x ': xs)) where-   {-# INLINE rnf #-}+   {-# INLINABLE rnf #-}    rnf v = case popVariantHead v of       Right x -> rnf x       Left xs -> rnf xs@@ -1174,9 +1206,10 @@ -- | Get variant possible values in a tuple of Maybe types variantToTuple :: forall l t.    ( VariantToHList l-   , HTuple' (Map Maybe l) t+   , HTuple (Map Maybe l)+   , t ~ Tuple (Map Maybe l)    ) => V l -> t-variantToTuple = hToTuple' . variantToHList+variantToTuple = hToTuple . variantToHList   instance ContVariant xs => MultiCont (V xs) where@@ -1198,58 +1231,58 @@    contToVariantM :: Monad m => ContFlow xs (m (V xs)) -> m (V xs)  instance ContVariant '[a] where-   {-# INLINE variantToCont #-}-   variantToCont (Variant _ a) = ContFlow $ \(Single f) ->+   {-# INLINABLE variantToCont #-}+   variantToCont (Variant _ a) = ContFlow $ \(Unit f) ->       f (unsafeCoerce a) -   {-# INLINE variantToContM #-}-   variantToContM act = ContFlow $ \(Single f) -> do+   {-# INLINABLE variantToContM #-}+   variantToContM act = ContFlow $ \(Unit f) -> do       Variant _ a <- act       f (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>-      Single (toVariantAt @0)+      Unit (toVariantAt @0) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>-      Single (return . toVariantAt @0)+      Unit (return . toVariantAt @0)  instance ContVariant '[a,b] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2) ->       case t of          0 -> f1 (unsafeCoerce a)          _ -> f2 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2) -> do       Variant t a <- act       case t of          0 -> f1 (unsafeCoerce a)          _ -> f2 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1       )  instance ContVariant '[a,b,c] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3) ->       case t of          0 -> f1 (unsafeCoerce a)          1 -> f2 (unsafeCoerce a)          _ -> f3 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3) -> do       Variant t a <- act       case t of@@ -1257,14 +1290,14 @@          1 -> f2 (unsafeCoerce a)          _ -> f3 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1       , toVariantAt @2       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1272,7 +1305,7 @@       )  instance ContVariant '[a,b,c,d] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4) ->       case t of          0 -> f1 (unsafeCoerce a)@@ -1280,7 +1313,7 @@          2 -> f3 (unsafeCoerce a)          _ -> f4 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4) -> do       Variant t a <- act       case t of@@ -1289,7 +1322,7 @@          2 -> f3 (unsafeCoerce a)          _ -> f4 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1297,7 +1330,7 @@       , toVariantAt @3       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1306,7 +1339,7 @@       )  instance ContVariant '[a,b,c,d,e] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5) ->       case t of          0 -> f1 (unsafeCoerce a)@@ -1315,7 +1348,7 @@          3 -> f4 (unsafeCoerce a)          _ -> f5 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5) -> do       Variant t a <- act       case t of@@ -1325,7 +1358,7 @@          3 -> f4 (unsafeCoerce a)          _ -> f5 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1334,7 +1367,7 @@       , toVariantAt @4       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1344,7 +1377,7 @@       )  instance ContVariant '[a,b,c,d,e,f] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6) ->       case t of          0 -> f1 (unsafeCoerce a)@@ -1354,7 +1387,7 @@          4 -> f5 (unsafeCoerce a)          _ -> f6 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6) -> do       Variant t a <- act       case t of@@ -1365,7 +1398,7 @@          4 -> f5 (unsafeCoerce a)          _ -> f6 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1375,7 +1408,7 @@       , toVariantAt @5       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1386,7 +1419,7 @@       )  instance ContVariant '[a,b,c,d,e,f,g] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7) ->       case t of          0 -> f1 (unsafeCoerce a)@@ -1397,7 +1430,7 @@          5 -> f6 (unsafeCoerce a)          _ -> f7 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7) -> do       Variant t a <- act       case t of@@ -1409,7 +1442,7 @@          5 -> f6 (unsafeCoerce a)          _ -> f7 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1420,7 +1453,7 @@       , toVariantAt @6       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1432,7 +1465,7 @@       )  instance ContVariant '[a,b,c,d,e,f,g,h] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8) ->       case t of          0 -> f1 (unsafeCoerce a)@@ -1444,7 +1477,7 @@          6 -> f7 (unsafeCoerce a)          _ -> f8 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8) -> do       Variant t a <- act       case t of@@ -1457,7 +1490,7 @@          6 -> f7 (unsafeCoerce a)          _ -> f8 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1469,7 +1502,7 @@       , toVariantAt @7       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1482,7 +1515,7 @@       )  instance ContVariant '[a,b,c,d,e,f,g,h,i] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9) ->       case t of          0 -> f1 (unsafeCoerce a)@@ -1495,7 +1528,7 @@          7 -> f8 (unsafeCoerce a)          _ -> f9 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9) -> do       Variant t a <- act       case t of@@ -1509,7 +1542,7 @@          7 -> f8 (unsafeCoerce a)          _ -> f9 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1522,7 +1555,7 @@       , toVariantAt @8       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1536,7 +1569,7 @@       )  instance ContVariant '[a,b,c,d,e,f,g,h,i,j] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) ->       case t of          0 -> f1  (unsafeCoerce a)@@ -1550,7 +1583,7 @@          8 -> f9  (unsafeCoerce a)          _ -> f10 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) -> do       Variant t a <- act       case t of@@ -1565,7 +1598,7 @@          8 -> f9  (unsafeCoerce a)          _ -> f10 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1579,7 +1612,7 @@       , toVariantAt @9       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1594,7 +1627,7 @@       )  instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) ->       case t of          0 -> f1  (unsafeCoerce a)@@ -1609,7 +1642,7 @@          9 -> f10 (unsafeCoerce a)          _ -> f11 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) -> do       Variant t a <- act       case t of@@ -1625,7 +1658,7 @@          9 -> f10 (unsafeCoerce a)          _ -> f11 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1640,7 +1673,7 @@       , toVariantAt @10       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1@@ -1656,7 +1689,7 @@       )  instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k,l] where-   {-# INLINE variantToCont #-}+   {-# INLINABLE variantToCont #-}    variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) ->       case t of          0  -> f1  (unsafeCoerce a)@@ -1672,7 +1705,7 @@          10 -> f11 (unsafeCoerce a)          _  -> f12 (unsafeCoerce a) -   {-# INLINE variantToContM #-}+   {-# INLINABLE variantToContM #-}    variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) -> do       Variant t a <- act       case t of@@ -1689,7 +1722,7 @@          10 -> f11 (unsafeCoerce a)          _  -> f12 (unsafeCoerce a) -   {-# INLINE contToVariant #-}+   {-# INLINABLE contToVariant #-}    contToVariant c = c >::>       ( toVariantAt @0       , toVariantAt @1@@ -1705,7 +1738,7 @@       , toVariantAt @11       ) -   {-# INLINE contToVariantM #-}+   {-# INLINABLE contToVariantM #-}    contToVariantM c = c >::>       ( return . toVariantAt @0       , return . toVariantAt @1

@@ -1,99 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ImplicitParams #-}---- | Continuation based control-flow-module Haskus.Utils.Variant.Cont-   ( fret-   , fretN-   , freturn-   , freturnN-   , frec-   -- * Control-flow-   , fIf-   , Then (..)-   , Else (..)-   )-where--import Haskus.Utils.Tuple-import Haskus.Utils.Types-import Haskus.Utils.ContFlow---- this define has to be defined in each module using ContFlow for now-#define fdo ContFlow $ \__cs -> let ?__cs = __cs in do---- | Call the type-indexed continuation from the tuple passed as first parameter-fret :: forall x r t n xs.-   ( ExtractTuple n t (x -> r)-   , xs ~ ContTupleToList t r-   , CheckMember x xs-   , n ~ IndexOf x xs-   , KnownNat n-   , CheckNub xs-   ) => t -> (x -> r)-{-# INLINE fret #-}-fret = tupleN @n @t @(x -> r)---- | Implicitly call the type-indexed continuation in the context-freturn :: forall x r t n xs.-   ( ExtractTuple n t (x -> r)-   , xs ~ ContTupleToList t r-   , CheckMember x xs-   , n ~ IndexOf x xs-   , KnownNat n-   , CheckNub xs-   , ?__cs :: t-   ) => x -> r-{-# INLINE freturn #-}-freturn = fret ?__cs---- | Call the indexed continuation from the tuple passed as first parameter-fretN :: forall n x r t xs.-   ( ExtractTuple n t (x -> r)-   , xs ~ ContTupleToList t r-   , x ~ Index n xs-   , KnownNat n-   ) => t -> (x -> r)-{-# INLINE fretN #-}-fretN = tupleN @n @t @(x -> r)----- | Implicitly call the type-indexed continuation in the context-freturnN :: forall n x r t xs.-   ( ExtractTuple n t (x -> r)-   , xs ~ ContTupleToList t r-   , x ~ Index n xs-   , KnownNat n-   , ?__cs :: t-   ) => x -> r-{-# INLINE freturnN #-}-freturnN = fretN @n ?__cs----- | Recursive call-frec :: forall r xs.-   ( ?__cs :: ContListToTuple xs r-   ) => ContFlow xs r -> r-frec f = f >::> ?__cs---------------------------------------------- Control-flow--data Then = Then-data Else = Else--fIf :: Bool -> ContFlow '[Then,Else] r-{-# INLINE fIf #-}-fIf b = fdo-   case b of-      True  -> freturn Then-      False -> freturn Else

@@ -0,0 +1,401 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}++module Haskus.Utils.Variant.Excepts+   ( Excepts+   , runE+   , runE_+   , liftE+   , appendE+   , prependE+   , failureE+   , successE+   , throwE+   , catchE+   , catchEvalE+   , evalE+   , onE_+   , onE+   , finallyE+   , injectExcepts+   , withExcepts+   , withExcepts_+   , mapExcepts+   , variantToExcepts+   , veitherToExcepts+   , catchLiftBoth+   , catchLiftLeft+   , catchLiftRight+   , catchAllE+   , catchDieE+   , catchRemove+   , sequenceE+   , runBothE+   -- * Reexport+   , module Haskus.Utils.Variant.VEither+   )+where++import Haskus.Utils.Monad+import Haskus.Utils.Types+import Haskus.Utils.Variant.VEither++import Control.Monad.Catch+#if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0)+import qualified Control.Monad.Fail+import           Control.Monad.Fail ( MonadFail )+#endif++newtype Excepts es m a = Excepts (m (VEither es a))++deriving instance Show (m (VEither es a)) => Show (Excepts es m a)++-- | Run an Excepts+runE :: forall es a m.+   Excepts es m a -> m (VEither es a)+{-# INLINABLE runE #-}+runE (Excepts m) = m++-- | Run an Excepts, discard the result value+runE_ :: forall es a m.+   Functor m => Excepts es m a -> m ()+{-# INLINABLE runE_ #-}+runE_ m = void (runE m)++injectExcepts :: forall es a m.+   Monad m => Excepts es m a -> Excepts es m (VEither es a)+{-# INLINABLE injectExcepts #-}+injectExcepts (Excepts m) = lift m++withExcepts_ :: Monad m => (VEither es a -> m ()) -> Excepts es m a -> Excepts es m a+{-# INLINABLE withExcepts_ #-}+withExcepts_ f (Excepts m) = Excepts $ do+   v <- m+   f v+   return v++withExcepts :: Monad m => (VEither es a -> m b) -> Excepts es m a -> Excepts es m b+{-# INLINABLE withExcepts #-}+withExcepts f (Excepts m) = Excepts $ do+   v <- m+   VRight <$> f v++-- | Convert a flow without error into a value+evalE :: Monad m => Excepts '[] m a -> m a+{-# INLINABLE evalE #-}+evalE v = veitherToValue <$> runE v++mapExcepts :: (m (VEither es a) -> n (VEither es' b)) -> Excepts es m a -> Excepts es' n b+{-# INLINABLE mapExcepts #-}+mapExcepts f = Excepts . f . runE++-- | Lift a Excepts into another+liftE :: forall es' es a m.+   ( Monad m+   , VEitherLift es es'+   ) => Excepts es m a -> Excepts es' m a+{-# INLINABLE liftE #-}+liftE = mapExcepts (liftM veitherLift)++-- | Append errors to an Excepts+appendE :: forall ns es a m.+   ( Monad m+   ) => Excepts es m a -> Excepts (Concat es ns) m a+{-# INLINABLE appendE #-}+appendE = mapExcepts (liftM (veitherAppend @ns))++-- | Prepend errors to an Excepts+prependE :: forall ns es a m.+   ( Monad m+   , KnownNat (Length ns)+   ) => Excepts es m a -> Excepts (Concat ns es) m a+{-# INLINABLE prependE #-}+prependE = mapExcepts (liftM (veitherPrepend @ns))++instance Functor m => Functor (Excepts es m) where+   {-# INLINABLE fmap #-}+   fmap f = mapExcepts (fmap (fmap f))++instance Foldable m => Foldable (Excepts es m) where+   {-# INLINABLE foldMap #-}+   foldMap f (Excepts m) = foldMap (veitherCont (const mempty) f) m++instance Traversable m => Traversable (Excepts es m) where+   {-# INLINABLE traverse #-}+   traverse f (Excepts m) =+      Excepts <$> traverse (veitherCont (pure . VLeft) (fmap VRight . f)) m++instance (Functor m, Monad m) => Applicative (Excepts es m) where+    {-# INLINABLE pure #-}+    pure a = Excepts $ return (VRight a)++    {-# INLINABLE (<*>) #-}+    Excepts mf <*> Excepts ma = Excepts $ do+      f <- mf+      a <- ma+      pure (f <*> a)++    {-# INLINABLE (*>) #-}+    m *> k = m >>= \_ -> k++instance (Monad m) => Monad (Excepts es m) where+    {-# INLINABLE (>>=) #-}+    m >>= k = Excepts $ do+        a <- runE m+        case a of+            VLeft es -> return (VLeft es)+            VRight x -> runE (k x)++#if MIN_VERSION_base(4,12,0)+instance (MonadFail m) => MonadFail (Excepts es m) where+#endif+   {-# INLINABLE fail #-}+   fail = Excepts . fail++instance MonadTrans (Excepts e) where+    {-# INLINABLE lift #-}+    lift = Excepts . liftM VRight++instance (MonadIO m) => MonadIO (Excepts es m) where+    {-# INLINABLE liftIO #-}+    liftIO = lift . liftIO+++-- | Throws exceptions into the base monad.+instance MonadThrow m => MonadThrow (Excepts e m) where+   {-# INLINABLE throwM #-}+   throwM = lift . throwM++-- | Catches exceptions from the base monad.+instance MonadCatch m => MonadCatch (Excepts e m) where+   catch (Excepts m) f = Excepts $ catch m (runE . f)++instance MonadMask m => MonadMask (Excepts e m) where+   mask f = Excepts $ mask $ \u -> runE $ f (q u)+      where+         q :: (m (VEither e a) -> m (VEither e a)) -> Excepts e m a -> Excepts e m a+         q u (Excepts b) = Excepts (u b)++   uninterruptibleMask f = Excepts $ uninterruptibleMask $ \u -> runE $ f (q u)+      where+         q :: (m (VEither e a) -> m (VEither e a)) -> Excepts e m a -> Excepts e m a+         q u (Excepts b) = Excepts (u b)++   generalBracket acquire release use = Excepts $ do+      (eb, ec) <- generalBracket+         (runE acquire)+         (\eresource exitCase -> case eresource of+            VLeft e -> return (VLeft e) -- nothing to release, acquire didn't succeed+            VRight resource -> case exitCase of+               ExitCaseSuccess (VRight b) -> runE (release resource (ExitCaseSuccess b))+               ExitCaseException e        -> runE (release resource (ExitCaseException e))+               _                          -> runE (release resource ExitCaseAbort))+         (veitherCont (return . VLeft) (runE . use))+      runE $ do+         -- The order in which we perform those two 'Excepts' effects determines+         -- which error will win if they are both erroring. We want the error from+         -- 'release' to win.+         c <- Excepts (return ec)+         b <- Excepts (return eb)+         return (b, c)++++-- | Signal an exception value @e@.+throwE :: forall e es a m. (Monad m, e :< es) => e -> Excepts es m a+{-# INLINABLE throwE #-}+throwE = Excepts . pure . VLeft . V++-- | Signal an exception value @e@.+failureE :: forall e a m. Monad m => e -> Excepts '[e] m a+{-# INLINABLE failureE #-}+failureE = throwE++-- | Signal a success+successE :: forall a m. Monad m => a -> Excepts '[] m a+{-# INLINABLE successE #-}+successE = pure++-- | Handle an exception. Lift both normal and exceptional flows into the result+-- flow+catchE :: forall e es' es'' es a m.+   ( Monad m+   , e :< es+   , LiftVariant (Remove e es) es'+   , LiftVariant es'' es'+   ) => (e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchE #-}+catchE = catchLiftBoth++-- | Handle an exception. Lift both normal and exceptional flows into the result+-- flow+catchLiftBoth :: forall e es' es'' es a m.+   ( Monad m+   , e :< es+   , LiftVariant (Remove e es) es'+   , LiftVariant es'' es'+   ) => (e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchLiftBoth #-}+catchLiftBoth h m = Excepts $ do+   a <- runE m+   case a of+      VRight r -> return (VRight r)+      VLeft  ls -> case popVariant ls of+         Right l -> runE (liftE (h l))+         Left rs -> return (VLeft (liftVariant rs))++-- | Handle an exception. Assume it is in the first position+catchRemove :: forall e es a m.+   ( Monad m+   ) => (e -> Excepts es m a) -> Excepts (e ': es) m a -> Excepts es m a+{-# INLINABLE catchRemove #-}+catchRemove h m = Excepts $ do+   a <- runE m+   case a of+      VRight r -> return (VRight r)+      VLeft  ls -> case popVariantHead ls of+         Right l -> runE (h l)+         Left rs -> return (VLeft rs)++-- | Handle an exception. Lift the remaining errors into the resulting flow+catchLiftLeft :: forall e es es' a m.+   ( Monad m+   , e :< es+   , LiftVariant (Remove e es) es'+   ) => (e -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchLiftLeft #-}+catchLiftLeft h m = Excepts $ do+   a <- runE m+   case a of+      VRight r -> return (VRight r)+      VLeft  ls -> case popVariant ls of+         Right l -> runE (h l)+         Left rs -> return (VLeft (liftVariant rs))++-- | Handle an exception. Lift the handler into the resulting flow+catchLiftRight :: forall e es es' a m.+   ( Monad m+   , e :< es+   , LiftVariant es' (Remove e es)+   ) => (e -> Excepts es' m a) -> Excepts es m a -> Excepts (Remove e es) m a+{-# INLINABLE catchLiftRight #-}+catchLiftRight h m = Excepts $ do+   a <- runE m+   case a of+      VRight r -> return (VRight r)+      VLeft  ls -> case popVariant ls of+         Right l -> runE (liftE (h l))+         Left rs -> return (VLeft rs)++-- | Do something in case of error+catchAllE :: Monad m => (V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchAllE #-}+catchAllE h m = Excepts $ do+   a <- runE m+   case a of+      VRight x  -> return (VRight x)+      VLeft xs  -> runE (h xs)++-- | Evaluate a Excepts. Use the provided function to handle error cases.+catchEvalE :: Monad m => (V es -> m a) -> Excepts es m a -> m a+{-# INLINABLE catchEvalE #-}+catchEvalE h m = do+   a <- runE m+   case a of+      VRight x  -> return x+      VLeft xs  -> h xs++-- | Catch and die in case of error+catchDieE :: (e :< es, Monad m) => (e -> m ()) -> Excepts es m a -> Excepts (Remove e es) m a+{-# INLINABLE catchDieE #-}+catchDieE h m = Excepts $ do+   a <- runE m+   case a of+      VRight r -> return (VRight r)+      VLeft  ls -> case popVariant ls of+         Right l -> h l >> error "catchDieE"+         Left rs -> return (VLeft rs)++-- | Do something in case of error+onE_ :: Monad m => m () -> Excepts es m a -> Excepts es m a+{-# INLINABLE onE_ #-}+onE_ h m = Excepts $ do+   a <- runE m+   case a of+      VRight _ -> return a+      VLeft _  -> h >> return a++-- | Do something in case of error+onE :: Monad m => (V es -> m ()) -> Excepts es m a -> Excepts es m a+{-# INLINABLE onE #-}+onE h m = Excepts $ do+   a <- runE m+   case a of+      VRight _  -> return a+      VLeft es  -> h es >> return a++-- | Finally for Excepts+finallyE :: Monad m => m () -> Excepts es m a -> Excepts es m a+{-# INLINABLE finallyE #-}+finallyE h m = Excepts $ do+   a <- runE m+   h+   return a++-- | Convert a Variant into a Excepts+variantToExcepts :: Monad m => V (a ': es) -> Excepts es m a+{-# INLINABLE variantToExcepts #-}+variantToExcepts v = Excepts (return (veitherFromVariant v))++-- | Convert a VEither into a Excepts+veitherToExcepts :: Monad m => VEither es a -> Excepts es m a+{-# INLINABLE veitherToExcepts #-}+veitherToExcepts v = Excepts (return v)++instance MonadInIO m => MonadInIO (Excepts es m) where+   {-# INLINABLE liftWith #-}+   liftWith wth f =+      Excepts $ liftWith wth (\a -> runE (f a))++   {-# INLINABLE liftWith2 #-}+   liftWith2 wth f =+      Excepts $ liftWith2 wth (\a b -> runE (f a b))++-- | Product of the execution of two Excepts+--+-- You can use a generic monad combinator such as+-- `Control.Concurrent.Async.concurrently` (in "async" package) to get+-- concurrent execution.+--+-- >> concurrentE = runBothE concurrently+runBothE ::+   ( KnownNat (Length (b:e2))+   , Monad m+   ) => (forall x y. m x -> m y -> m (x,y)) -> Excepts e1 m a -> Excepts e2 m b -> Excepts (Tail (Product (a:e1) (b:e2))) m (a,b)+runBothE exec f g = Excepts do+   (v1,v2) <- exec (runE f) (runE g)+   pure (veitherProduct v1 v2)++-- | Product of the sequential execution of two Excepts+sequenceE ::+   ( KnownNat (Length (b:e2))+   , Monad m+   ) => Excepts e1 m a -> Excepts e2 m b -> Excepts (Tail (Product (a:e1) (b:e2))) m (a,b)+sequenceE = runBothE exec+   where+      exec f g = do+         v1 <- f+         v2 <- g+         pure (v1,v2)

@@ -1,346 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Haskus.Utils.Variant.Flow-   ( Flow-   , runFlow-   -- * FlowT-   , FlowT-   , runFlowT-   , runFlowT_-   , evalFlowT-   , evalCatchFlowT-   , injectFlowT-   , mapFlowT-   , liftFlowT-   , variantToFlowT-   , success-   , failure-   , throwE-   , catchE-   , catchLiftBoth-   , catchLiftLeft-   , catchLiftRight-   , catchAllE-   , catchDie-   , catchDieAll-   , catchRemove-   , onFlowError_-   , onFlowError-   , finallyFlow-   -- * Reexport-   , module Haskus.Utils.Variant-   )-where--import Haskus.Utils.Monad-import Haskus.Utils.Variant-import Data.Functor.Identity--import Control.Monad.Catch----------------------------------------------------------------------------------- Flow--------------------------------------------------------------------------------type Flow es     = FlowT es Identity--runFlow :: Flow es a -> V (a ': es)-{-# INLINABLE runFlow #-}-runFlow (FlowT m) = runIdentity m----------------------------------------------------------------------------------- FlowT--------------------------------------------------------------------------------newtype FlowT es m a = FlowT (m (V (a ': es)))--deriving instance Show (m (V (a ': es))) => Show (FlowT es m a)--runFlowT :: FlowT es m a -> m (V (a ': es))-{-# INLINABLE runFlowT #-}-runFlowT (FlowT m) = m--runFlowT_ :: Functor m => FlowT es m a -> m ()-{-# INLINABLE runFlowT_ #-}-runFlowT_ m = void (runFlowT m)--injectFlowT :: Monad m => FlowT es m a -> FlowT es m (V (a ': es))-{-# INLINABLE injectFlowT #-}-injectFlowT (FlowT m) = return =<< lift m---- | Convert a flow without error into a value-evalFlowT :: Monad m => FlowT '[] m a -> m a-{-# INLINABLE evalFlowT #-}-evalFlowT v = variantToValue <$> runFlowT v--mapFlowT :: (m (V (a ': es)) -> n (V (b ': es'))) -> FlowT es m a -> FlowT es' n b-{-# INLINABLE mapFlowT #-}-mapFlowT f m = FlowT $ f (runFlowT m)---- | Lift a FlowT into another-liftFlowT :: (Monad m, LiftVariant es es') => FlowT es m a -> FlowT es' m a-{-# INLINABLE liftFlowT #-}-liftFlowT (FlowT m) = FlowT $ do-   a <- m-   return (mapVariantHeadTail id liftVariant a)--instance Functor m => Functor (FlowT es m) where-   {-# INLINABLE fmap #-}-   fmap f = FlowT . fmap (mapVariantHeadTail f id) . runFlowT--instance Foldable m => Foldable (FlowT es m) where-   {-# INLINABLE foldMap #-}-   foldMap f (FlowT m) = foldMap (variantHeadTail f (const mempty)) m--instance Traversable m => Traversable (FlowT es m) where-   {-# INLINABLE traverse #-}-   traverse f (FlowT m) =-      FlowT <$> traverse (variantHeadTail (fmap toVariantHead . f) (pure . toVariantTail)) m--instance (Functor m, Monad m) => Applicative (FlowT es m) where-    {-# INLINABLE pure #-}-    pure a = FlowT $ return (toVariantHead a)--    {-# INLINABLE (<*>) #-}-    FlowT f <*> FlowT v = FlowT $ do-        mf <- f-        case popVariantHead mf of-            Left es -> return (toVariantTail es)-            Right k -> do-                mv <- v-                case popVariantHead mv of-                    Left es -> return (toVariantTail es)-                    Right x -> return (toVariantHead (k x))--    {-# INLINABLE (*>) #-}-    m *> k = m >>= \_ -> k--instance (Monad m) => Monad (FlowT es m) where-    {-# INLINABLE (>>=) #-}-    m >>= k = FlowT $ do-        a <- runFlowT m-        case popVariantHead a of-            Left es -> return (toVariantTail es)-            Right x -> runFlowT (k x)--    {-# INLINABLE fail #-}-    fail = FlowT . fail--instance MonadTrans (FlowT e) where-    {-# INLINABLE lift #-}-    lift = FlowT . liftM toVariantHead--instance (MonadIO m) => MonadIO (FlowT es m) where-    {-# INLINABLE liftIO #-}-    liftIO = lift . liftIO----- | Throws exceptions into the base monad.-instance MonadThrow m => MonadThrow (FlowT e m) where-   {-# INLINABLE throwM #-}-   throwM = lift . throwM---- | Catches exceptions from the base monad.-instance MonadCatch m => MonadCatch (FlowT e m) where-   catch (FlowT m) f = FlowT $ catch m (runFlowT . f)--instance MonadMask m => MonadMask (FlowT e m) where-   mask f = FlowT $ mask $ \u -> runFlowT $ f (q u)-      where-         q :: (m (V (a ': e)) -> m (V (a ': e))) -> FlowT e m a -> FlowT e m a-         q u (FlowT b) = FlowT (u b)--   uninterruptibleMask f = FlowT $ uninterruptibleMask $ \u -> runFlowT $ f (q u)-      where-         q :: (m (V (a ': e)) -> m (V (a ': e))) -> FlowT e m a -> FlowT e m a-         q u (FlowT b) = FlowT (u b)--   generalBracket acquire release use = FlowT $ do-      (eb, ec) <- generalBracket-         (runFlowT acquire)-         (\eresource exitCase -> case popVariantHead eresource of-            Left e -> return (toVariantTail e) -- nothing to release, acquire didn't succeed-            Right resource -> case exitCase of-               ExitCaseSuccess v-                  | Just b <- fromVariantAt @0 v -> runFlowT (release resource (ExitCaseSuccess b))-               ExitCaseException e               -> runFlowT (release resource (ExitCaseException e))-               _                                 -> runFlowT (release resource ExitCaseAbort))-         (variantHeadTail (runFlowT . use) (return . toVariantTail))-      return $ runFlow $ do-         -- The order in which we perform those two 'FlowT' effects determines-         -- which error will win if they are both erroring. We want the error from-         -- 'release' to win.-         c <- FlowT (return ec)-         b <- FlowT (return eb)-         return (b, c)------ | Success value-success :: Monad m => a -> FlowT '[] m a-success = pure---- | Signal an exception value @e@.-throwE :: (Monad m, e :< es) => e -> FlowT es m a-{-# INLINABLE throwE #-}-throwE = FlowT . return . toVariantTail . V---- | Signal an exception value @e@.-failure :: Monad m => e -> FlowT '[e] m a-{-# INLINABLE failure #-}-failure = throwE---- | Handle an exception. Lift both normal and exceptional flows into the result--- flow-catchE :: forall e es' es'' es a m.-   ( Monad m-   , e :< es-   , LiftVariant (Remove e es) es'-   , LiftVariant es'' es'-   ) =>-    FlowT es m a -> (e -> FlowT es'' m a) -> FlowT es' m a-{-# INLINABLE catchE #-}-m `catchE` h = m `catchLiftBoth` h---- | Handle an exception. Lift both normal and exceptional flows into the result--- flow-catchLiftBoth :: forall e es' es'' es a m.-   ( Monad m-   , e :< es-   , LiftVariant (Remove e es) es'-   , LiftVariant es'' es'-   ) =>-    FlowT es m a -> (e -> FlowT es'' m a) -> FlowT es' m a-{-# INLINABLE catchLiftBoth #-}-m `catchLiftBoth` h = FlowT $ do-   a <- runFlowT m-   case popVariantHead a of-      Right r -> return (toVariantHead r)-      Left  ls -> case popVariant ls of-         Right l -> runFlowT (liftFlowT (h l))-         Left rs -> return (toVariantTail (liftVariant rs))---- | Handle an exception. Assume it is in the first position-catchRemove :: forall e es a m.-   ( Monad m-   ) =>-    FlowT (e ': es) m a -> (e -> FlowT es m a) -> FlowT es m a-{-# INLINABLE catchRemove #-}-m `catchRemove` h = FlowT $ do-   a <- runFlowT m-   case popVariantHead a of-      Right r -> return (toVariantHead r)-      Left  ls -> case popVariantHead ls of-         Right l -> runFlowT (h l)-         Left rs -> return (toVariantTail rs)---- | Handle an exception. Lift the remaining errors into the resulting flow-catchLiftLeft :: forall e es es' a m.-   ( Monad m-   , e :< es-   , LiftVariant (Remove e es) es'-   ) =>-    FlowT es m a -> (e -> FlowT es' m a) -> FlowT es' m a-{-# INLINABLE catchLiftLeft #-}-m `catchLiftLeft` h = FlowT $ do-   a <- runFlowT m-   case popVariantHead a of-      Right r -> return (toVariantHead r)-      Left  ls -> case popVariant ls of-         Right l -> runFlowT (h l)-         Left rs -> return (toVariantTail (liftVariant rs))---- | Handle an exception. Lift the handler into the resulting flow-catchLiftRight :: forall e es es' a m.-   ( Monad m-   , e :< es-   , LiftVariant es' (Remove e es)-   ) =>-    FlowT es m a -> (e -> FlowT es' m a) -> FlowT (Remove e es) m a-{-# INLINABLE catchLiftRight #-}-m `catchLiftRight` h = FlowT $ do-   a <- runFlowT m-   case popVariantHead a of-      Right r -> return (toVariantHead r)-      Left  ls -> case popVariant ls of-         Right l -> runFlowT (liftFlowT (h l))-         Left rs -> return (toVariantTail rs)---- | Do something in case of error-catchAllE :: Monad m => FlowT es m a -> (V es -> FlowT es' m a) -> FlowT es' m a-{-# INLINABLE catchAllE #-}-m `catchAllE` h = FlowT $ do-   a <- runFlowT m-   case popVariantAt @0 a of-      Right x  -> return (toVariantHead x)-      Left xs  -> runFlowT (h xs)---- | Evaluate a FlowT. Use the provided function to handle error cases.-evalCatchFlowT :: Monad m => (V es -> m a) -> FlowT es m a -> m a-{-# INLINABLE evalCatchFlowT #-}-evalCatchFlowT h m = do-   a <- runFlowT m-   case popVariantAt @0 a of-      Right x  -> return x-      Left xs  -> h xs---- | Evaluate a FlowT. Use the provided function to handle error cases.-catchDieAll :: Monad m => FlowT es m a -> (V es -> m a) -> m a-{-# INLINABLE catchDieAll #-}-catchDieAll m h = evalCatchFlowT h m---- | Catch and die in case of error-catchDie :: (e :< es, Monad m) => FlowT es m a -> (e -> m ()) -> FlowT (Remove e es) m a-{-# INLINABLE catchDie #-}-m `catchDie` h = FlowT $ do-   a <- runFlowT m-   case popVariantHead a of-      Right r -> return (toVariantHead r)-      Left  ls -> case popVariant ls of-         Right l -> h l >> error "catchDie"-         Left rs -> return (toVariantTail rs)---- | Do something in case of error-onFlowError_ :: Monad m => FlowT es m a -> m () -> FlowT es m a-{-# INLINABLE onFlowError_ #-}-m `onFlowError_` h = FlowT $ do-   a <- runFlowT m-   case fromVariantHead a of-      Just _  -> return a-      Nothing -> h >> return a---- | Do something in case of error-onFlowError :: Monad m => FlowT es m a -> (V es -> m ()) -> FlowT es m a-{-# INLINABLE onFlowError #-}-m `onFlowError` h = FlowT $ do-   a <- runFlowT m-   case popVariantHead a of-      Right _  -> return a-      Left es  -> h es >> return a---- | Finally for FlowT-finallyFlow :: Monad m => FlowT es m a -> m () -> FlowT es m a-{-# INLINABLE finallyFlow #-}-m `finallyFlow` h = FlowT $ do-   a <- runFlowT m-   h-   return a---- | Convert a Variant into a FlowT-variantToFlowT :: Monad m => V (a ': es) -> FlowT es m a-variantToFlowT v = FlowT (return v)--instance MonadInIO m => MonadInIO (FlowT es m) where-   {-# INLINABLE liftWith #-}-   liftWith wth f =-      FlowT $ liftWith wth (\a -> runFlowT (f a))--   {-# INLINABLE liftWith2 #-}-   liftWith2 wth f =-      FlowT $ liftWith2 wth (\a b -> runFlowT (f a b))

@@ -1,1984 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleInstances #-}---- | Variant based control-flow (deprecated)-module Haskus.Utils.Variant.OldFlow-   ( Flow-   , IOV-   -- * Flow utils-   , flowRes-   , flowSingle-   , flowSetN-   , flowSet-   , flowLift-   , flowToCont-   , flowTraverse-   , flowFor-   , flowTraverseFilter-   , flowForFilter-   , LiftVariant-   , (:<)-   , (:<?)-   -- * Functor, applicative equivalents-   , (<$<)-   , (<*<)-   , (<|<)-   -- * Named operators-   , flowMap-   , flowBind-   , flowBind'-   , flowMatch-   , flowMatchFail-   -- * Operation on first element-   , (.~.>)-   , (>.~.>)-   , (.~+>)-   , (>.~+>)-   , (.~^^>)-   , (>.~^^>)-   , (.~^>)-   , (>.~^>)-   , (.~$>)-   , (>.~$>)-   , (.~|>)-   , (>.~|>)-   , (.~=>)-   , (>.~=>)-   , (.~!>)-   , (>.~!>)-   , (.~!!>)-   , (>.~!!>)-   -- ** Pure-   , (.-.>)-   , (>.-.>)-   , (<.-.)-   , (<.-.<)-   -- ** Const-   , (.~~.>)-   , (>.~~.>)-   , (.~~+>)-   , (>.~~+>)-   , (.~~^^>)-   , (>.~~^^>)-   , (.~~^>)-   , (>.~~^>)-   , (.~~$>)-   , (>.~~$>)-   , (.~~|>)-   , (>.~~|>)-   , (.~~=>)-   , (>.~~=>)-   , (.~~!>)-   , (>.~~!>)-   -- * Operation on tail-   , (..~.>)-   , (>..~.>)-   , (..-.>)-   , (>..-.>)-   , (..-..>)-   , (>..-..>)-   , (..~..>)-   , (>..~..>)-   , (..~^^>)-   , (>..~^^>)-   , (..~^>)-   , (>..~^>)-   , (..~=>)-   , (>..~=>)-   , (..~!>)-   , (>..~!>)-   , (..~!!>)-   , (>..~!!>)-   -- * Operation on caught element in tail-   , (..%~^>)-   , (>..%~^>)-   , (..%~^^>)-   , (>..%~^^>)-   , (..%~$>)-   , (>..%~$>)-   , (..%~!!>)-   , (>..%~!!>)-   , (..%~!>)-   , (>..%~!>)-   , (..?~^>)-   , (>..?~^>)-   , (..?~^^>)-   , (>..?~^^>)-   , (..?~$>)-   , (>..?~$>)-   , (..?~!!>)-   , (>..?~!!>)-   , (..?~!>)-   , (>..?~!>)-   -- * Operation on caught element-   , (%~.>)-   , (>%~.>)-   , (%~+>)-   , (>%~+>)-   , (%~^^>)-   , (>%~^^>)-   , (%~^>)-   , (>%~^>)-   , (%~$>)-   , (>%~$>)-   , (%~|>)-   , (>%~|>)-   , (%~=>)-   , (>%~=>)-   , (%~!>)-   , (>%~!>)-   , (%~!!>)-   , (>%~!!>)-   , (?~.>)-   , (>?~.>)-   , (?~+>)-   , (>?~+>)-   , (?~^^>)-   , (>?~^^>)-   , (?~^>)-   , (>?~^>)-   , (?~$>)-   , (>?~$>)-   , (?~|>)-   , (>?~|>)-   , (?~=>)-   , (>?~=>)-   , (?~!>)-   , (>?~!>)-   , (?~!!>)-   , (>?~!!>)-   -- * Operation on every element-   , (-||)-   , (-||>)-   , (>-||>)-   , (~||)-   , (~||>)-   , (>~||>)-   , LiftCont (..)-   , ExtractRHS-   , ReplaceRHS-   , LiftContTuple-   , ContVariant (..)-   -- * Helpers-   , makeFlowOp-   , makeFlowOpM-   , selectTail-   , selectFirst-   , selectType-   , applyConst-   , applyPure-   , applyM-   , applyF-   , combineFirst-   , combineSameTail-   , combineEither-   , combineConcat-   , combineUnion-   , combineLiftUnselected-   , combineLiftBoth-   , combineSingle-   , liftV-   , liftF-   )-where--import Haskus.Utils.Variant-import Haskus.Utils.Types-import Haskus.Utils.ContFlow-import Haskus.Utils.Tuple---- | Control-flow-type Flow m (l :: [*]) = m (V l)--type IOV l = Flow IO l--------------------------------------------------------------- Flow utils--------------------------------------------------------------- | Return in the first element-flowSetN :: forall (n :: Nat) xs m.-   ( Monad m-   , KnownNat n-   ) => Index n xs -> Flow m xs-{-# INLINABLE flowSetN #-}-flowSetN = return . toVariantAt @n---- | Return in the first well-typed element-flowSet :: (x :< xs, Monad m) => x -> Flow m xs-{-# INLINABLE flowSet #-}-flowSet = return . toVariant---- | Return a single element-flowSingle :: Monad m => x -> Flow m '[x]-{-# INLINABLE flowSingle #-}-flowSingle = flowSetN @0---- | Lift a flow into another-flowLift :: (LiftVariant xs ys , Monad m) => Flow m xs -> Flow m ys-{-# INLINABLE flowLift #-}-flowLift = fmap liftVariant---- | Lift a flow into a ContFlow-flowToCont :: (ContVariant xs, Monad m) => Flow m xs -> ContFlow xs (m r)-flowToCont = variantToContM---- | Traverse a list and stop on first error-flowTraverse :: forall m a b xs.-   ( Monad m-   ) => (a -> Flow m (b ': xs)) -> [a] -> Flow m ([b] ': xs)-flowTraverse f = go (flowSetN @0 [])-   where-      go :: Flow m ([b] ': xs) -> [a] -> Flow m ([b] ': xs)-      go rs []     = rs >.-.> reverse-      go rs (a:as) = go rs' as-         where-            -- execute (f a) if previous execution succedded.-            -- prepend the result to the list-            rs' = rs >.~$> \bs -> (f a >.-.> (:bs))---- | Traverse a list and stop on first error-flowFor :: forall m a b xs.-   ( Monad m-   ) => [a] -> (a -> Flow m (b ': xs)) -> Flow m ([b] ': xs)-flowFor = flip flowTraverse---- | Traverse a list and return only valid values-flowTraverseFilter :: forall m a b xs.-   ( Monad m-   ) => (a -> Flow m (b ': xs)) -> [a] -> m [b]-flowTraverseFilter f = go-   where-      go :: [a] -> m [b]-      go []     = return []-      go (a:as) = do-         f a >.~.> (\b -> (b:) <$> go as)-             >..~.> const (go as)---- | Traverse a list and return only valid values-flowForFilter :: forall m a b xs.-   ( Monad m-   ) => [a] -> (a -> Flow m (b ': xs)) -> m [b]-flowForFilter = flip flowTraverseFilter----- | Extract single flow result-flowRes :: Functor m => Flow m '[x] -> m x-{-# INLINABLE flowRes #-}-flowRes = fmap variantToValue----- | Lift an operation on a Variant into an operation on a flow-liftm :: Monad m => (V x -> a -> m b) -> Flow m x -> a -> m b-{-# INLINABLE liftm #-}-liftm op x a = do-   x' <- x-   op x' a--------------------------------------------------------------- Named operators--------------------------------------------------------------- | Map a pure function onto the correct value in the flow-flowMap :: Monad m => Flow m (x ': xs) -> (x -> y) -> Flow m (y ': xs)-{-# INLINABLE flowMap #-}-flowMap = (>.-.>)---- | Bind two flows in a monadish way (error types union)-flowBind :: forall xs ys zs m x.-   ( LiftVariant xs zs-   , LiftVariant ys zs-   , zs ~ Union xs ys-   , Monad m-   ) => Flow m (x ': ys) -> (x -> Flow m xs) -> Flow m zs-{-# INLINABLE flowBind #-}-flowBind = (>.~|>)---- | Bind two flows in a monadic way (constant error types)-flowBind' :: Monad m => Flow m (x ': xs) -> (x -> Flow m (y ': xs)) -> Flow m (y ': xs)-{-# INLINABLE flowBind' #-}-flowBind' = (>.~$>)---- | Match a value in a flow-flowMatch :: forall x xs zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs-{-# INLINABLE flowMatch #-}-flowMatch = (>%~^>)---- | Match a value in a flow and use a non-returning failure in this case-flowMatchFail :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => Flow m xs -> (x -> m ()) -> Flow m (Remove x xs)-{-# INLINABLE flowMatchFail #-}-flowMatchFail = (>%~!!>)--------------------------------------------------------------- First element operations--------------------------------------------------------------- | Extract the first value, set the first value-(.~.>) :: forall m l x a.-   ( Monad m )-   => V (a ': l) -> (a -> m x) -> Flow m (x ': l)-{-# INLINABLE (.~.>) #-}-(.~.>) v f = makeFlowOp selectFirst (applyM f) combineFirst v--infixl 0 .~.>---- | Extract the first value, set the first value-(>.~.>) :: forall m l x a.-   ( Monad m )-   => Flow m (a ': l) -> (a -> m x) -> Flow m (x ': l)-{-# INLINABLE (>.~.>) #-}-(>.~.>) = liftm (.~.>)--infixl 0 >.~.>---- | Extract the first value, concat the result-(.~+>) :: forall (k :: Nat) m l l2 a.-   ( KnownNat k-   , k ~ Length l2-   , Monad m )-   => V (a ': l) -> (a -> Flow m l2) -> Flow m (Concat l2 l)-{-# INLINABLE (.~+>) #-}-(.~+>) v f = makeFlowOp selectFirst (applyF f) combineConcat v--infixl 0 .~+>---- | Extract the first value, concat the results-(>.~+>) :: forall (k :: Nat) m l l2 a.-   ( KnownNat k-   , k ~ Length l2-   , Monad m )-   => Flow m (a ': l) -> (a -> Flow m l2) -> Flow m (Concat l2 l)-{-# INLINABLE (>.~+>) #-}-(>.~+>) = liftm (.~+>)--infixl 0 >.~+>---- | Extract the first value, lift both-(.~^^>) :: forall m a xs ys zs.-   ( Monad m-   , LiftVariant xs zs-   , LiftVariant ys zs-   ) => V (a ': ys) -> (a -> Flow m xs) -> Flow m zs-{-# INLINABLE (.~^^>) #-}-(.~^^>) v f = makeFlowOp selectFirst (applyF f) combineLiftBoth v--infixl 0 .~^^>----- | Extract the first value, lift both-(>.~^^>) :: forall m a xs ys zs.-   ( Monad m-   , LiftVariant xs zs-   , LiftVariant ys zs-   ) => Flow m (a ': ys) -> (a -> Flow m xs) -> Flow m zs-{-# INLINABLE (>.~^^>) #-}-(>.~^^>) = liftm (.~^^>)--infixl 0 >.~^^>---- | Extract the first value, lift unselected-(.~^>) :: forall m a ys zs.-   ( Monad m-   , LiftVariant ys zs-   ) => V (a ': ys) -> (a -> Flow m zs) -> Flow m zs-{-# INLINABLE (.~^>) #-}-(.~^>) v f = makeFlowOp selectFirst (applyF f) combineLiftUnselected v--infixl 0 .~^>---- | Extract the first value, lift unselected-(>.~^>) :: forall m a ys zs.-   ( Monad m-   , LiftVariant ys zs-   ) => Flow m (a ': ys) -> (a -> Flow m zs) -> Flow m zs-{-# INLINABLE (>.~^>) #-}-(>.~^>) = liftm (.~^>)--infixl 0 >.~^>---- | Extract the first value, use the same tail-(.~$>) :: forall m x xs a.-   ( Monad m-   ) => V (a ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)-{-# INLINABLE (.~$>) #-}-(.~$>) v f = makeFlowOp selectFirst (applyF f) combineSameTail v--infixl 0 .~$>---- | Extract the first value, use the same tail-(>.~$>) :: forall m x xs a.-   ( Monad m-   ) => Flow m (a ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)-{-# INLINABLE (>.~$>) #-}-(>.~$>) = liftm (.~$>)--infixl 0 >.~$>---- | Take the first output, union the result-(.~|>) ::-   ( LiftVariant xs zs-   , LiftVariant ys zs-   , zs ~ Union xs ys-   , Monad m-   ) => V (a ': ys) -> (a -> Flow m xs) -> Flow m zs-{-# INLINABLE (.~|>) #-}-(.~|>) v f = makeFlowOp selectFirst (applyF f) combineUnion v--infixl 0 .~|>---- | Take the first output, fusion the result-(>.~|>) ::-   ( LiftVariant xs zs-   , LiftVariant ys zs-   , zs ~ Union xs ys-   , Monad m-   ) => Flow m (a ': ys) -> (a -> Flow m xs) -> Flow m zs-{-# INLINABLE (>.~|>) #-}-(>.~|>) = liftm (.~|>)--infixl 0 >.~|>---- | Extract the first value and perform effect. Passthrough the input value-(.~=>) ::-   ( Monad m-   ) => V (a ': l) -> (a -> m ()) -> Flow m (a ': l)-{-# INLINABLE (.~=>) #-}-(.~=>) v f = case popVariantHead v of-   Right u -> f u >> return v-   Left  _ -> return v--infixl 0 .~=>---- | Extract the first value and perform effect. Passthrough the input value-(>.~=>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (a -> m ()) -> Flow m (a ': l)-{-# INLINABLE (>.~=>) #-}-(>.~=>) = liftm (.~=>)--infixl 0 >.~=>---- | Extract the first value and perform effect.-(.~!>) ::-   ( Monad m-   ) => V (a ': l) -> (a -> m ()) -> m ()-{-# INLINABLE (.~!>) #-}-(.~!>) v f = case popVariantHead v of-   Right u -> f u-   Left  _ -> return ()--infixl 0 .~!>---- | Extract the first value and perform effect.-(>.~!>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (a -> m ()) -> m ()-{-# INLINABLE (>.~!>) #-}-(>.~!>) = liftm (.~!>)--infixl 0 >.~!>---- | Extract the first value and perform effect.-(.~!!>) ::-   ( Monad m-   ) => V (a ': l) -> (a -> m ()) -> m (V l)-{-# INLINABLE (.~!!>) #-}-(.~!!>) v f = case popVariantHead v of-   Right u -> f u >> error ".~!!> error"-   Left  l -> return l--infixl 0 .~!!>---- | Extract the first value and perform effect.-(>.~!!>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (a -> m ()) -> m (V l)-{-# INLINABLE (>.~!!>) #-}-(>.~!!>) = liftm (.~!!>)--infixl 0 >.~!!>--------------------------------------------------------------- First element, pure variant--------------------------------------------------------------- | Extract the first value, set the first value-(.-.>) :: forall m l x a.-   ( Monad m )-   => V (a ': l) -> (a -> x) -> Flow m (x ': l)-{-# INLINABLE (.-.>) #-}-(.-.>) v f = makeFlowOp selectFirst (applyPure (liftV f)) combineFirst v--infixl 0 .-.>---- | Extract the first value, set the first value-(>.-.>) :: forall m l x a.-   ( Monad m )-   => Flow m (a ': l) -> (a -> x) -> Flow m (x ': l)-{-# INLINABLE (>.-.>) #-}-(>.-.>) = liftm (.-.>)--infixl 0 >.-.>---- | Extract the first value, set the first value-(<.-.) :: forall m l x a.-   ( Monad m )-   => (a -> x) -> V (a ': l) -> Flow m (x ': l)-{-# INLINABLE (<.-.) #-}-(<.-.) = flip (.-.>)--infixr 0 <.-.---- | Extract the first value, set the first value-(<.-.<) :: forall m l x a.-   ( Monad m )-   => (a -> x) -> Flow m (a ': l) -> Flow m (x ': l)-{-# INLINABLE (<.-.<) #-}-(<.-.<) = flip (>.-.>)--infixr 0 <.-.<--------------------------------------------------------------- Functor, applicative--------------------------------------------------------------- | Functor <$> equivalent-(<$<) :: forall m l a b.-   ( Monad m )-   => (a -> b) -> Flow m (a ': l) -> Flow m (b ': l)-{-# INLINABLE (<$<) #-}-(<$<) = (<.-.<)--infixl 4 <$<---- | Applicative <*> equivalent-(<*<) :: forall m l a b.-   ( Monad m )-   => Flow m ((a -> b) ': l) -> Flow m (a ': l) -> Flow m (b ': l)-{-# INLINABLE (<*<) #-}-(<*<) mf mg = mf >.~$> (mg >.-.>)--infixl 4 <*<---- | Applicative <*> equivalent, with error union-(<|<) :: forall m xs ys zs y z.-   ( Monad m-   , LiftVariant xs zs-   , LiftVariant ys zs-   , zs ~ Union xs ys-   ) => Flow m ((y -> z) ': xs) -> Flow m (y ': ys) -> Flow m (z ': zs)-{-# INLINABLE (<|<) #-}-(<|<) mf mg = -   mf >..-..> liftVariant-      >.~$> (\f -> mg >..-..> liftVariant-                      >.-.> f-            )--infixl 4 <|<--------------------------------------------------------------- First element, const variant--------------------------------------------------------------- | Extract the first value, set the first value-(.~~.>) :: forall m l x a.-   ( Monad m )-   => V (a ': l) -> m x -> Flow m (x ': l)-{-# INLINABLE (.~~.>) #-}-(.~~.>) v f = v .~.> const f--infixl 0 .~~.>---- | Extract the first value, set the first value-(>.~~.>) :: forall m l x a.-   ( Monad m )-   => Flow m (a ': l) -> m x -> Flow m (x ': l)-{-# INLINABLE (>.~~.>) #-}-(>.~~.>) = liftm (.~~.>)--infixl 0 >.~~.>---- | Extract the first value, concat the result-(.~~+>) :: forall (k :: Nat) m l l2 a.-   ( KnownNat k-   , k ~ Length l2-   , Monad m )-   => V (a ': l) -> Flow m l2 -> Flow m (Concat l2 l)-{-# INLINABLE (.~~+>) #-}-(.~~+>) v f = v .~+> const f--infixl 0 .~~+>---- | Extract the first value, concat the results-(>.~~+>) :: forall (k :: Nat) m l l2 a.-   ( KnownNat k-   , k ~ Length l2-   , Monad m )-   => Flow m (a ': l) -> Flow m l2 -> Flow m (Concat l2 l)-{-# INLINABLE (>.~~+>) #-}-(>.~~+>) = liftm (.~~+>)--infixl 0 >.~~+>---- | Extract the first value, lift the result-(.~~^^>) :: forall m a xs ys zs.-   ( Monad m-   , LiftVariant xs zs-   , LiftVariant ys zs-   ) => V (a ': ys) -> Flow m xs -> Flow m zs-{-# INLINABLE (.~~^^>) #-}-(.~~^^>) v f = v .~^^> const f--infixl 0 .~~^^>----- | Extract the first value, lift the result-(>.~~^^>) :: forall m a xs ys zs.-   ( Monad m-   , LiftVariant xs zs-   , LiftVariant ys zs-   ) => Flow m (a ': ys) -> Flow m xs -> Flow m zs-{-# INLINABLE (>.~~^^>) #-}-(>.~~^^>) = liftm (.~~^^>)--infixl 0 >.~~^^>---- | Extract the first value, connect to the expected output-(.~~^>) :: forall m a ys zs.-   ( Monad m-   , LiftVariant ys zs-   ) => V (a ': ys) -> Flow m zs -> Flow m zs-{-# INLINABLE (.~~^>) #-}-(.~~^>) v f = v .~^> const f--infixl 0 .~~^>---- | Extract the first value, connect to the expected output-(>.~~^>) :: forall m a ys zs.-   ( Monad m-   , LiftVariant ys zs-   ) => Flow m (a ': ys) -> Flow m zs -> Flow m zs-{-# INLINABLE (>.~~^>) #-}-(>.~~^>) = liftm (.~~^>)--infixl 0 >.~~^>---- | Extract the first value, use the same output type-(.~~$>) :: forall m x xs a.-   ( Monad m-   ) => V (a ': xs) -> Flow m (x ': xs) -> Flow m (x ': xs)-{-# INLINABLE (.~~$>) #-}-(.~~$>) v f = v .~$> const f--infixl 0 .~~$>---- | Extract the first value, use the same output type-(>.~~$>) :: forall m x xs a.-   ( Monad m-   ) => Flow m (a ': xs) -> Flow m (x ': xs) -> Flow m (x ': xs)-{-# INLINABLE (>.~~$>) #-}-(>.~~$>) = liftm (.~~$>)--infixl 0 >.~~$>---- | Take the first output, fusion the result-(.~~|>) ::-   ( LiftVariant xs zs-   , LiftVariant ys zs-   , zs ~ Union xs ys-   , Monad m-   ) => V (a ': ys) -> Flow m xs -> Flow m zs-{-# INLINABLE (.~~|>) #-}-(.~~|>) v f = v .~|> const f--infixl 0 .~~|>---- | Take the first output, fusion the result-(>.~~|>) ::-   ( LiftVariant xs zs-   , LiftVariant ys zs-   , zs ~ Union xs ys-   , Monad m-   ) => Flow m (a ': ys) -> Flow m xs -> Flow m zs-{-# INLINABLE (>.~~|>) #-}-(>.~~|>) = liftm (.~~|>)--infixl 0 >.~~|>---- | Extract the first value and perform effect. Passthrough the input value-(.~~=>) ::-   ( Monad m-   ) => V (a ': l) -> m () -> Flow m (a ': l)-{-# INLINABLE (.~~=>) #-}-(.~~=>) v f = v .~=> const f--infixl 0 .~~=>---- | Extract the first value and perform effect. Passthrough the input value-(>.~~=>) ::-   ( Monad m-   ) => Flow m (a ': l) -> m () -> Flow m (a ': l)-{-# INLINABLE (>.~~=>) #-}-(>.~~=>) = liftm (.~~=>)--infixl 0 >.~~=>---- | Extract the first value and perform effect.-(.~~!>) ::-   ( Monad m-   ) => V (a ': l) -> m () -> m ()-{-# INLINABLE (.~~!>) #-}-(.~~!>) v f = v .~!> const f--infixl 0 .~~!>---- | Extract the first value and perform effect.-(>.~~!>) ::-   ( Monad m-   ) => Flow m (a ': l) -> m () -> m ()-{-# INLINABLE (>.~~!>) #-}-(>.~~!>) = liftm (.~~!>)--infixl 0 >.~~!>---------------------------------------------------------------- Tail operations--------------------------------------------------------------- | Extract the tail, set the first value-(..~.>) ::-   ( Monad m-   ) => V (a ': l) -> (V l -> m a) -> m a-{-# INLINABLE (..~.>) #-}-(..~.>) v f = makeFlowOp selectTail (applyVM f) combineSingle v--infixl 0 ..~.>---- | Extract the tail, set the first value-(>..~.>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (V l -> m a) -> m a-{-# INLINABLE (>..~.>) #-}-(>..~.>) = liftm (..~.>)--infixl 0 >..~.>---- | Extract the tail, set the first value (pure function)-(..-.>) ::-   ( Monad m-   ) => V (a ': l) -> (V l -> a) -> m a-{-# INLINABLE (..-.>) #-}-(..-.>) v f = case popVariantHead v of-   Right u -> return u-   Left  l -> return (f l)--infixl 0 ..-.>---- | Extract the tail, set the first value (pure function)-(>..-.>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (V l -> a) -> m a-{-# INLINABLE (>..-.>) #-}-(>..-.>) = liftm (..-.>)--infixl 0 >..-.>---- | Extract the tail, set the tail-(..-..>) :: forall a l xs m.-   ( Monad m-   ) => V (a ': l) -> (V l -> V xs) -> Flow m (a ': xs)-{-# INLINABLE (..-..>) #-}-(..-..>) v f = case popVariantHead v of-   Right u -> flowSetN @0 u-   Left  l -> return (prependVariant @'[a] (f l))--infixl 0 ..-..>---- | Extract the tail, set the tail-(>..-..>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (V l -> V xs) -> Flow m (a ': xs)-{-# INLINABLE (>..-..>) #-}-(>..-..>) = liftm (..-..>)--infixl 0 >..-..>---- | Extract the tail, set the tail-(..~..>) :: forall a l xs m.-   ( Monad m-   ) => V (a ': l) -> (V l -> Flow m xs) -> Flow m (a ': xs)-{-# INLINABLE (..~..>) #-}-(..~..>) v f = case popVariantHead v of-   Right u -> flowSetN @0 u-   Left  l -> prependVariant @'[a] <$> f l--infixl 0 ..~..>---- | Extract the tail, set the tail-(>..~..>) ::-   ( Monad m-   ) => Flow m (a ': l) -> (V l -> Flow m xs) -> Flow m (a ': xs)-{-# INLINABLE (>..~..>) #-}-(>..~..>) = liftm (..~..>)--infixl 0 >..~..>---- | Extract the tail, lift the result-(..~^^>) ::-   ( Monad m-   , LiftVariant xs (a ': zs)-   ) => V (a ': l) -> (V l -> Flow m xs) -> Flow m (a ': zs)-{-# INLINABLE (..~^^>) #-}-(..~^^>) v f = case popVariantHead v of-   Right u -> flowSetN @0 u-   Left  l -> liftVariant <$> f l--infixl 0 ..~^^>---- | Extract the tail, lift the result-(>..~^^>) ::-   ( Monad m-   , LiftVariant xs (a ': zs)-   ) => Flow m  (a ': l) -> (V l -> Flow m xs) -> Flow m (a ': zs)-{-# INLINABLE (>..~^^>) #-}-(>..~^^>) = liftm (..~^^>)--infixl 0 >..~^^>---- | Extract the tail, connect the result-(..~^>) ::-   ( Monad m-   , a :< zs-   ) => V (a ': l) -> (V l -> Flow m zs) -> Flow m zs-{-# INLINABLE (..~^>) #-}-(..~^>) v f = case popVariantHead v of-   Right u -> flowSet u-   Left  l -> f l--infixl 0 ..~^>---- | Extract the tail, connect the result-(>..~^>) ::-   ( Monad m-   , a :< zs-   ) => Flow m (a ': l) -> (V l -> Flow m zs) -> Flow m zs-{-# INLINABLE (>..~^>) #-}-(>..~^>) = liftm (..~^>)--infixl 0 >..~^>---- | Match in the tail, connect to the expected result-(..?~^>) ::-   ( Monad m-   , a :<? xs-   , LiftVariant (Remove a xs) ys-   ) => V (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys)-{-# INLINABLE (..?~^>) #-}-(..?~^>) v f = v ..~..> (\v' -> v' ?~^> f)--infixl 0 ..?~^>---- | Match in the tail, connect to the expected result-(>..?~^>) ::-   ( Monad m-   , a :<? xs-   , LiftVariant (Remove a xs) ys-   ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys)-{-# INLINABLE (>..?~^>) #-}-(>..?~^>) = liftm (..?~^>)--infixl 0 >..?~^>---- | Match in the tail, connect to the expected result-(..%~^>) ::-   ( Monad m-   , a :< xs-   , LiftVariant (Remove a xs) ys-   ) => V (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys)-{-# INLINABLE (..%~^>) #-}-(..%~^>) v f = v ..~..> (\v' -> v' %~^> f)--infixl 0 ..%~^>---- | Match in the tail, connect to the expected result-(>..%~^>) ::-   ( Monad m-   , a :< xs-   , LiftVariant (Remove a xs) ys-   ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys)-{-# INLINABLE (>..%~^>) #-}-(>..%~^>) = liftm (..%~^>)--infixl 0 >..%~^>---- | Match in the tail, lift to the expected result-(..?~^^>) ::-   ( Monad m-   , a :<? xs-   , LiftVariant (Remove a xs) zs-   , LiftVariant ys zs-   ) => V (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)-{-# INLINABLE (..?~^^>) #-}-(..?~^^>) v f = v ..~..> (\v' -> v' ?~^^> f)--infixl 0 ..?~^^>---- | Match in the tail, lift to the expected result-(>..?~^^>) ::-   ( Monad m-   , a :<? xs-   , LiftVariant (Remove a xs) zs-   , LiftVariant ys zs-   ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)-{-# INLINABLE (>..?~^^>) #-}-(>..?~^^>) = liftm (..?~^^>)--infixl 0 >..?~^^>---- | Match in the tail, lift to the expected result-(..%~^^>) ::-   ( Monad m-   , a :< xs-   , LiftVariant (Remove a xs) zs-   , LiftVariant ys zs-   ) => V (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)-{-# INLINABLE (..%~^^>) #-}-(..%~^^>) v f = v ..~..> (\v' -> v' %~^^> f)--infixl 0 ..%~^^>---- | Match in the tail, lift to the expected result-(>..%~^^>) ::-   ( Monad m-   , a :< xs-   , LiftVariant (Remove a xs) zs-   , LiftVariant ys zs-   ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs)-{-# INLINABLE (>..%~^^>) #-}-(>..%~^^>) = liftm (..%~^^>)--infixl 0 >..%~^^>---- | Match in the tail, keep the same types-(..?~$>) ::-   ( Monad m-   , a :<? xs-   , LiftVariant (Remove a xs) (x ': xs)-   ) => V (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)-{-# INLINABLE (..?~$>) #-}-(..?~$>) v f = case popVariantHead v of-   Right _ -> return v-   Left xs -> xs ?~^> f--infixl 0 ..?~$>---- | Match in the tail, keep the same types-(>..?~$>) ::-   ( Monad m-   , a :<? xs-   , LiftVariant (Remove a xs) (x ': xs)-   ) => Flow m (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)-{-# INLINABLE (>..?~$>) #-}-(>..?~$>) = liftm (..?~$>)--infixl 0 >..?~$>---- | Match in the tail, keep the same types-(..%~$>) ::-   ( Monad m-   , a :< xs-   , LiftVariant (Remove a xs) (x ': xs)-   ) => V (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)-{-# INLINABLE (..%~$>) #-}-(..%~$>) v f = case popVariantHead v of-   Right _ -> return v-   Left xs -> xs %~^> f--infixl 0 ..%~$>---- | Match in the tail, keep the same types-(>..%~$>) ::-   ( Monad m-   , a :< xs-   , LiftVariant (Remove a xs) (x ': xs)-   ) => Flow m (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)-{-# INLINABLE (>..%~$>) #-}-(>..%~$>) = liftm (..%~$>)--infixl 0 >..%~$>----- | Extract the tail and perform an effect. Passthrough the input value-(..~=>) ::-   ( Monad m-   ) => V (x ': xs) -> (V xs -> m ()) -> Flow m (x ': xs)-{-# INLINABLE (..~=>) #-}-(..~=>) v f = case popVariantHead v of-   Right _ -> return v-   Left  l -> f l >> return v--infixl 0 ..~=>---- | Extract the tail and perform an effect. Passthrough the input value-(>..~=>) ::-   ( Monad m-   ) => Flow m (x ': xs) -> (V xs -> m ()) -> Flow m (x ': xs)-{-# INLINABLE (>..~=>) #-}-(>..~=>) = liftm (..~=>)--infixl 0 >..~=>---- | Extract the tail and perform an effect-(..~!>) ::-   ( Monad m-   ) => V (x ': xs) -> (V xs -> m ()) -> m ()-{-# INLINABLE (..~!>) #-}-(..~!>) v f = case popVariantHead v of-   Right _ -> return ()-   Left  l -> f l--infixl 0 ..~!>---- | Extract the tail and perform an effect-(>..~!>) ::-   ( Monad m-   ) => Flow m (x ': xs) -> (V xs -> m ()) -> m ()-{-# INLINABLE (>..~!>) #-}-(>..~!>) = liftm (..~!>)--infixl 0 >..~!>---- | Extract the tail and perform an effect-(..~!!>) ::-   ( Monad m-   ) => V (x ': xs) -> (V xs -> m ()) -> m x-{-# INLINABLE (..~!!>) #-}-(..~!!>) v f = case popVariantHead v of-   Right x -> return x-   Left xs -> f xs >> error "..~!!> error"--infixl 0 ..~!!>---- | Extract the tail and perform an effect-(>..~!!>) ::-   ( Monad m-   ) => Flow m (x ': xs) -> (V xs -> m ()) -> m x-{-# INLINABLE (>..~!!>) #-}-(>..~!!>) = liftm (..~!!>)--infixl 0 >..~!!>---- | Match in the tail and perform an effect-(..?~!!>) ::-   ( Monad m-   , y :<? xs-   ) => V (x ': xs) -> (y -> m ()) -> Flow m (x ': Remove y xs)-{-# INLINABLE (..?~!!>) #-}-(..?~!!>) v f = v ..~..> (\xs -> xs ?~!!> f)--infixl 0 ..?~!!>---- | Match in the tail and perform an effect-(>..?~!!>) ::-   ( Monad m-   , y :<? xs-   ) => Flow m (x ': xs) -> (y -> m ()) -> Flow m (x ': Remove y xs)-{-# INLINABLE (>..?~!!>) #-}-(>..?~!!>) = liftm (..?~!!>)--infixl 0 >..?~!!>---- | Match in the tail and perform an effect-(..%~!!>) ::-   ( Monad m-   , y :< xs-   ) => V (x ': xs) -> (y -> m ()) -> Flow m (x ': Remove y xs)-{-# INLINABLE (..%~!!>) #-}-(..%~!!>) v f = v ..~..> (\xs -> xs %~!!> f)--infixl 0 ..%~!!>---- | Match in the tail and perform an effect-(>..%~!!>) ::-   ( Monad m-   , y :< xs-   ) => Flow m (x ': xs) -> (y -> m ()) -> Flow m (x ': Remove y xs)-{-# INLINABLE (>..%~!!>) #-}-(>..%~!!>) = liftm (..%~!!>)--infixl 0 >..%~!!>---- | Match in the tail and perform an effect-(..?~!>) ::-   ( Monad m-   , y :<? xs-   ) => V (x ': xs) -> (y -> m ()) -> m ()-{-# INLINABLE (..?~!>) #-}-(..?~!>) v f = case popVariantHead v of-   Right _ -> return ()-   Left xs -> xs ?~!> f--infixl 0 ..?~!>---- | Match in the tail and perform an effect-(>..?~!>) ::-   ( Monad m-   , y :<? xs-   ) => Flow m (x ': xs) -> (y -> m ()) -> m ()-{-# INLINABLE (>..?~!>) #-}-(>..?~!>) = liftm (..?~!>)--infixl 0 >..?~!>---- | Match in the tail and perform an effect-(..%~!>) ::-   ( Monad m-   , y :< xs-   ) => V (x ': xs) -> (y -> m ()) -> m ()-{-# INLINABLE (..%~!>) #-}-(..%~!>) v f = case popVariantHead v of-   Right _ -> return ()-   Left xs -> xs %~!> f--infixl 0 ..%~!>---- | Match in the tail and perform an effect-(>..%~!>) ::-   ( Monad m-   , y :< xs-   ) => Flow m (x ': xs) -> (y -> m ()) -> m ()-{-# INLINABLE (>..%~!>) #-}-(>..%~!>) = liftm (..%~!>)--infixl 0 >..%~!>--------------------------------------------------------------- Caught element operations--------------------------------------------------------------- | Pop element, set the first value-(?~.>) :: forall x xs y ys m.-   ( ys ~ Remove x xs-   , Monad m-   , x :<? xs-   ) => V xs -> (x -> m y) -> Flow m (y ': ys)-{-# INLINABLE (?~.>) #-}-(?~.>) v f = case popVariantMaybe v of-   Right x -> flowSetN @0 =<< f x-   Left ys -> prependVariant @'[y] <$> return ys--infixl 0 ?~.>---- | Pop element, set the first value-(>?~.>) ::-   ( ys ~ Remove x xs-   , Monad m-   , x :<? xs-   ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys)-{-# INLINABLE (>?~.>) #-}-(>?~.>) = liftm (?~.>)--infixl 0 >?~.>---- | Pop element, set the first value-(%~.>) :: forall x xs y ys m.-   ( ys ~ Remove x xs-   , Monad m-   , x :< xs-   ) => V xs -> (x -> m y) -> Flow m (y ': ys)-{-# INLINABLE (%~.>) #-}-(%~.>) = (?~.>)--infixl 0 %~.>---- | Pop element, set the first value-(>%~.>) ::-   ( ys ~ Remove x xs-   , Monad m-   , x :< xs-   ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys)-{-# INLINABLE (>%~.>) #-}-(>%~.>) = liftm (%~.>)--infixl 0 >%~.>---- | Pop element, concat the result-(?~+>) :: forall x xs ys m.-   ( Monad m-   , x :<? xs-   , KnownNat (Length ys)-   ) => V xs -> (x -> Flow m ys) -> Flow m (Concat ys (Remove x xs))-{-# INLINABLE (?~+>) #-}-(?~+>) v f = case popVariantMaybe v of-   Right x -> appendVariant  @(Remove x xs) <$> f x-   Left ys -> prependVariant @ys            <$> return ys--infixl 0 ?~+>---- | Pop element, concat the result-(>?~+>) :: forall x xs ys m.-   ( Monad m-   , x :< xs-   , KnownNat (Length ys)-   ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Remove x xs))-{-# INLINABLE (>?~+>) #-}-(>?~+>) = liftm (?~+>)--infixl 0 >?~+>---- | Pop element, concat the result-(%~+>) :: forall x xs ys m.-   ( Monad m-   , x :< xs-   , KnownNat (Length ys)-   ) => V xs -> (x -> Flow m ys) -> Flow m (Concat ys (Remove x xs))-{-# INLINABLE (%~+>) #-}-(%~+>) = (?~+>)--infixl 0 %~+>---- | Pop element, concat the result-(>%~+>) :: forall x xs ys m.-   ( Monad m-   , x :< xs-   , KnownNat (Length ys)-   ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Remove x xs))-{-# INLINABLE (>%~+>) #-}-(>%~+>) = liftm (%~+>)--infixl 0 >%~+>---- | Pop element, lift the result-(?~^^>) :: forall x xs ys zs m.-   ( Monad m-   , x :<? xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   ) => V xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (?~^^>) #-}-(?~^^>) v f = case popVariantMaybe v of-   Right x -> liftVariant <$> f x-   Left ys -> liftVariant <$> return ys--infixl 0 ?~^^>---- | Pop element, lift the result-(>?~^^>) :: forall x xs ys zs m.-   ( Monad m-   , x :<? xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (>?~^^>) #-}-(>?~^^>) = liftm (?~^^>)--infixl 0 >?~^^>---- | Pop element, lift the result-(%~^^>) :: forall x xs ys zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   ) => V xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (%~^^>) #-}-(%~^^>) = (?~^^>)--infixl 0 %~^^>---- | Pop element, lift the result-(>%~^^>) :: forall x xs ys zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (>%~^^>) #-}-(>%~^^>) = liftm (%~^^>)--infixl 0 >%~^^>---- | Pop element, connect to the expected output-(?~^>) :: forall x xs zs m.-   ( Monad m-   , x :<? xs-   , LiftVariant (Remove x xs) zs-   ) => V xs -> (x -> Flow m zs) -> Flow m zs-{-# INLINABLE (?~^>) #-}-(?~^>) v f = case popVariantMaybe v of-   Right x -> f x-   Left ys -> return (liftVariant ys)--infixl 0 ?~^>---- | Pop element, connect to the expected output-(>?~^>) :: forall x xs zs m.-   ( Monad m-   , x :<? xs-   , LiftVariant (Remove x xs) zs-   ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs-{-# INLINABLE (>?~^>) #-}-(>?~^>) = liftm (?~^>)--infixl 0 >?~^>---- | Pop element, connect to the expected output-(%~^>) :: forall x xs zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   ) => V xs -> (x -> Flow m zs) -> Flow m zs-{-# INLINABLE (%~^>) #-}-(%~^>) = (?~^>)--infixl 0 %~^>---- | Pop element, connect to the expected output-(>%~^>) :: forall x xs zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs-{-# INLINABLE (>%~^>) #-}-(>%~^>) = liftm (%~^>)--infixl 0 >%~^>---- | Pop element, use the same output type-(?~$>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => V xs -> (x -> Flow m xs) -> Flow m xs-{-# INLINABLE (?~$>) #-}-(?~$>) v f = case popVariantMaybe v of-   Right x -> f x-   Left _  -> return v--infixl 0 ?~$>---- | Pop element, use the same output type-(>?~$>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs-{-# INLINABLE (>?~$>) #-}-(>?~$>) = liftm (?~$>)--infixl 0 >?~$>---- | Pop element, use the same output type-(%~$>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => V xs -> (x -> Flow m xs) -> Flow m xs-{-# INLINABLE (%~$>) #-}-(%~$>) = (?~$>)--infixl 0 %~$>---- | Pop element, use the same output type-(>%~$>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs-{-# INLINABLE (>%~$>) #-}-(>%~$>) = liftm (%~$>)--infixl 0 >%~$>---- | Pop element, fusion the result-(?~|>) :: forall x xs ys zs m.-   ( Monad m-   , x :<? xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   , zs ~ Union (Remove x xs) ys-   ) => V xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (?~|>) #-}-(?~|>) v f = case popVariantMaybe v of-   Right x -> liftVariant <$> f x-   Left ys -> return (liftVariant ys)--infixl 0 ?~|>---- | Pop element, fusion the result-(>?~|>) :: forall x xs ys zs m.-   ( Monad m-   , x :<? xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   , zs ~ Union (Remove x xs) ys-   ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (>?~|>) #-}-(>?~|>) = liftm (?~|>)--infixl 0 >?~|>---- | Pop element, fusion the result-(%~|>) :: forall x xs ys zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   , zs ~ Union (Remove x xs) ys-   ) => V xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (%~|>) #-}-(%~|>) = (?~|>)--infixl 0 %~|>---- | Pop element, fusion the result-(>%~|>) :: forall x xs ys zs m.-   ( Monad m-   , x :< xs-   , LiftVariant (Remove x xs) zs-   , LiftVariant ys zs-   , zs ~ Union (Remove x xs) ys-   ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs-{-# INLINABLE (>%~|>) #-}-(>%~|>) = liftm (%~|>)--infixl 0 >%~|>---- | Pop element and perform effect. Passthrough the input value.-(?~=>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => V xs -> (x -> m ()) -> Flow m xs-{-# INLINABLE (?~=>) #-}-(?~=>) v f = case popVariantMaybe v of-   Right x -> f x >> return v-   Left _  -> return v--infixl 0 ?~=>---- | Pop element and perform effect. Passthrough the input value.-(>?~=>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => Flow m xs -> (x -> m ()) -> Flow m xs-{-# INLINABLE (>?~=>) #-}-(>?~=>) = liftm (?~=>)--infixl 0 >?~=>---- | Pop element and perform effect. Passthrough the input value.-(%~=>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => V xs -> (x -> m ()) -> Flow m xs-{-# INLINABLE (%~=>) #-}-(%~=>) = (?~=>)--infixl 0 %~=>---- | Pop element and perform effect. Passthrough the input value.-(>%~=>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => Flow m xs -> (x -> m ()) -> Flow m xs-{-# INLINABLE (>%~=>) #-}-(>%~=>) = liftm (%~=>)--infixl 0 >%~=>---- | Pop element and perform effect.-(?~!>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => V xs -> (x -> m ()) -> m ()-{-# INLINABLE (?~!>) #-}-(?~!>) v f = case popVariantMaybe v of-   Right x -> f x-   Left _  -> return ()--infixl 0 ?~!>---- | Pop element and perform effect.-(>?~!>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => Flow m xs -> (x -> m ()) -> m ()-{-# INLINABLE (>?~!>) #-}-(>?~!>) = liftm (?~!>)--infixl 0 >?~!>---- | Pop element and perform effect.-(%~!>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => V xs -> (x -> m ()) -> m ()-{-# INLINABLE (%~!>) #-}-(%~!>) = (?~!>)--infixl 0 %~!>---- | Pop element and perform effect.-(>%~!>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => Flow m xs -> (x -> m ()) -> m ()-{-# INLINABLE (>%~!>) #-}-(>%~!>) = liftm (%~!>)--infixl 0 >%~!>---- | Pop element and perform effect.-(?~!!>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => V xs -> (x -> m ()) -> Flow m (Remove x xs)-{-# INLINABLE (?~!!>) #-}-(?~!!>) v f = case popVariantMaybe v of-   Right x -> f x >> error "?~!!> error"-   Left u  -> return u--infixl 0 ?~!!>---- | Pop element and perform effect.-(>?~!!>) :: forall x xs m.-   ( Monad m-   , x :<? xs-   ) => Flow m xs -> (x -> m ()) -> Flow m (Remove x xs)-{-# INLINABLE (>?~!!>) #-}-(>?~!!>) = liftm (?~!!>)--infixl 0 >?~!!>---- | Pop element and perform effect.-(%~!!>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => V xs -> (x -> m ()) -> Flow m (Remove x xs)-{-# INLINABLE (%~!!>) #-}-(%~!!>) = (?~!!>)--infixl 0 %~!!>---- | Pop element and perform effect.-(>%~!!>) :: forall x xs m.-   ( Monad m-   , x :< xs-   ) => Flow m xs -> (x -> m ()) -> Flow m (Remove x xs)-{-# INLINABLE (>%~!!>) #-}-(>%~!!>) = liftm (%~!!>)--infixl 0 >%~!!>------------------------------------------------------------------- Helpers-------------------------------------------------------------------- | Make a flow operator-makeFlowOp :: Monad m =>-      (V as -> Either (V bs) (V cs))-      -> (V cs -> Flow m ds)-      -> (Either (V bs) (V ds) -> es)-      -> V as -> m es-{-# INLINABLE makeFlowOp #-}-makeFlowOp select apply combine v = combine <$> traverse apply (select v)---- | Make a flow operator-makeFlowOpM :: Monad m =>-      (V as -> Either (V bs) (V cs))-      -> (V cs -> Flow m ds)-      -> (Either (V bs) (V ds) -> es)-      -> Flow m as -> m es-{-# INLINABLE makeFlowOpM #-}-makeFlowOpM select apply combine v = v >>= makeFlowOp select apply combine----- | Select the first value-selectFirst :: V (x ': xs) -> Either (V xs) (V '[x])-{-# INLINABLE selectFirst #-}-selectFirst = fmap (toVariantAt @0) . popVariantHead---- | Select the tail-selectTail :: V (x ': xs) -> Either (V '[x]) (V xs)-{-# INLINABLE selectTail #-}-selectTail = flipEither . selectFirst-   where-      flipEither (Left x)  = Right x-      flipEither (Right x) = Left x---- | Select by type-selectType ::-   ( x :< xs-   ) => V xs -> Either (V (Remove x xs)) (V '[x])-{-# INLINABLE selectType #-}-selectType = fmap (toVariantAt @0) . popVariant---- | Const application-applyConst :: Flow m ys -> (V xs -> Flow m ys)-{-# INLINABLE applyConst #-}-applyConst = const---- | Pure application-applyPure :: Monad m => (V xs -> V ys) -> V xs -> Flow m ys-{-# INLINABLE applyPure #-}-applyPure f = return . f---- | Lift a monadic function-applyM :: Monad m => (a -> m b) -> V '[a] -> Flow m '[b]-{-# INLINABLE applyM #-}-applyM = liftF---- | Lift a monadic function-applyVM :: Monad m => (V a -> m b) -> V a -> Flow m '[b]-{-# INLINABLE applyVM #-}-applyVM f = fmap (toVariantAt @0) . f---- | Lift a monadic function-applyF :: (a -> Flow m b) -> V '[a] -> Flow m b-{-# INLINABLE applyF #-}-applyF f = f . variantToValue---- | Set the first value (the "correct" one)-combineFirst :: forall x xs. Either (V xs) (V '[x]) -> V (x ': xs)-{-# INLINABLE combineFirst #-}-combineFirst = \case-   Right x -> appendVariant  @xs x-   Left xs -> prependVariant @'[x] xs---- | Set the first value, keep the same tail type -combineSameTail :: forall x xs.-   Either (V xs) (V (x ': xs)) -> V (x ': xs)-{-# INLINABLE combineSameTail #-}-combineSameTail = \case-   Right x -> x-   Left xs -> prependVariant @'[x] xs---- | Return the valid variant unmodified-combineEither :: Either (V xs) (V xs) -> V xs-{-# INLINABLE combineEither #-}-combineEither = \case-   Right x -> x-   Left x  -> x---- | Concatenate unselected values-combineConcat :: forall xs ys.-   ( KnownNat (Length xs)-   ) => Either (V ys) (V xs) -> V (Concat xs ys)-{-# INLINABLE combineConcat #-}-combineConcat = \case-   Right xs -> appendVariant  @ys xs-   Left ys  -> prependVariant @xs ys---- | Union-combineUnion ::-   ( LiftVariant xs (Union xs ys)-   , LiftVariant ys (Union xs ys)-   ) => Either (V ys) (V xs) -> V (Union xs ys)-{-# INLINABLE combineUnion #-}-combineUnion = \case-   Right xs -> liftVariant xs-   Left  ys -> liftVariant ys---- | Lift unselected-combineLiftUnselected ::-   ( LiftVariant ys xs-   ) => Either (V ys) (V xs) -> V xs-{-# INLINABLE combineLiftUnselected #-}-combineLiftUnselected = \case-   Right xs -> xs-   Left ys  -> liftVariant ys---- | Lift both-combineLiftBoth ::-   ( LiftVariant ys zs-   , LiftVariant xs zs-   ) => Either (V ys) (V xs) -> V zs-{-# INLINABLE combineLiftBoth #-}-combineLiftBoth = \case-   Right xs -> liftVariant xs-   Left ys  -> liftVariant ys---- | Single value-combineSingle :: Either (V '[x]) (V '[x]) -> x-{-# INLINABLE combineSingle #-}-combineSingle = \case-   Right x -> variantToValue x-   Left  x -> variantToValue x----- | Lift a pure function into a Variant to Variant function-liftV :: (a -> b) -> V '[a] -> V '[b]-liftV = mapVariantAt @0---- | Lift a function into a Flow-liftF :: Monad m => (a -> m b) -> V '[a] -> Flow m '[b]-liftF = mapVariantAtM @0----------------------------------------- Operation on every element---------------------------------------- | Replace the RHS of every function type in the list with `v`-type family ReplaceRHS f v where-   ReplaceRHS '[] _              = '[]-   ReplaceRHS ((x -> _) ': xs) v = (x -> v) ': ReplaceRHS xs v---- | Extract the RHS of every function type in the list-type family ExtractRHS f where-   ExtractRHS '[]              = '[]-   ExtractRHS ((_ -> x) ': xs) = x ': ExtractRHS xs--type LiftContTuple x = ListToTuple (ReplaceRHS (TupleToList x) (V (ExtractRHS (TupleToList x))))--class LiftCont x where-   -- | Lift a tuple of functions (a -> r1, b -> r2, ...) into a tuple of-   -- functions (a -> V '[r1,r2,...], b -> V '[r1,r2,...], ...)-   liftCont :: x -> LiftContTuple x--instance LiftCont (Single (a -> b)) where-   liftCont (Single a) = Single (V . a)--instance LiftCont (a->b,c->d) where-   liftCont (a,b) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      )--instance LiftCont (a->b,c->d,e->f) where-   liftCont (a,b,c) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      )--instance LiftCont (a->b,c->d,e->f,g->h) where-   liftCont (a,b,c,d) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      , toVariantAt @3 . d-      )--instance LiftCont (a->b,c->d,e->f,g->h,i->j) where-   liftCont (a,b,c,d,e) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      , toVariantAt @3 . d-      , toVariantAt @4 . e-      )--instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l) where-   liftCont (a,b,c,d,e,f) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      , toVariantAt @3 . d-      , toVariantAt @4 . e-      , toVariantAt @5 . f-      )--instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l,m->n) where-   liftCont (a,b,c,d,e,f,g) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      , toVariantAt @3 . d-      , toVariantAt @4 . e-      , toVariantAt @5 . f-      , toVariantAt @6 . g-      )--instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l,m->n,o->p) where-   liftCont (a,b,c,d,e,f,g,h) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      , toVariantAt @3 . d-      , toVariantAt @4 . e-      , toVariantAt @5 . f-      , toVariantAt @6 . g-      , toVariantAt @7 . h-      )--instance LiftCont (a->b,c->d,e->f,g->h,i->j,k->l,m->n,o->p,q->r) where-   liftCont (a,b,c,d,e,f,g,h,i) =-      ( toVariantAt @0 . a-      , toVariantAt @1 . b-      , toVariantAt @2 . c-      , toVariantAt @3 . d-      , toVariantAt @4 . e-      , toVariantAt @5 . f-      , toVariantAt @6 . g-      , toVariantAt @7 . h-      , toVariantAt @8 . i-      )---- | Pure multi-map------ Map functions on a variant and produce a resulting variant------ @---     > (V 'c' :: V '[Char,String]) -|| (ord,map toUpper)---     V 99 :: V '[Int,String]------     > (V "test" :: V '[Char,String]) -|| (ord,map toUpper)---     V "TEST" :: V '[Int,String]------     > (V "test" :: V '[Char,String]) -|| (ord,length)---     V 4 :: V '[Int,Int]--- @----(-||) :: forall fs xs zs.-   ( LiftCont fs-   , zs ~ ExtractRHS (TupleToList fs)-   , LiftContTuple fs ~ ContListToTuple xs (V zs)-   , ContVariant xs-   ) => V xs -> fs -> V zs-(-||) v fs = variantToCont v >::> liftCont fs---- | Applicative pure multi-map-(-||>) :: forall m fs xs zs ks.-   ( LiftCont fs-   , zs ~ ExtractRHS (TupleToList fs)-   , LiftContTuple fs ~ ContListToTuple xs (V zs)-   , ContVariant xs-   , ks ~ ExtractM m zs-   , Applicative m-   , JoinVariant m zs-   ) => V xs -> fs -> Flow m ks-(-||>) v fs = joinVariant (v -|| fs)---- | Monadic pure multi-map-(>-||>) :: forall m fs xs zs ks.-   ( LiftCont fs-   , zs ~ ExtractRHS (TupleToList fs)-   , LiftContTuple fs ~ ContListToTuple xs (V zs)-   , ContVariant xs-   , ks ~ ExtractM m zs-   , Monad m-   , JoinVariant m zs-   ) => Flow m xs -> fs -> Flow m ks-(>-||>) act fs = do-   r <- act-   r -||> fs---- | Variant multi-map------ Map functions returning a variant on a variant and produce a resulting--- flattened and nub'ed variant------ @---     mapInt64 :: Int64 -> V '[Int16,Int32,Int64]---     mapInt64 x---        | x <= 0xffff     = toVariantAt @0 (fromIntegral x)---        | x <= 0xffffffff = toVariantAt @1 (fromIntegral x)---        | otherwise       = toVariantAt @2 x---     ---     mapInt32 :: Int32 -> V '[Int16,Int32]---     mapInt32 x---        | x <= 0xffff     = toVariantAt @0 (fromIntegral x)---        | otherwise       = toVariantAt @1 x---     ---     > V @Int64 @'[Int64,Int32] 10 ~|| (mapInt64,mapInt32)---     V 10 :: Variant '[Int16, Int32, Int64]--- @----(~||) :: forall fs xs zs ys rs.-   ( LiftCont fs-   , zs ~ ExtractRHS (TupleToList fs)-   , LiftContTuple fs ~ ContListToTuple xs (V zs)-   , ContVariant xs-   , ys ~ FlattenVariant zs-   , Flattenable (V zs) (V ys)-   , LiftVariant ys (Nub ys)-   , rs ~ Nub ys-   ) => V xs -> fs -> V rs-(~||) v fs = nubVariant (flattenVariant (v -|| fs))---- | Applicative variant multi-map------ @---    mapInt64 :: Int64 -> IO (V '[Int16,Int32,Int64])---    mapInt64 x---       | x <= 0xffff     = do---          putStrLn "Found Int16!"---          return (toVariantAt @0 (fromIntegral x))---       | x <= 0xffffffff = do---          putStrLn "Found Int32!"---          return (toVariantAt @1 (fromIntegral x))---       | otherwise       = do---          putStrLn "Found Int64!"---          return (toVariantAt @2 x)------    mapInt32 :: Int32 -> IO (V '[Int16,Int32])---    mapInt32 x---       | x <= 0xffff     = do---          putStrLn "Found Int16!"---          return (toVariantAt @0 (fromIntegral x))---       | otherwise       = do---          putStrLn "Found Int32!"---          return (toVariantAt @1 x)------    v = V @Int64 @'[Int64,Int32] 10------    > x <- v -||> (mapInt64,mapInt32)---    Found Int16!------    > :t x---    x :: V '[V '[Int16, Int32, Int64], V '[Int16, Int32]]------    > x <- v ~||> (mapInt64,mapInt32)---    Found Int16!------    > :t x---    x :: V '[Int16, Int32, Int64]--- @----(~||>) :: forall m fs xs zs ks ys rs.-   ( ContVariant xs-   , LiftCont fs-   , zs ~ ExtractRHS (TupleToList fs)-   , LiftContTuple fs ~ ContListToTuple xs (V zs)-   , ks ~ ExtractM m zs-   , ys ~ FlattenVariant ks-   , Flattenable (V ks) (V ys)-   , rs ~ Nub ys-   , LiftVariant ys rs-   , Applicative m-   , JoinVariant m zs-   ) => V xs -> fs -> Flow m rs-(~||>) v fs = nubVariant <$> (flattenVariant <$> joinVariant (v -|| fs))---- | Monadic variant multi-map-(>~||>) :: forall m fs xs zs ks ys rs.-   ( ContVariant xs-   , LiftCont fs-   , zs ~ ExtractRHS (TupleToList fs)-   , LiftContTuple fs ~ ContListToTuple xs (V zs)-   , ks ~ ExtractM m zs-   , ys ~ FlattenVariant ks-   , Flattenable (V ks) (V ys)-   , rs ~ Nub ys-   , LiftVariant ys rs-   , Monad m-   , JoinVariant m zs-   ) => Flow m xs -> fs -> Flow m rs-(>~||>) act fs = do-   r <- act-   r ~||> fs

@@ -0,0 +1,240 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}++-- | Variant biased towards one type+--+-- This allows definition of common type classes (Functor, etc.) that can't  be+-- provided for Variant+module Haskus.Utils.Variant.VEither+   ( VEither+   , pattern VLeft+   , pattern VRight+   , veitherFromVariant+   , veitherToVariant+   , veitherToValue+   , veitherBimap+   , VEitherLift+   , veitherLift+   , veitherAppend+   , veitherPrepend+   , veitherCont+   , veitherToEither+   , veitherProduct+   , module Haskus.Utils.Variant+   )+where++import Haskus.Utils.Variant+import Haskus.Utils.Types+import Data.Coerce++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeApplications+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeFamilies+-- >>> import Data.Foldable+++-- | Variant biased towards one type+newtype VEither es a+   = VEither (V (a ': es))+++----------------------+-- Patterns+----------------------++-- | Left value+--+-- >>> VLeft (V "failed" :: V '[String,Int]) :: VEither '[String,Int] Bool+-- VLeft "failed"+--+pattern VLeft :: forall x xs. V xs -> VEither xs x+pattern VLeft xs <- ((popVariantHead . veitherToVariant) -> Left xs)+   where+      VLeft xs = VEither (toVariantTail xs)++-- | Right value+--+-- >>> VRight True :: VEither '[String,Int] Bool+-- VRight True+pattern VRight :: forall x xs. x -> VEither xs x+pattern VRight x <- ((popVariantHead . veitherToVariant) -> Right x)+   where+      VRight x = VEither (toVariantHead x)++{-# COMPLETE VLeft,VRight #-}++----------------------+-- Show instance+----------------------++instance+   ( Show a+   , Show (V es)+   ) => Show (VEither es a) where+   showsPrec d v = showParen (d /= 0) $ case v of+      VLeft xs -> showString "VLeft "+                  . showsPrec 10 xs+      VRight x -> showString "VRight "+                  . showsPrec 10 x+++-- | Convert a Variant into a VEither+--+-- >>> let x = V "Test" :: V '[Int,String,Double]+-- >>> veitherFromVariant x+-- VLeft "Test"+--+veitherFromVariant :: V (a ': es) -> VEither es a+{-# INLINABLE veitherFromVariant #-}+veitherFromVariant = VEither++-- | Convert a VEither into a Variant+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> veitherToVariant x+-- True+--+veitherToVariant :: VEither es a -> V (a ': es)+{-# INLINABLE veitherToVariant #-}+veitherToVariant (VEither x) = x++-- | Convert a VEither into an Either+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> veitherToEither x+-- Right True+--+veitherToEither :: VEither es a -> Either (V es) a+{-# INLINABLE veitherToEither #-}+veitherToEither = \case+   VLeft xs -> Left xs+   VRight x -> Right x++-- | Extract from a VEither without left types+--+-- >>> let x = VRight True :: VEither '[] Bool+-- >>> veitherToValue x+-- True+veitherToValue :: forall a. VEither '[] a -> a+{-# INLINABLE veitherToValue #-}+veitherToValue = coerce (variantToValue @a)++-- | Bimap for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> veitherBimap id not x+-- VRight False+--+veitherBimap :: (V es -> V fs) -> (a -> b) ->  VEither es a -> VEither fs b+{-# INLINABLE veitherBimap #-}+veitherBimap f g v = case v of+   VLeft xs -> VLeft (f xs)+   VRight x -> VRight (g x)+++type VEitherLift es es' =+   ( LiftVariant es es'+   )++-- | Lift a VEither into another+veitherLift :: forall es' es a.+   ( VEitherLift es es'+   ) => VEither es a -> VEither es' a+{-# INLINABLE veitherLift #-}+veitherLift = veitherBimap liftVariant id++-- | Prepend errors to VEither+veitherPrepend :: forall ns es a.+   ( KnownNat (Length ns)+   ) => VEither es a -> VEither (Concat ns es) a+{-# INLINABLE veitherPrepend #-}+veitherPrepend = veitherBimap (prependVariant @ns) id++-- | Append errors to VEither+veitherAppend :: forall ns es a.+   VEither es a -> VEither (Concat es ns) a+{-# INLINABLE veitherAppend #-}+veitherAppend = veitherBimap (appendVariant @ns) id++-- | VEither continuations+veitherCont :: (V es -> u) -> (a -> u) -> VEither es a -> u+{-# INLINABLE veitherCont #-}+veitherCont f g v = case v of+   VLeft xs -> f xs+   VRight x -> g x++-- | Product of two VEither+veitherProduct :: KnownNat (Length (b:e2)) => VEither e1 a -> VEither e2 b -> VEither (Tail (Product (a:e1) (b:e2))) (a,b)+veitherProduct (VEither x) (VEither y) = VEither (productVariant x y)++-- | Functor instance for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> fmap (\b -> if b then "Success" else "Failure") x+-- VRight "Success"+--+instance Functor (VEither es) where+   {-# INLINABLE fmap #-}+   fmap f (VEither v) = VEither (mapVariantAt @0 f v)++-- | Applicative instance for VEither+--+-- >>> let x = VRight True  :: VEither '[Int,Float] Bool+-- >>> let y = VRight False :: VEither '[Int,Float] Bool+-- >>> (&&) <$> x <*> y+-- VRight False+-- >>> (||) <$> x <*> y+-- VRight True+--+instance Applicative (VEither es) where+   pure = VRight++   VRight f <*> VRight a = VRight (f a)+   VLeft v  <*> _        = VLeft v+   _        <*> VLeft v  = VLeft v++-- | Monad instance for VEither+--+-- >>> let x   = VRight True    :: VEither '[Int,Float] Bool+-- >>> let f v = VRight (not v) :: VEither '[Int,Float] Bool+-- >>> x >>= f+-- VRight False+--+instance Monad (VEither es) where+   VRight a >>= f = f a+   VLeft v  >>= _ = VLeft v++-- | Foldable instance for VEither+--+-- >>> let x   = VRight True    :: VEither '[Int,Float] Bool+-- >>> let y   = VLeft (V "failed" :: V '[String,Int]) :: VEither '[String,Int] Bool+-- >>> forM_ x print+-- True+-- >>> forM_ y print+--+instance Foldable (VEither es) where+   foldMap f (VRight a) = f a+   foldMap _ (VLeft _)  = mempty++instance Traversable (VEither es) where+   traverse f (VRight a) = VRight <$> f a+   traverse _ (VLeft xs) = pure (VLeft xs)

@@ -23,6 +23,7 @@    , ApplyAll    , pattern FV    , appendVariantF+   , prependVariantF    , toVariantFHead    , toVariantFTail    , popVariantFHead@@ -33,16 +34,19 @@    , popVariantF    , LiftVariantF    , liftVariantF-   , AlterVariantF-   , alterVariantF-   , AlgVariantF-   , algVariantF    , SplitVariantF    , splitVariantF    , variantFToCont    , variantFToContM    , contToVariantF    , contToVariantFM+   -- * Algebras+   , BottomUpF+   , BottomUp (..)+   , BottomUpOrig (..)+   , BottomUpOrigF+   , TopDownStop (..)+   , TopDownStopF    -- * Reexport    , NoConstraint    , module Haskus.Utils.Functor@@ -54,12 +58,10 @@ import Haskus.Utils.Types.List import Haskus.Utils.Types.Constraint import Haskus.Utils.ContFlow+import Haskus.Utils.Types -import Unsafe.Coerce import Data.Bifunctor-import GHC.Exts (Any) import Control.DeepSeq-import Data.Functor.Classes  -- $setup -- >>> :set -XDataKinds@@ -73,6 +75,7 @@ -- >>> -- >>> data ConsF a e = ConsF a e deriving (Functor) -- >>> data NilF    e = NilF      deriving (Functor)+-- >>> type ListF   a = VariantF '[NilF,ConsF a] -- >>> -- >>> instance Eq a => Eq1 (ConsF a) where liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2 -- >>> instance Eq1 NilF where liftEq _ _ _ = True@@ -93,17 +96,19 @@ -- False  -- | Recursive Functor-like Variant-newtype VariantF (xs :: [* -> *]) e+newtype VariantF (xs :: [t -> *]) (e :: t)    = VariantF (V (ApplyAll e xs))  -- | Apply its first argument to every element of the 2nd arg list -- -- > ApplyAll e '[f,g,h] ==> '[f e, g e, h e] ---type family ApplyAll e (xs :: [* -> k]) :: [k] where+type family ApplyAll (e :: t) (xs :: [t -> k]) :: [k] where    ApplyAll e '[]       = '[]    ApplyAll e (f ': fs) = f e ': ApplyAll e fs +type instance Base (VariantF xs a) = VariantF xs+ -- | Eq instance for VariantF -- -- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String@@ -215,7 +220,12 @@       Right x -> toVariantFHead (fmap f x)       Left xs -> toVariantFTail (fmap f (VariantF xs)) ++ -- | Pattern-match in a VariantF+--+-- >>> FV (NilF :: NilF String) :: VariantF '[ConsF Char,NilF] String+-- NilF pattern FV :: forall c cs e. c :< (ApplyAll e cs) => c -> VariantF cs e pattern FV x = VariantF (V x) @@ -228,19 +238,26 @@    ) => VariantF xs e -> VariantF (Concat xs ys) e appendVariantF (VariantF v) = VariantF (appendVariant @(ApplyAll e ys) v) +prependVariantF :: forall (xs :: [* -> *]) (ys :: [* -> *]) e.+   ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys)+   , KnownNat (Length (ApplyAll e xs))+   ) => VariantF ys e -> VariantF (Concat xs ys) e+prependVariantF (VariantF v) = VariantF (prependVariant @(ApplyAll e xs) v)++ -- | Set the first value toVariantFHead :: forall x xs e. x e -> VariantF (x ': xs) e-{-# INLINE toVariantFHead #-}+{-# INLINABLE toVariantFHead #-} toVariantFHead v = VariantF (toVariantHead @(x e) @(ApplyAll e xs) v)  -- | Set the tail toVariantFTail :: forall x xs e. VariantF xs e -> VariantF (x ': xs) e-{-# INLINE toVariantFTail #-}+{-# INLINABLE toVariantFTail #-} toVariantFTail (VariantF v) = VariantF (toVariantTail @(x e) @(ApplyAll e xs) v)  -- | Pop VariantF head popVariantFHead :: forall x xs e. VariantF (x ': xs) e -> Either (VariantF xs e) (x e)-{-# INLINE popVariantFHead #-}+{-# INLINABLE popVariantFHead #-} popVariantFHead (VariantF v) = case popVariantHead v of    Right x -> Right x    Left xs -> Left (VariantF xs)@@ -254,7 +271,7 @@ popVariantF :: forall x xs e.    ( PopVariantF x xs e    ) => VariantF xs e -> Either (VariantF (Remove x xs) e) (x e)-{-# INLINE popVariantF #-}+{-# INLINABLE popVariantF #-} popVariantF (VariantF v) = case popVariant v of    Right x -> Right x    Left xs -> Left (VariantF xs)@@ -282,77 +299,6 @@    ) => VariantF as e -> VariantF bs e liftVariantF (VariantF v) = VariantF (liftVariant' v) -class AlterVariantF (c :: (* -> *) -> Constraint) e (xs :: [* -> *]) where-   alterVariantF' :: (forall (f :: * -> *). c f => f e -> f e) -> Word -> Any -> Any--instance AlterVariantF c e '[] where-   {-# INLINE alterVariantF' #-}-   alterVariantF' _ = undefined--instance-   ( AlterVariantF c e xs-   , c x-   ) => AlterVariantF c e (x ': xs)-   where-      {-# INLINE alterVariantF' #-}-      alterVariantF' f t v =-         case t of-            0 -> unsafeCoerce (f (unsafeCoerce v :: x e))-            n -> alterVariantF' @c @e @xs f (n-1) v---- | Alter a variant. You need to specify the constraints required by the--- modifying function.------ Usage:------ >   alterVariantF @NoConstraint id         v--- >   alterVariantF @Resizable    (resize 4) v--- >--- >   -- Multiple constraints:--- >   class (Ord a, Num a) => OrdNum a--- >   instance (Ord a, Num a) => OrdNum a--- >   alterVariantF @OrdNum foo v----alterVariantF :: forall c e (xs :: [* -> *]).-   ( AlterVariantF c e xs-   ) => (forall (f :: * -> *). c f => f e -> f e) -> VariantF xs e -> VariantF xs e-{-# INLINABLE alterVariantF #-}-alterVariantF f (VariantF (Variant t a)) =-   VariantF (Variant t (alterVariantF' @c @e @xs f t a))---class AlgVariantF (c :: (* -> *) -> Constraint) e r (xs :: [* -> *]) where-   algVariantF' :: (forall (f :: * -> *). c f => f e -> r) -> Word -> Any -> r--instance AlgVariantF c e r '[] where-   {-# INLINE algVariantF' #-}-   algVariantF' _ = undefined--instance-   ( AlgVariantF c e r xs-   , c x-   ) => AlgVariantF c e r (x ': xs)-   where-      {-# INLINE algVariantF' #-}-      algVariantF' f t v =-         case t of-            0 -> f (unsafeCoerce v :: x e)-            n -> algVariantF' @c @e @r @xs f (n-1) v---- | Apply an algebra to a VariantF. You need to specify the constraints--- required by the modifying function.------ Usage:------ >  algVariantF @NoConstraint id         v--- >  algVariantF @Resizable    (resize 4) v----algVariantF :: forall c e r (xs :: [* -> *]).-   ( AlgVariantF c e r xs-   ) => (forall (f :: * -> *). c f => f e -> r) -> VariantF xs e -> r-{-# INLINABLE algVariantF #-}-algVariantF f (VariantF (Variant t a)) = algVariantF' @c @e @r @xs f t a- type SplitVariantF as xs e =    ( Complement (ApplyAll e xs) (ApplyAll e as) ~ ApplyAll e (Complement xs as)    , SplitVariant (ApplyAll e as) (ApplyAll e (Complement xs as)) (ApplyAll e xs)@@ -398,3 +344,74 @@    toContM = variantFToContM  deriving newtype instance (NFData (V (ApplyAll e xs))) => NFData (VariantF xs e)++----------------------------------------+-- BottomUp+----------------------------------------++type family BottomUpF c fs :: Constraint where+   BottomUpF c fs = (Functor (VariantF fs), BottomUp c fs)++class BottomUp c fs where+   toBottomUp :: (forall f. c f => f a -> b) -> (VariantF fs a -> b)++instance BottomUp c '[] where+   {-# INLINABLE toBottomUp #-}+   toBottomUp _f = undefined++instance forall c fs f.+   ( BottomUp c fs+   , c f+   ) => BottomUp c (f ':fs) where+   {-# INLINABLE toBottomUp #-}+   toBottomUp f v = case popVariantFHead v of+      Right x -> f x+      Left xs -> toBottomUp @c f xs++----------------------------------------+-- BottomUpOrig+----------------------------------------++type family BottomUpOrigF c fs :: Constraint where+   BottomUpOrigF c fs = (Functor (VariantF fs), BottomUpOrig c fs)++class BottomUpOrig c fs where+   toBottomUpOrig :: (forall f. c f => f (t,a) -> b) -> (VariantF fs (t,a) -> b)++instance BottomUpOrig c '[] where+   {-# INLINABLE toBottomUpOrig #-}+   toBottomUpOrig _f = undefined++instance forall c fs f.+   ( BottomUpOrig c fs+   , c f+   ) => BottomUpOrig c (f ': fs) where+   {-# INLINABLE toBottomUpOrig #-}+   toBottomUpOrig f v = case popVariantFHead v of+      Right x -> f x+      Left xs -> toBottomUpOrig @c f xs+++----------------------------------------+-- TopDownStop+----------------------------------------++type family TopDownStopF c fs :: Constraint where+   TopDownStopF c fs = (Functor (VariantF fs), TopDownStop c fs)++class TopDownStop c fs where+   toTopDownStop :: (forall f. c f => TopDownStopT a f) -> TopDownStopT a (VariantF fs)++instance TopDownStop c '[] where+   {-# INLINABLE toTopDownStop #-}+   toTopDownStop _f = undefined++instance forall c fs f.+   ( TopDownStop c fs+   , Functor f+   , c f+   ) => TopDownStop c (f ':fs) where+   {-# INLINABLE toTopDownStop #-}+   toTopDownStop f v = case popVariantFHead v of+      Right x -> first toVariantFHead (f x)+      Left xs -> first (prependVariantF @'[f]) (toTopDownStop @c f xs)

@@ -18,9 +18,15 @@ import Test.Tasty import Test.Tasty.QuickCheck as QC +import Haskus.Utils.Functor import Haskus.Utils.EADT import Haskus.Utils.EADT.TH+import Haskus.Utils.Types +-------------------------------+-- List EADT+-------------------------------+ data ConsF a l = ConsF a l deriving (Functor) data NilF    l = NilF      deriving (Functor) @@ -28,18 +34,88 @@ eadtPattern 'NilF  "Nil" eadtInfixPattern 'ConsF ":->" -type List a = EADT '[ConsF a, NilF]+type ListF a = VariantF '[NilF, ConsF a]+type List  a = EADT     '[NilF, ConsF a] +instance Eq a => Eq1 (ConsF a) where+   liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2++instance Eq1 NilF where+   liftEq _ _ _ = True++instance Ord a => Ord1 (ConsF a) where+   liftCompare cmp (ConsF a e1) (ConsF b e2) = compare a b <> cmp e1 e2++instance Ord1 NilF where+   liftCompare _ _ _ = EQ++instance Show a => Show1 (ConsF a) where+   liftShowsPrec shw _ p (ConsF a e) =+      showParen (p >= 10) (showString "ConsF " . showsPrec 10 a . showString " " . shw 10 e)++instance Show1 NilF where+   liftShowsPrec _ _ _ _ = showString "NilF"++-- example values: list0 :: List String list0 = Cons "Hello" $ Cons "World" Nil +-------------------------------+-- Show AlgebraC+-------------------------------++class MyShow (f :: Type -> Type) where+   myShow :: f String -> String++instance MyShow NilF where+   myShow _ = "[]"++instance Show a => MyShow (ConsF a) where+   myShow (ConsF a b) = show a ++ " : " ++ b++showBottomUp :: Show a => BottomUpT String (ListF a)+showBottomUp = toBottomUp @MyShow myShow++-------------------------------+-- numbersTo anamorphism+-------------------------------++numbersTo :: CoAlgebra (ListF String) Int+numbersTo 0 = FV (NilF :: NilF Int)+numbersTo n = FV (ConsF (show n) (n-1))++-------------------------------+-- numbersToMin5 apomorphism+-------------------------------++numbersToMin5 :: RCoAlgebra (ListF String) (List String) Int+numbersToMin5 0 = FV (NilF :: NilF (Either (List String) Int))+numbersToMin5 n+   | n > 5     = FV (ConsF (show n) (Right (n-1) :: Either (List String) Int))+   | otherwise = FV (ConsF "min" (Left (Nil :: List String) :: Either (List String) Int))++-------------------------------+-- Tests+-------------------------------+ testsEADT :: TestTree testsEADT = testGroup "EADT" $-   [ testProperty "eadtPattern: match"              $ case list0 of-                                                         Cons (x :: String) _ -> x == "Hello"-                                                         _                    -> False-   , testProperty "eadtInfixPattern: match"         $ case list0 of-                                                         (x :: String) :-> _ -> x == "Hello"-                                                         _                   -> False+   [ testProperty "eadtPattern: match" $+      case list0 of+         Cons (x :: String) _ -> x == "Hello"+         _                    -> False +   , testProperty "eadtInfixPattern: match" $+      case list0 of+         (x :: String) :-> _ -> x == "Hello"+         _                   -> False++   , testProperty "catamorphism: constraint" $+      cata showBottomUp list0 == "\"Hello\" : \"World\" : []"++   , testProperty "anamorphism: numbersTo" $+      ana numbersTo 5 == Cons "5" (Cons "4" (Cons "3" (Cons "2" (Cons "1" Nil))))++   , testProperty "apomorphism: numbersToMin5" $+      apo numbersToMin5 8 == Cons "8" (Cons "7" (Cons "6" (Cons "min" Nil)))    ]