diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2013-2017, Haskus organization +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of Sylvain Henry nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haskus-utils-variant.cabal b/haskus-utils-variant.cabal new file mode 100644 --- /dev/null +++ b/haskus-utils-variant.cabal @@ -0,0 +1,35 @@ +name: haskus-utils-variant +version: 1.0 +cabal-version: >=1.20 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Sylvain Henry 2018 +maintainer: sylvain@haskus.fr +homepage: http://www.haskus.org +synopsis: Haskus utility modules +description: + Variant (extensible sum type) and EADT (extensible recursive sum type) + datatypes. +category: System +author: Sylvain Henry + +source-repository head + type: git + location: git://github.com/haskus/haskus-utils.git + +library + exposed-modules: + Haskus.Utils.ContFlow + Haskus.Utils.Variant + Haskus.Utils.Variant.Flow + Haskus.Utils.Variant.Cont + Haskus.Utils.EADT + build-depends: + base >=4.9 && <4.12, + haskus-utils-types ==1.0.*, + haskus-utils-data ==1.0.* + default-language: Haskell2010 + hs-source-dirs: src/lib + ghc-options: -Wall + diff --git a/src/lib/Haskus/Utils/ContFlow.hs b/src/lib/Haskus/Utils/ContFlow.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/ContFlow.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} + +-- | Continuation based control-flow +module Haskus.Utils.ContFlow + ( ContFlow (..) + , (>::>) + , (>:-:>) + , (>:%:>) + , ContListToTuple + , ContTupleToList + , StripR + , AddR + ) +where + +import Haskus.Utils.Tuple +import Haskus.Utils.Types + +-- | A continuation based control-flow +newtype ContFlow (xs :: [*]) r = ContFlow (ContListToTuple 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) + +-- | 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 AddR f r where + AddR '[] r = '[] + AddR (x ': xs) r = (x -> r) ': AddR xs r + +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 "'") + +-- | Bind a flow to a tuple of continuations +(>::>) :: ContFlow xs r -> ContListToTuple xs r -> r +{-# INLINE (>::>) #-} +(>::>) (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) + +infixl 0 >:-:> + +-- | Bind a flow to a tuple of continuations and +-- reorder fields if necessary +(>:%:>) :: forall ts xs r. + ( ReorderTuple ts (ContListToTuple xs r) + ) => ContFlow xs r -> ts -> r +{-# INLINE (>:%:>) #-} +(>:%:>) (ContFlow f) !cs = f (tupleReorder cs) + +infixl 0 >:%:> + + diff --git a/src/lib/Haskus/Utils/EADT.hs b/src/lib/Haskus/Utils/EADT.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/EADT.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | Extensible ADT +module Haskus.Utils.EADT + ( VariantF (..) + , ApplyAll + , pattern FV + , appendVariantF + , toVariantFHead + , toVariantFTail + , popVariantFHead + , popVariantF + , mapVariantF + , variantFToValue + , LiftableF + , liftVariantF + -- * Extensible ADT + , EADT + , (:<:) + , pattern VF + , appendEADT + , liftEADT + , popEADT + -- * Reexport + , module Haskus.Utils.Functor + ) +where + +import Haskus.Utils.Variant +import Haskus.Utils.Functor +import Haskus.Utils.Types.List +import Haskus.Utils.Types + +-- | Recursive Functor-like Variant +newtype VariantF (xs :: [* -> *]) e + = VariantF (V (ApplyAll e xs)) + +-- | `ApplyAll e '[f,g,h] ==> '[f e, g e, h e]` +type family ApplyAll e (xs :: [* -> *]) :: [*] where + ApplyAll e '[] = '[] + ApplyAll e (f ': fs) = f e ': ApplyAll e fs + +instance (Show (V (ApplyAll e xs))) => Show (VariantF xs e) where + show (VariantF x) = show x +deriving instance (Eq (V (ApplyAll e xs))) => Eq (VariantF xs e) +deriving instance (Ord (V (ApplyAll e xs))) => Ord (VariantF xs e) + +instance Functor (VariantF '[]) where + fmap _ = undefined + +instance (Functor (VariantF fs), Functor f) => Functor (VariantF (f ': fs)) where + fmap f (VariantF v) = case popVariantHead v of + Right x -> toVariantFHead (fmap f x) + Left xs -> toVariantFTail (fmap f (VariantF xs)) + +-- | Pattern-match in a VariantF +pattern FV :: forall c cs e. Popable c (ApplyAll e cs) => c -> VariantF cs e +pattern FV x = VariantF (V x) + +-- | Retrieve a single value +variantFToValue :: VariantF '[f] e -> f e +variantFToValue (VariantF v) = variantToValue v + +appendVariantF :: forall (ys :: [* -> *]) (xs :: [* -> *]) e. + ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys) + ) => VariantF xs e -> VariantF (Concat xs ys) e +appendVariantF (VariantF v) = VariantF (appendVariant @(ApplyAll e ys) v) + +-- | Set the first value +toVariantFHead :: forall x xs e. x e -> VariantF (x ': xs) e +{-# INLINE 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 #-} +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 #-} +popVariantFHead (VariantF v) = case popVariantHead v of + Right x -> Right x + Left xs -> Left (VariantF xs) + +-- | Pop VariantF +popVariantF :: forall x xs ys e. + ( Popable (x e) (ApplyAll e xs) + , Filter (x e) (ApplyAll e xs) ~ ApplyAll e ys + ) => VariantF xs e -> Either (VariantF ys e) (x e) +{-# INLINE popVariantF #-} +popVariantF (VariantF v) = case popVariant v of + Right x -> Right x + Left xs -> Left (VariantF xs) + +-- | Map the matching types of a variant +mapVariantF :: forall a b cs e ds as. + ( MappableVariant (a e) (b e) as + , ds ~ ReplaceNS (IndexesOf a cs) b cs + , as ~ ApplyAll e cs + , ApplyAll e ds ~ ReplaceNS (IndexesOf (a e) as) (b e) as + ) => (a e -> b e) -> VariantF cs e -> VariantF ds e +mapVariantF f (VariantF v) = VariantF (mapVariant @(a e) @(b e) @as f v) + +-- | xs is liftable in ys +type LiftableF e xs ys = + ( IsSubset xs ys ~ 'True + , LiftVariant (ApplyAll e xs) (ApplyAll e ys) + ) + +-- | Lift a VariantF into another +liftVariantF :: forall e as bs. + ( LiftableF e as bs + ) => VariantF as e -> VariantF bs e +liftVariantF (VariantF v) = VariantF (liftVariant' v) + +-------------------------------------------- +-- Extensible ADT +-------------------------------------------- + +-- | An extensible ADT +type EADT xs = Fix (VariantF xs) + +type family f :<: xs where + f :<: xs = EADTF' f (EADT xs) xs + +type EADTF' f e cs = + ( Member' f cs + , Index (IndexOf (f e) (ApplyAll e cs)) (ApplyAll e cs) ~ f e + , PopVariant (f e) (ApplyAll e cs) + , KnownNat (IndexOf (f e) (ApplyAll e cs)) + ) + +-- | Pattern-match in an extensible ADT +pattern VF :: forall e f cs. + ( 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 (V' x)) -- `V'` match a variant value (without + -- checking the membership: we already + -- do it with :<:) + +-- | Append new "constructors" to the EADT +appendEADT :: forall ys xs zs. + ( zs ~ Concat xs ys + , 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)) + +-- | Lift an EADT into another +liftEADT :: forall e as bs. + ( e ~ Fix (VariantF bs) + , LiftableF e as bs + , Functor (VariantF as) + ) => EADT as -> EADT bs +liftEADT = cata (Fix . liftVariantF) + +-- | Pop an EADT value +popEADT :: forall xs f e. + ( f :<: xs + , e ~ EADT xs + , Popable (f e) (ApplyAll e xs) + , Filter (f e) (ApplyAll e xs) ~ ApplyAll e (Filter f xs) + ) => EADT xs -> Either (VariantF (Filter f xs) (EADT xs)) (f (EADT xs)) +popEADT (Fix v) = popVariantF v diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Variant.hs @@ -0,0 +1,1269 @@ +{-# 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 #-} + +-- | Open sum type +module Haskus.Utils.Variant + ( Variant + , V + , variantIndex + -- * Patterns + , pattern V + , pattern VMaybe + , (:<) + , (: ... +-- V (x :: String) -> ... +pattern V :: forall c cs. Popable c cs => c -> Variant cs +pattern V x <- (fromVariant -> Just x) + where + V x = toVariant x + +-- | Silent pattern synonym for Variant +-- +-- Usage: case v of +-- V (x :: Int) -> ... +-- V (x :: String) -> ... +pattern V' :: forall c cs. + ( Member' c cs + , PopVariant c cs + ) => c -> Variant cs +pattern V' x <- (fromVariant' -> Just x) + where + V' x = toVariant' x + +-- | Statically unchecked matching on a Variant +pattern VMaybe :: forall c cs. (MaybePopable c cs) => c -> Variant cs +pattern VMaybe x <- (fromVariantMaybe -> Just x) + +instance Eq (Variant '[]) where + (==) = error "Empty variant" + +instance + ( Eq (Variant xs) + , Eq x + ) => Eq (Variant (x ': xs)) + where + {-# INLINE (==) #-} + (==) v1@(Variant t1 _) v2@(Variant t2 _) + | t1 /= t2 = False + | otherwise = case (popVariantHead v1, popVariantHead v2) of + (Right a, Right b) -> a == b + (Left as, Left bs) -> as == bs + _ -> False + +instance Ord (Variant '[]) where + compare = error "Empty variant" + +instance + ( Ord (Variant xs) + , Ord x + ) => Ord (Variant (x ': xs)) + where + compare v1 v2 = case (popVariantHead v1, popVariantHead v2) of + (Right a, Right b) -> compare a b + (Left as, Left bs) -> compare as bs + (Right _, Left _) -> LT + (Left _, Right _) -> GT + +instance Show (Variant '[]) where + show = error "Empty variant" + +instance + ( Show (Variant xs) + , Show x + ) => Show (Variant (x ': xs)) + where + show v = case popVariantHead v of + Right x -> show x + Left xs -> show xs + +----------------------------------------------------------- +-- Operations by index +----------------------------------------------------------- + +-- | Get Variant index +variantIndex :: Variant a -> Word +variantIndex (Variant n _) = n + +-- | Set the value with the given indexed type +toVariantAt :: forall (n :: Nat) (l :: [*]). + ( KnownNat n + ) => Index n l -> Variant l +{-# INLINE toVariantAt #-} +toVariantAt a = Variant (natValue' @n) (unsafeCoerce a) + +-- | Set the first value +toVariantHead :: forall x xs. x -> Variant (x ': xs) +{-# INLINE toVariantHead #-} +toVariantHead a = Variant 0 (unsafeCoerce a) + +-- | Set the tail +toVariantTail :: forall x xs. Variant xs -> Variant (x ': xs) +{-# INLINE toVariantTail #-} +toVariantTail (Variant t a) = Variant (t+1) a + +-- | Get the value if it has the indexed type +fromVariantAt :: forall (n :: Nat) (l :: [*]). + ( KnownNat n + ) => Variant l -> Maybe (Index n l) +{-# INLINE fromVariantAt #-} +fromVariantAt (Variant t a) = do + guard (t == natValue' @n) + return (unsafeCoerce a) -- we know it is the effective type + +-- | Pop a variant value by index, return either the value or the remaining +-- variant +popVariantAt :: forall (n :: Nat) l. + ( KnownNat n + ) => Variant l -> Either (Variant (RemoveAt n l)) (Index n l) +{-# INLINE popVariantAt #-} +popVariantAt v@(Variant t a) = case fromVariantAt @n v of + Just x -> Right x + Nothing -> Left $ if t > natValue' @n + then Variant (t-1) a + else Variant t a + +-- | Pop the head of a variant value +popVariantHead :: forall x xs. Variant (x ': xs) -> Either (Variant xs) x +{-# INLINE popVariantHead #-} +popVariantHead v@(Variant t a) = case fromVariantAt @0 v of + Just x -> Right x + Nothing -> Left $ Variant (t-1) a + +-- | Update a variant value +updateVariantAt :: forall (n :: Nat) a b l. + ( KnownNat n + , a ~ Index n l + ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l) +{-# INLINE updateVariantAt #-} +updateVariantAt f v@(Variant t a) = + case fromVariantAt @n v of + Nothing -> Variant t a + Just x -> Variant t (unsafeCoerce (f x)) + +----------------------------------------------------------- +-- Operations by type +----------------------------------------------------------- + +-- | Put a value into a Variant +-- +-- Use the first matching type index. +toVariant :: forall a l. + ( Member a l + ) => a -> Variant l +{-# INLINE toVariant #-} +toVariant = toVariantAt @(IndexOf a l) + +-- | Put a value into a Variant (silent) +-- +-- Use the first matching type index. +toVariant' :: forall a l. + ( Member' a l + ) => a -> Variant l +{-# INLINE toVariant' #-} +toVariant' = toVariantAt @(IndexOf a l) + +class PopVariant a xs where + -- | Remove a type from a variant + popVariant' :: Variant xs -> Either (Variant (Filter a xs)) a + +instance PopVariant a '[] where + popVariant' _ = undefined + +instance forall a xs n xs' y ys. + ( PopVariant a xs' + , n ~ MaybeIndexOf a xs + , xs' ~ RemoveAt1 n xs + , Filter a xs' ~ Filter a xs + , KnownNat n + , xs ~ (y ': ys) + ) => PopVariant a (y ': ys) + where + {-# INLINE popVariant' #-} + popVariant' (Variant t a) + = case natValue' @n of + 0 -> Left (Variant t a) -- no 'a' left in xs + n | n-1 == t -> Right (unsafeCoerce a) + | n-1 < t -> popVariant' @a @xs' (Variant (t-1) a) + | otherwise -> Left (Variant t a) + +-- | a is popable in xs +type Popable a xs = + ( Member a xs + , PopVariant a xs + ) + +-- | a may be popable in xs +type MaybePopable a xs = + ( PopVariant a xs + ) + +type (:<) a xs = Popable a xs +type (: Variant xs -> Either (Variant (Filter a xs)) a +popVariant v = popVariant' @a v + +-- | Extract a type from a variant. Return either the value of this type or the +-- remaining variant +popVariantMaybe :: forall a xs. + ( MaybePopable a xs + ) => Variant xs -> Either (Variant (Filter a xs)) a +popVariantMaybe v = popVariant' @a v + +-- | Pick the first matching type of a Variant +-- +-- fromVariantFirst @A (Variant 2 undefined :: Variant '[A,B,A]) == Nothing +fromVariantFirst :: forall a l. + ( Member a l + ) => Variant l -> Maybe a +{-# INLINE fromVariantFirst #-} +fromVariantFirst = fromVariantAt @(IndexOf a l) + +-- | Try to a get a value of a given type from a Variant +fromVariant :: forall a xs. + ( Popable a xs + ) => Variant xs -> Maybe a +{-# INLINE fromVariant #-} +fromVariant v = case popVariant v of + Right a -> Just a + Left _ -> Nothing + +-- | Try to a get a value of a given type from a Variant (silent) +fromVariant' :: forall a xs. + ( PopVariant a xs + ) => Variant xs -> Maybe a +{-# INLINE fromVariant' #-} +fromVariant' v = case popVariant' v of + Right a -> Just a + Left _ -> Nothing + +-- | Try to a get a value of a given type from a Variant that may not even +-- support the given type. +fromVariantMaybe :: forall a xs. + ( MaybePopable a xs + ) => Variant xs -> Maybe a +{-# INLINE fromVariantMaybe #-} +fromVariantMaybe v = case popVariantMaybe v of + Right a -> Just a + Left _ -> Nothing + +-- | Update a variant value +updateVariantFirst :: forall a b n l. + ( Member a l + , n ~ IndexOf a l + ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l) +{-# INLINE updateVariantFirst #-} +updateVariantFirst f v = updateVariantAt @n f v + +-- | Monadic update of the first matching variant value +updateVariantFirstM :: forall (n :: Nat) l l2 m . + (KnownNat n, Monad m) + => (Index n l -> m (Index n l2)) -> Variant l -> m (Variant l2) +{-# INLINE updateVariantFirstM #-} +updateVariantFirstM f v@(Variant t a) = + case fromVariantAt @n v of + Nothing -> return (Variant t a) + Just x -> Variant t <$> unsafeCoerce (f x) + +class MapVariant a b cs (is :: [Nat]) where + mapVariant' :: (a -> b) -> Variant cs -> Variant (ReplaceNS is b cs) + +instance MapVariant a b '[] is where + {-# INLINE mapVariant' #-} + mapVariant' = undefined + +instance MapVariant a b cs '[] where + {-# INLINE mapVariant' #-} + mapVariant' _ v = v + +instance forall a b cs is i. + ( MapVariant a b (ReplaceN i b cs) is + , a ~ Index i cs + , KnownNat i + ) => MapVariant a b cs (i ': is) where + {-# INLINE mapVariant' #-} + mapVariant' f v = mapVariant' @a @b @(ReplaceN i b cs) @is f (updateVariantAt @i f v) + +type MappableVariant a b cs = + ( MapVariant a b cs (IndexesOf a cs) + ) + +-- | Map the matching types of a variant +mapVariant :: forall a b cs. + ( MappableVariant a b cs + ) => (a -> b) -> Variant cs -> Variant (ReplaceNS (IndexesOf a cs) b cs) +mapVariant = mapVariant' @a @b @cs @(IndexesOf a cs) + + +-- | Update a variant value with a variant and fold the result +foldMapVariantAt :: forall (n :: Nat) l l2 . + ( KnownNat n + , KnownNat (Length l2) + ) => (Index n l -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2) +foldMapVariantAt f v@(Variant t a) = + case fromVariantAt @n v of + Nothing -> + -- we need to adapt the tag if new valid tags (from l2) are added before + if t < n + then Variant t a + else Variant (t+nl2-1) a + + Just x -> case f x of + Variant t2 a2 -> Variant (t2+n) a2 + where + n = natValue' @n + nl2 = natValue' @(Length l2) + +-- | Update a variant value with a variant and fold the result +foldMapVariantAtM :: forall (n :: Nat) m l l2. + ( KnownNat n + , KnownNat (Length l2) + , Monad m + ) => (Index n l -> m (Variant l2)) -> Variant l -> m (Variant (ReplaceAt n l l2)) +foldMapVariantAtM f v@(Variant t a) = + case fromVariantAt @n v of + Nothing -> + -- we need to adapt the tag if new valid tags (from l2) are added before + return $ if t < n + then Variant t a + else Variant (t+nl2-1) a + + Just x -> do + y <- f x + case y of + Variant t2 a2 -> return (Variant (t2+n) a2) + where + n = natValue' @n + nl2 = natValue' @(Length l2) + +-- | Update a variant value with a variant and fold the result +foldMapVariantFirst :: forall a (n :: Nat) l l2 . + ( KnownNat n + , KnownNat (Length l2) + , n ~ IndexOf a l + , a ~ Index n l + ) => (a -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2) +foldMapVariantFirst f v = foldMapVariantAt @n f v + +-- | Update a variant value with a variant and fold the result +foldMapVariantFirstM :: forall a (n :: Nat) l l2 m. + ( KnownNat n + , KnownNat (Length l2) + , n ~ IndexOf a l + , a ~ Index n l + , Monad m + ) => (a -> m (V l2)) -> V l -> m (V (ReplaceAt n l l2)) +foldMapVariantFirstM f v = foldMapVariantAtM @n f v + + + +-- | Update a variant value with a variant and fold the result +foldMapVariant :: forall a cs ds i. + ( i ~ IndexOf a cs + , Popable a cs + ) => (a -> V ds) -> V cs -> V (InsertAt i (Filter a cs) ds) +foldMapVariant f v = case popVariant v of + Right a -> case f a of + Variant t x -> Variant (i + t) x + Left (Variant t x) + | t < i -> Variant t x + | otherwise -> Variant (i+t) x + where + i = natValue' @i + + + + +----------------------------------------------------------- +-- Generic operations with type classes +----------------------------------------------------------- + +class AlterVariant c (b :: [*]) where + alterVariant' :: Alter c -> Word -> Any -> Any + +instance AlterVariant c '[] where + {-# INLINE alterVariant' #-} + alterVariant' = undefined + +instance + ( AlterVariant c xs + , c x + ) => AlterVariant c (x ': xs) + where + {-# INLINE alterVariant' #-} + alterVariant' m@(Alter f) t v = + case t of + 0 -> unsafeCoerce (f (unsafeCoerce v :: x)) + n -> alterVariant' @c @xs m (n-1) v + +-- | Wrap a function and its constraints +data Alter (c :: * -> Constraint) = Alter (forall a. c a => a -> a) + +-- | Wrap a function and its constraints +data AlterM (c :: * -> Constraint) m = AlterM (forall a. (Monad m, c a) => a -> m a) + +-- | Useful to specify a "* -> Constraint" function returning no constraint +class NoConstraint a +instance NoConstraint a + +class TraverseVariant c (b :: [*]) m where + traverseVariant' :: AlterM c m -> Word -> Any -> m Any + +instance TraverseVariant c '[] m where + {-# INLINE traverseVariant' #-} + traverseVariant' = undefined + +instance + ( TraverseVariant c xs m + , c x + , Monad m + ) => TraverseVariant c (x ': xs) m + where + {-# INLINE traverseVariant' #-} + traverseVariant' m@(AlterM f) t v = + case t of + 0 -> unsafeCoerce <$> f (unsafeCoerce v :: x) + n -> traverseVariant' @c @xs m (n-1) v + + +-- | Alter a variant. You need to specify the constraints required by the +-- modifying function. +-- +-- Usage: +-- alterVariant @NoConstraint id v +-- alterVariant @Resizable (resize 4) v +-- +-- class (Ord a, Num a) => OrdNum a +-- instance (Ord a, Num a) => OrdNum a +-- +{-# INLINE alterVariant #-} +alterVariant :: forall c (a :: [*]). + ( AlterVariant c a + ) => (forall x. c x => x -> x) -> Variant a -> Variant a +alterVariant f (Variant t a) = + Variant t (alterVariant' @c @a (Alter @c f) t a) + +-- | Traverse a variant. You need to specify the constraints required by the +-- modifying function. +{-# INLINE traverseVariant #-} +traverseVariant :: forall c (a :: [*]) m. + ( TraverseVariant c a m + , Monad m + ) => (forall x. c x => x -> m x) -> Variant a -> m (Variant a) +traverseVariant f (Variant t a) = + Variant t <$> traverseVariant' @c @a (AlterM @c @m f) t a + +-- | Traverse a variant. You need to specify the constraints required by the +-- modifying function. +traverseVariant_ :: forall c (a :: [*]) m. + ( TraverseVariant c a m + , Monad m + ) => (forall x. c x => x -> m ()) -> Variant a -> m () +traverseVariant_ f v = void (traverseVariant @c @a f' v) + where + f' :: forall x. c x => x -> m x + f' x = f x >> return x + +----------------------------------------------------------- +-- Conversions between variants +----------------------------------------------------------- + +-- | Extend a variant by appending other possible values +appendVariant :: forall (ys :: [*]) (xs :: [*]). Variant xs -> Variant (Concat xs ys) +{-# INLINE appendVariant #-} +appendVariant (Variant t a) = Variant t a + +-- | Extend a variant by prepending other possible values +prependVariant :: forall (ys :: [*]) (xs :: [*]). + ( KnownNat (Length ys) + ) => Variant xs -> Variant (Concat ys xs) +{-# INLINE prependVariant #-} +prependVariant (Variant t a) = Variant (n+t) a + where + n = natValue' @(Length ys) + +-- | xs is liftable in ys +type Liftable xs ys = + ( IsSubset xs ys ~ 'True + , LiftVariant xs ys + ) + +class LiftVariant xs ys where + liftVariant' :: Variant xs -> Variant ys + +instance LiftVariant '[] ys where + liftVariant' = error "Lifting empty variant" + +instance forall xs ys x. + ( LiftVariant xs ys + , KnownNat (IndexOf x ys) + ) => LiftVariant (x ': xs) ys + where + {-# INLINE liftVariant' #-} + liftVariant' (Variant t a) + | t == 0 = Variant (natValue' @(IndexOf x ys)) a + | otherwise = liftVariant' @xs (Variant (t-1) a) + + +-- | Lift a variant into another +-- +-- Set values to the first matching type +liftVariant :: forall xs ys. + ( Liftable xs ys + ) => Variant xs -> Variant ys +{-# INLINE liftVariant #-} +liftVariant = liftVariant' + +-- | Nub the type list +nubVariant :: (Liftable xs (Nub xs)) => V xs -> V (Nub xs) +nubVariant = liftVariant + +-- | Product of two variants +productVariant :: forall xs ys. + ( KnownNat (Length ys) + ) => Variant xs -> Variant ys -> Variant (Product xs ys) +productVariant (Variant n1 a1) (Variant n2 a2) + = Variant (n1 * natValue @(Length ys) + n2) (unsafeCoerce (a1,a2)) + +type family FlattenVariant (xs :: [*]) :: [*] where + FlattenVariant '[] = '[] + FlattenVariant (Variant xs:ys) = Concat xs (FlattenVariant ys) + FlattenVariant (y:ys) = y ': FlattenVariant ys + +class Flattenable a rs where + toFlattenVariant :: Word -> a -> rs + +instance Flattenable (Variant '[]) rs where + {-# INLINE toFlattenVariant #-} + toFlattenVariant _ _ = undefined + +instance forall xs ys rs. + ( Flattenable (Variant ys) (Variant rs) + , KnownNat (Length xs) + ) => Flattenable (Variant (Variant xs ': ys)) (Variant rs) + where + {-# INLINE toFlattenVariant #-} + toFlattenVariant i v = case popVariantHead v of + Right (Variant n a) -> Variant (i+n) a + Left vys -> toFlattenVariant (i+natValue @(Length xs)) vys + +-- | Flatten variants in a variant +flattenVariant :: forall xs. + ( Flattenable (Variant xs) (Variant (FlattenVariant xs)) + ) => Variant xs -> Variant (FlattenVariant xs) +flattenVariant v = toFlattenVariant 0 v + +type family ExtractMonad m f where + ExtractMonad m '[m x] = '[x] + ExtractMonad m (m x ': xs) = x ': ExtractMonad m xs + +-- | Join on a variant +-- +-- Transform a variant of applicatives as follow: +-- V'[m a, m b, m c] ===> m (V'[a,b,c]) +-- +joinVariant :: forall m xs ys. + ( Applicative m + , ys ~ ExtractMonad m xs + ) => Variant xs -> m (Variant ys) +joinVariant (Variant t act) = Variant t <$> (unsafeCoerce act :: m Any) + +----------------------------------------------------------- +-- Conversions to other data types +----------------------------------------------------------- + +-- | Retrieve a single value +variantToValue :: Variant '[a] -> a +{-# INLINE variantToValue #-} +variantToValue (Variant _ a) = unsafeCoerce a + +-- | Create a variant from a single value +variantFromValue :: a -> Variant '[a] +{-# INLINE variantFromValue #-} +variantFromValue a = Variant 0 (unsafeCoerce a) + + +-- | Convert a variant of two values in a Either +variantToEither :: forall a b. Variant '[a,b] -> Either b a +variantToEither (Variant 0 a) = Right (unsafeCoerce a) +variantToEither (Variant _ a) = Left (unsafeCoerce a) + +class VariantToHList xs where + -- | Convert a variant into a HList of Maybes + variantToHList :: Variant xs -> HList (Map Maybe xs) + +instance VariantToHList '[] where + variantToHList _ = HNil + +instance + ( VariantToHList xs + ) => VariantToHList (x ': xs) + where + variantToHList v@(Variant t a) = + fromVariantAt @0 v `HCons` variantToHList v' + where + v' :: Variant xs + v' = Variant (t-1) a + +-- | Get variant possible values in a tuple of Maybe types +variantToTuple :: forall l t. + ( VariantToHList l + , HTuple' (Map Maybe l) t + ) => Variant l -> t +variantToTuple = hToTuple' . variantToHList + + +-- | Lift an Either into a Variant (reversed order by convention) +variantFromEither :: Either a b -> Variant '[b,a] +{-# INLINE variantFromEither #-} +variantFromEither (Left a) = toVariantAt @1 a +variantFromEither (Right b) = toVariantAt @0 b + + +class ContVariant xs where + -- | Convert a variant into a multi-continuation + variantToCont :: Variant xs -> ContFlow xs r + + -- | Convert a variant into a multi-continuation + variantToContM :: Monad m => m (Variant xs) -> ContFlow xs (m r) + + -- | Convert a multi-continuation into a Variant + contToVariant :: ContFlow xs (Variant xs) -> Variant xs + + -- | Convert a multi-continuation into a Variant + contToVariantM :: Monad m => ContFlow xs (m (Variant xs)) -> m (Variant xs) + +instance ContVariant '[a] where + {-# INLINE variantToCont #-} + variantToCont (Variant _ a) = ContFlow $ \(Single f) -> + f (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(Single f) -> do + Variant _ a <- act + f (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + Single (toVariantAt @0) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + Single (return . toVariantAt @0) + +instance ContVariant '[a,b] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2) -> + case t of + 0 -> f1 (unsafeCoerce a) + _ -> f2 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + _ -> f2 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + ) + +instance ContVariant '[a,b,c] where + {-# INLINE 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 #-} + variantToContM act = ContFlow $ \(f1,f2,f3) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + _ -> f3 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + ) + +instance ContVariant '[a,b,c,d] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + _ -> f4 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + _ -> f4 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + ) + +instance ContVariant '[a,b,c,d,e] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + _ -> f5 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + _ -> f5 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + ) + +instance ContVariant '[a,b,c,d,e,f] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + _ -> f6 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + _ -> f6 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + ) + +instance ContVariant '[a,b,c,d,e,f,g] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + _ -> f7 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + _ -> f7 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + , toVariantAt @6 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + , return . toVariantAt @6 + ) + +instance ContVariant '[a,b,c,d,e,f,g,h] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + _ -> f8 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + _ -> f8 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + , toVariantAt @6 + , toVariantAt @7 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + , return . toVariantAt @6 + , return . toVariantAt @7 + ) + +instance ContVariant '[a,b,c,d,e,f,g,h,i] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + _ -> f9 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + _ -> f9 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + , toVariantAt @6 + , toVariantAt @7 + , toVariantAt @8 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + , return . toVariantAt @6 + , return . toVariantAt @7 + , return . toVariantAt @8 + ) + +instance ContVariant '[a,b,c,d,e,f,g,h,i,j] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + 8 -> f9 (unsafeCoerce a) + _ -> f10 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + 8 -> f9 (unsafeCoerce a) + _ -> f10 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + , toVariantAt @6 + , toVariantAt @7 + , toVariantAt @8 + , toVariantAt @9 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + , return . toVariantAt @6 + , return . toVariantAt @7 + , return . toVariantAt @8 + , return . toVariantAt @9 + ) + +instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k] where + {-# INLINE variantToCont #-} + variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) -> + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + 8 -> f9 (unsafeCoerce a) + 9 -> f10 (unsafeCoerce a) + _ -> f11 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + 8 -> f9 (unsafeCoerce a) + 9 -> f10 (unsafeCoerce a) + _ -> f11 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + , toVariantAt @6 + , toVariantAt @7 + , toVariantAt @8 + , toVariantAt @9 + , toVariantAt @10 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + , return . toVariantAt @6 + , return . toVariantAt @7 + , return . toVariantAt @8 + , return . toVariantAt @9 + , return . toVariantAt @10 + ) + +instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k,l] where + {-# INLINE 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) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + 8 -> f9 (unsafeCoerce a) + 9 -> f10 (unsafeCoerce a) + 10 -> f11 (unsafeCoerce a) + _ -> f12 (unsafeCoerce a) + + {-# INLINE variantToContM #-} + variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) -> do + Variant t a <- act + case t of + 0 -> f1 (unsafeCoerce a) + 1 -> f2 (unsafeCoerce a) + 2 -> f3 (unsafeCoerce a) + 3 -> f4 (unsafeCoerce a) + 4 -> f5 (unsafeCoerce a) + 5 -> f6 (unsafeCoerce a) + 6 -> f7 (unsafeCoerce a) + 7 -> f8 (unsafeCoerce a) + 8 -> f9 (unsafeCoerce a) + 9 -> f10 (unsafeCoerce a) + 10 -> f11 (unsafeCoerce a) + _ -> f12 (unsafeCoerce a) + + {-# INLINE contToVariant #-} + contToVariant c = c >::> + ( toVariantAt @0 + , toVariantAt @1 + , toVariantAt @2 + , toVariantAt @3 + , toVariantAt @4 + , toVariantAt @5 + , toVariantAt @6 + , toVariantAt @7 + , toVariantAt @8 + , toVariantAt @9 + , toVariantAt @10 + , toVariantAt @11 + ) + + {-# INLINE contToVariantM #-} + contToVariantM c = c >::> + ( return . toVariantAt @0 + , return . toVariantAt @1 + , return . toVariantAt @2 + , return . toVariantAt @3 + , return . toVariantAt @4 + , return . toVariantAt @5 + , return . toVariantAt @6 + , return . toVariantAt @7 + , return . toVariantAt @8 + , return . toVariantAt @9 + , return . toVariantAt @10 + , return . toVariantAt @11 + ) diff --git a/src/lib/Haskus/Utils/Variant/Cont.hs b/src/lib/Haskus/Utils/Variant/Cont.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Variant/Cont.hs @@ -0,0 +1,100 @@ +{-# 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.Types.List +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 + , Member 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 + , Member 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 diff --git a/src/lib/Haskus/Utils/Variant/Flow.hs b/src/lib/Haskus/Utils/Variant/Flow.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Variant/Flow.hs @@ -0,0 +1,1981 @@ +{-# 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 +module Haskus.Utils.Variant.Flow + ( Flow + , IOV + -- * Flow utils + , flowRes + , flowSingle + , flowSetN + , flowSet + , flowLift + , flowToCont + , flowTraverse + , flowFor + , flowTraverseFilter + , flowForFilter + , Liftable + , Popable + , MaybePopable + -- * 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.Types.List +import Haskus.Utils.ContFlow +import Haskus.Utils.Tuple + +-- | Control-flow +type Flow m (l :: [*]) = m (Variant 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 +{-# INLINE flowSetN #-} +flowSetN = return . toVariantAt @n + +-- | Return in the first well-typed element +flowSet :: (Member x xs, Monad m) => x -> Flow m xs +{-# INLINE flowSet #-} +flowSet = return . toVariant + +-- | Return a single element +flowSingle :: Monad m => x -> Flow m '[x] +{-# INLINE flowSingle #-} +flowSingle = flowSetN @0 + +-- | Lift a flow into another +flowLift :: (Liftable xs ys , Monad m) => Flow m xs -> Flow m ys +{-# INLINE 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 +{-# INLINE flowRes #-} +flowRes = fmap variantToValue + + +-- | Lift an operation on a Variant into an operation on a flow +liftm :: Monad m => (Variant x -> a -> m b) -> Flow m x -> a -> m b +{-# INLINE 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) +{-# INLINE flowMap #-} +flowMap = (>.-.>) + +-- | Bind two flows in a monadish way (error types union) +flowBind :: forall xs ys zs m x. + ( Liftable xs zs + , Liftable ys zs + , zs ~ Union xs ys + , Monad m + ) => Flow m (x ': ys) -> (x -> Flow m xs) -> Flow m zs +{-# INLINE 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) +{-# INLINE flowBind' #-} +flowBind' = (>.~$>) + +-- | Match a value in a flow +flowMatch :: forall x xs zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs +{-# INLINE flowMatch #-} +flowMatch = (>%~^>) + +-- | Match a value in a flow and use a non-returning failure in this case +flowMatchFail :: forall x xs m. + ( Monad m + , Popable x xs + ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs) +{-# INLINE flowMatchFail #-} +flowMatchFail = (>%~!!>) + +---------------------------------------------------------- +-- First element operations +---------------------------------------------------------- + +-- | Extract the first value, set the first value +(.~.>) :: forall m l x a. + ( Monad m ) + => Variant (a ': l) -> (a -> m x) -> Flow m (x ': l) +{-# INLINE (.~.>) #-} +(.~.>) 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) +{-# INLINE (>.~.>) #-} +(>.~.>) = liftm (.~.>) + +infixl 0 >.~.> + +-- | Extract the first value, concat the result +(.~+>) :: forall (k :: Nat) m l l2 a. + ( KnownNat k + , k ~ Length l2 + , Monad m ) + => Variant (a ': l) -> (a -> Flow m l2) -> Flow m (Concat l2 l) +{-# INLINE (.~+>) #-} +(.~+>) 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) +{-# INLINE (>.~+>) #-} +(>.~+>) = liftm (.~+>) + +infixl 0 >.~+> + +-- | Extract the first value, lift both +(.~^^>) :: forall m a xs ys zs. + ( Monad m + , Liftable xs zs + , Liftable ys zs + ) => Variant (a ': ys) -> (a -> Flow m xs) -> Flow m zs +{-# INLINE (.~^^>) #-} +(.~^^>) v f = makeFlowOp selectFirst (applyF f) combineLiftBoth v + +infixl 0 .~^^> + + +-- | Extract the first value, lift both +(>.~^^>) :: forall m a xs ys zs. + ( Monad m + , Liftable xs zs + , Liftable ys zs + ) => Flow m (a ': ys) -> (a -> Flow m xs) -> Flow m zs +{-# INLINE (>.~^^>) #-} +(>.~^^>) = liftm (.~^^>) + +infixl 0 >.~^^> + +-- | Extract the first value, lift unselected +(.~^>) :: forall m a ys zs. + ( Monad m + , Liftable ys zs + ) => Variant (a ': ys) -> (a -> Flow m zs) -> Flow m zs +{-# INLINE (.~^>) #-} +(.~^>) v f = makeFlowOp selectFirst (applyF f) combineLiftUnselected v + +infixl 0 .~^> + +-- | Extract the first value, lift unselected +(>.~^>) :: forall m a ys zs. + ( Monad m + , Liftable ys zs + ) => Flow m (a ': ys) -> (a -> Flow m zs) -> Flow m zs +{-# INLINE (>.~^>) #-} +(>.~^>) = liftm (.~^>) + +infixl 0 >.~^> + +-- | Extract the first value, use the same tail +(.~$>) :: forall m x xs a. + ( Monad m + ) => Variant (a ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) +{-# INLINE (.~$>) #-} +(.~$>) 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) +{-# INLINE (>.~$>) #-} +(>.~$>) = liftm (.~$>) + +infixl 0 >.~$> + +-- | Take the first output, union the result +(.~|>) :: + ( Liftable xs zs + , Liftable ys zs + , zs ~ Union xs ys + , Monad m + ) => Variant (a ': ys) -> (a -> Flow m xs) -> Flow m zs +{-# INLINE (.~|>) #-} +(.~|>) v f = makeFlowOp selectFirst (applyF f) combineUnion v + +infixl 0 .~|> + +-- | Take the first output, fusion the result +(>.~|>) :: + ( Liftable xs zs + , Liftable ys zs + , zs ~ Union xs ys + , Monad m + ) => Flow m (a ': ys) -> (a -> Flow m xs) -> Flow m zs +{-# INLINE (>.~|>) #-} +(>.~|>) = liftm (.~|>) + +infixl 0 >.~|> + +-- | Extract the first value and perform effect. Passthrough the input value +(.~=>) :: + ( Monad m + ) => Variant (a ': l) -> (a -> m ()) -> Flow m (a ': l) +{-# INLINE (.~=>) #-} +(.~=>) 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) +{-# INLINE (>.~=>) #-} +(>.~=>) = liftm (.~=>) + +infixl 0 >.~=> + +-- | Extract the first value and perform effect. +(.~!>) :: + ( Monad m + ) => Variant (a ': l) -> (a -> m ()) -> m () +{-# INLINE (.~!>) #-} +(.~!>) 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 () +{-# INLINE (>.~!>) #-} +(>.~!>) = liftm (.~!>) + +infixl 0 >.~!> + +-- | Extract the first value and perform effect. +(.~!!>) :: + ( Monad m + ) => Variant (a ': l) -> (a -> m ()) -> m (Variant l) +{-# INLINE (.~!!>) #-} +(.~!!>) 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 (Variant l) +{-# INLINE (>.~!!>) #-} +(>.~!!>) = liftm (.~!!>) + +infixl 0 >.~!!> + +---------------------------------------------------------- +-- First element, pure variant +---------------------------------------------------------- + +-- | Extract the first value, set the first value +(.-.>) :: forall m l x a. + ( Monad m ) + => Variant (a ': l) -> (a -> x) -> Flow m (x ': l) +{-# INLINE (.-.>) #-} +(.-.>) 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) +{-# INLINE (>.-.>) #-} +(>.-.>) = liftm (.-.>) + +infixl 0 >.-.> + +-- | Extract the first value, set the first value +(<.-.) :: forall m l x a. + ( Monad m ) + => (a -> x) -> Variant (a ': l) -> Flow m (x ': l) +{-# INLINE (<.-.) #-} +(<.-.) = 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) +{-# INLINE (<.-.<) #-} +(<.-.<) = flip (>.-.>) + +infixr 0 <.-.< + +---------------------------------------------------------- +-- Functor, applicative +---------------------------------------------------------- + +-- | Functor <$> equivalent +(<$<) :: forall m l a b. + ( Monad m ) + => (a -> b) -> Flow m (a ': l) -> Flow m (b ': l) +{-# INLINE (<$<) #-} +(<$<) = (<.-.<) + +infixl 4 <$< + +-- | Applicative <*> equivalent +(<*<) :: forall m l a b. + ( Monad m ) + => Flow m ((a -> b) ': l) -> Flow m (a ': l) -> Flow m (b ': l) +{-# INLINE (<*<) #-} +(<*<) mf mg = mf >.~$> (mg >.-.>) + +infixl 4 <*< + +-- | Applicative <*> equivalent, with error union +(<|<) :: forall m xs ys zs y z. + ( Monad m + , Liftable xs zs + , Liftable ys zs + , zs ~ Union xs ys + ) => Flow m ((y -> z) ': xs) -> Flow m (y ': ys) -> Flow m (z ': zs) +{-# INLINE (<|<) #-} +(<|<) 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 ) + => Variant (a ': l) -> m x -> Flow m (x ': l) +{-# INLINE (.~~.>) #-} +(.~~.>) 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) +{-# INLINE (>.~~.>) #-} +(>.~~.>) = liftm (.~~.>) + +infixl 0 >.~~.> + +-- | Extract the first value, concat the result +(.~~+>) :: forall (k :: Nat) m l l2 a. + ( KnownNat k + , k ~ Length l2 + , Monad m ) + => Variant (a ': l) -> Flow m l2 -> Flow m (Concat l2 l) +{-# INLINE (.~~+>) #-} +(.~~+>) 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) +{-# INLINE (>.~~+>) #-} +(>.~~+>) = liftm (.~~+>) + +infixl 0 >.~~+> + +-- | Extract the first value, lift the result +(.~~^^>) :: forall m a xs ys zs. + ( Monad m + , Liftable xs zs + , Liftable ys zs + ) => Variant (a ': ys) -> Flow m xs -> Flow m zs +{-# INLINE (.~~^^>) #-} +(.~~^^>) v f = v .~^^> const f + +infixl 0 .~~^^> + + +-- | Extract the first value, lift the result +(>.~~^^>) :: forall m a xs ys zs. + ( Monad m + , Liftable xs zs + , Liftable ys zs + ) => Flow m (a ': ys) -> Flow m xs -> Flow m zs +{-# INLINE (>.~~^^>) #-} +(>.~~^^>) = liftm (.~~^^>) + +infixl 0 >.~~^^> + +-- | Extract the first value, connect to the expected output +(.~~^>) :: forall m a ys zs. + ( Monad m + , Liftable ys zs + ) => Variant (a ': ys) -> Flow m zs -> Flow m zs +{-# INLINE (.~~^>) #-} +(.~~^>) v f = v .~^> const f + +infixl 0 .~~^> + +-- | Extract the first value, connect to the expected output +(>.~~^>) :: forall m a ys zs. + ( Monad m + , Liftable ys zs + ) => Flow m (a ': ys) -> Flow m zs -> Flow m zs +{-# INLINE (>.~~^>) #-} +(>.~~^>) = liftm (.~~^>) + +infixl 0 >.~~^> + +-- | Extract the first value, use the same output type +(.~~$>) :: forall m x xs a. + ( Monad m + ) => Variant (a ': xs) -> Flow m (x ': xs) -> Flow m (x ': xs) +{-# INLINE (.~~$>) #-} +(.~~$>) 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) +{-# INLINE (>.~~$>) #-} +(>.~~$>) = liftm (.~~$>) + +infixl 0 >.~~$> + +-- | Take the first output, fusion the result +(.~~|>) :: + ( Liftable xs zs + , Liftable ys zs + , zs ~ Union xs ys + , Monad m + ) => Variant (a ': ys) -> Flow m xs -> Flow m zs +{-# INLINE (.~~|>) #-} +(.~~|>) v f = v .~|> const f + +infixl 0 .~~|> + +-- | Take the first output, fusion the result +(>.~~|>) :: + ( Liftable xs zs + , Liftable ys zs + , zs ~ Union xs ys + , Monad m + ) => Flow m (a ': ys) -> Flow m xs -> Flow m zs +{-# INLINE (>.~~|>) #-} +(>.~~|>) = liftm (.~~|>) + +infixl 0 >.~~|> + +-- | Extract the first value and perform effect. Passthrough the input value +(.~~=>) :: + ( Monad m + ) => Variant (a ': l) -> m () -> Flow m (a ': l) +{-# INLINE (.~~=>) #-} +(.~~=>) 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) +{-# INLINE (>.~~=>) #-} +(>.~~=>) = liftm (.~~=>) + +infixl 0 >.~~=> + +-- | Extract the first value and perform effect. +(.~~!>) :: + ( Monad m + ) => Variant (a ': l) -> m () -> m () +{-# INLINE (.~~!>) #-} +(.~~!>) v f = v .~!> const f + +infixl 0 .~~!> + +-- | Extract the first value and perform effect. +(>.~~!>) :: + ( Monad m + ) => Flow m (a ': l) -> m () -> m () +{-# INLINE (>.~~!>) #-} +(>.~~!>) = liftm (.~~!>) + +infixl 0 >.~~!> + + +---------------------------------------------------------- +-- Tail operations +---------------------------------------------------------- + +-- | Extract the tail, set the first value +(..~.>) :: + ( Monad m + ) => Variant (a ': l) -> (Variant l -> m a) -> m a +{-# INLINE (..~.>) #-} +(..~.>) v f = makeFlowOp selectTail (applyVM f) combineSingle v + +infixl 0 ..~.> + +-- | Extract the tail, set the first value +(>..~.>) :: + ( Monad m + ) => Flow m (a ': l) -> (Variant l -> m a) -> m a +{-# INLINE (>..~.>) #-} +(>..~.>) = liftm (..~.>) + +infixl 0 >..~.> + +-- | Extract the tail, set the first value (pure function) +(..-.>) :: + ( Monad m + ) => Variant (a ': l) -> (Variant l -> a) -> m a +{-# INLINE (..-.>) #-} +(..-.>) 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) -> (Variant l -> a) -> m a +{-# INLINE (>..-.>) #-} +(>..-.>) = liftm (..-.>) + +infixl 0 >..-.> + +-- | Extract the tail, set the tail +(..-..>) :: forall a l xs m. + ( Monad m + ) => Variant (a ': l) -> (Variant l -> Variant xs) -> Flow m (a ': xs) +{-# INLINE (..-..>) #-} +(..-..>) 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) -> (Variant l -> Variant xs) -> Flow m (a ': xs) +{-# INLINE (>..-..>) #-} +(>..-..>) = liftm (..-..>) + +infixl 0 >..-..> + +-- | Extract the tail, set the tail +(..~..>) :: forall a l xs m. + ( Monad m + ) => Variant (a ': l) -> (Variant l -> Flow m xs) -> Flow m (a ': xs) +{-# INLINE (..~..>) #-} +(..~..>) 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) -> (Variant l -> Flow m xs) -> Flow m (a ': xs) +{-# INLINE (>..~..>) #-} +(>..~..>) = liftm (..~..>) + +infixl 0 >..~..> + +-- | Extract the tail, lift the result +(..~^^>) :: + ( Monad m + , Liftable xs (a ': zs) + ) => Variant (a ': l) -> (Variant l -> Flow m xs) -> Flow m (a ': zs) +{-# INLINE (..~^^>) #-} +(..~^^>) 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 + , Liftable xs (a ': zs) + ) => Flow m (a ': l) -> (Variant l -> Flow m xs) -> Flow m (a ': zs) +{-# INLINE (>..~^^>) #-} +(>..~^^>) = liftm (..~^^>) + +infixl 0 >..~^^> + +-- | Extract the tail, connect the result +(..~^>) :: + ( Monad m + , Member a zs + ) => Variant (a ': l) -> (Variant l -> Flow m zs) -> Flow m zs +{-# INLINE (..~^>) #-} +(..~^>) v f = case popVariantHead v of + Right u -> flowSet u + Left l -> f l + +infixl 0 ..~^> + +-- | Extract the tail, connect the result +(>..~^>) :: + ( Monad m + , Member a zs + ) => Flow m (a ': l) -> (Variant l -> Flow m zs) -> Flow m zs +{-# INLINE (>..~^>) #-} +(>..~^>) = liftm (..~^>) + +infixl 0 >..~^> + +-- | Match in the tail, connect to the expected result +(..?~^>) :: + ( Monad m + , MaybePopable a xs + , Liftable (Filter a xs) ys + ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) +{-# INLINE (..?~^>) #-} +(..?~^>) v f = v ..~..> (\v' -> v' ?~^> f) + +infixl 0 ..?~^> + +-- | Match in the tail, connect to the expected result +(>..?~^>) :: + ( Monad m + , MaybePopable a xs + , Liftable (Filter a xs) ys + ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) +{-# INLINE (>..?~^>) #-} +(>..?~^>) = liftm (..?~^>) + +infixl 0 >..?~^> + +-- | Match in the tail, connect to the expected result +(..%~^>) :: + ( Monad m + , Popable a xs + , Liftable (Filter a xs) ys + ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) +{-# INLINE (..%~^>) #-} +(..%~^>) v f = v ..~..> (\v' -> v' %~^> f) + +infixl 0 ..%~^> + +-- | Match in the tail, connect to the expected result +(>..%~^>) :: + ( Monad m + , Popable a xs + , Liftable (Filter a xs) ys + ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': ys) +{-# INLINE (>..%~^>) #-} +(>..%~^>) = liftm (..%~^>) + +infixl 0 >..%~^> + +-- | Match in the tail, lift to the expected result +(..?~^^>) :: + ( Monad m + , MaybePopable a xs + , Liftable (Filter a xs) zs + , Liftable ys zs + ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs) +{-# INLINE (..?~^^>) #-} +(..?~^^>) v f = v ..~..> (\v' -> v' ?~^^> f) + +infixl 0 ..?~^^> + +-- | Match in the tail, lift to the expected result +(>..?~^^>) :: + ( Monad m + , MaybePopable a xs + , Liftable (Filter a xs) zs + , Liftable ys zs + ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs) +{-# INLINE (>..?~^^>) #-} +(>..?~^^>) = liftm (..?~^^>) + +infixl 0 >..?~^^> + +-- | Match in the tail, lift to the expected result +(..%~^^>) :: + ( Monad m + , Popable a xs + , Liftable (Filter a xs) zs + , Liftable ys zs + ) => Variant (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs) +{-# INLINE (..%~^^>) #-} +(..%~^^>) v f = v ..~..> (\v' -> v' %~^^> f) + +infixl 0 ..%~^^> + +-- | Match in the tail, lift to the expected result +(>..%~^^>) :: + ( Monad m + , Popable a xs + , Liftable (Filter a xs) zs + , Liftable ys zs + ) => Flow m (x ': xs) -> (a -> Flow m ys) -> Flow m (x ': zs) +{-# INLINE (>..%~^^>) #-} +(>..%~^^>) = liftm (..%~^^>) + +infixl 0 >..%~^^> + +-- | Match in the tail, keep the same types +(..?~$>) :: + ( Monad m + , MaybePopable a xs + , Liftable (Filter a xs) (x ': xs) + ) => Variant (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) +{-# INLINE (..?~$>) #-} +(..?~$>) 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 + , MaybePopable a xs + , Liftable (Filter a xs) (x ': xs) + ) => Flow m (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) +{-# INLINE (>..?~$>) #-} +(>..?~$>) = liftm (..?~$>) + +infixl 0 >..?~$> + +-- | Match in the tail, keep the same types +(..%~$>) :: + ( Monad m + , Popable a xs + , Liftable (Filter a xs) (x ': xs) + ) => Variant (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) +{-# INLINE (..%~$>) #-} +(..%~$>) 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 + , Popable a xs + , Liftable (Filter a xs) (x ': xs) + ) => Flow m (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs) +{-# INLINE (>..%~$>) #-} +(>..%~$>) = liftm (..%~$>) + +infixl 0 >..%~$> + + +-- | Extract the tail and perform an effect. Passthrough the input value +(..~=>) :: + ( Monad m + ) => Variant (x ': xs) -> (Variant xs -> m ()) -> Flow m (x ': xs) +{-# INLINE (..~=>) #-} +(..~=>) 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) -> (Variant xs -> m ()) -> Flow m (x ': xs) +{-# INLINE (>..~=>) #-} +(>..~=>) = liftm (..~=>) + +infixl 0 >..~=> + +-- | Extract the tail and perform an effect +(..~!>) :: + ( Monad m + ) => Variant (x ': xs) -> (Variant xs -> m ()) -> m () +{-# INLINE (..~!>) #-} +(..~!>) 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) -> (Variant xs -> m ()) -> m () +{-# INLINE (>..~!>) #-} +(>..~!>) = liftm (..~!>) + +infixl 0 >..~!> + +-- | Extract the tail and perform an effect +(..~!!>) :: + ( Monad m + ) => Variant (x ': xs) -> (Variant xs -> m ()) -> m x +{-# INLINE (..~!!>) #-} +(..~!!>) 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) -> (Variant xs -> m ()) -> m x +{-# INLINE (>..~!!>) #-} +(>..~!!>) = liftm (..~!!>) + +infixl 0 >..~!!> + +-- | Match in the tail and perform an effect +(..?~!!>) :: + ( Monad m + , MaybePopable y xs + ) => Variant (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) +{-# INLINE (..?~!!>) #-} +(..?~!!>) v f = v ..~..> (\xs -> xs ?~!!> f) + +infixl 0 ..?~!!> + +-- | Match in the tail and perform an effect +(>..?~!!>) :: + ( Monad m + , MaybePopable y xs + ) => Flow m (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) +{-# INLINE (>..?~!!>) #-} +(>..?~!!>) = liftm (..?~!!>) + +infixl 0 >..?~!!> + +-- | Match in the tail and perform an effect +(..%~!!>) :: + ( Monad m + , Popable y xs + ) => Variant (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) +{-# INLINE (..%~!!>) #-} +(..%~!!>) v f = v ..~..> (\xs -> xs %~!!> f) + +infixl 0 ..%~!!> + +-- | Match in the tail and perform an effect +(>..%~!!>) :: + ( Monad m + , Popable y xs + ) => Flow m (x ': xs) -> (y -> m ()) -> Flow m (x ': Filter y xs) +{-# INLINE (>..%~!!>) #-} +(>..%~!!>) = liftm (..%~!!>) + +infixl 0 >..%~!!> + +-- | Match in the tail and perform an effect +(..?~!>) :: + ( Monad m + , MaybePopable y xs + ) => Variant (x ': xs) -> (y -> m ()) -> m () +{-# INLINE (..?~!>) #-} +(..?~!>) v f = case popVariantHead v of + Right _ -> return () + Left xs -> xs ?~!> f + +infixl 0 ..?~!> + +-- | Match in the tail and perform an effect +(>..?~!>) :: + ( Monad m + , MaybePopable y xs + ) => Flow m (x ': xs) -> (y -> m ()) -> m () +{-# INLINE (>..?~!>) #-} +(>..?~!>) = liftm (..?~!>) + +infixl 0 >..?~!> + +-- | Match in the tail and perform an effect +(..%~!>) :: + ( Monad m + , Popable y xs + ) => Variant (x ': xs) -> (y -> m ()) -> m () +{-# INLINE (..%~!>) #-} +(..%~!>) v f = case popVariantHead v of + Right _ -> return () + Left xs -> xs %~!> f + +infixl 0 ..%~!> + +-- | Match in the tail and perform an effect +(>..%~!>) :: + ( Monad m + , Popable y xs + ) => Flow m (x ': xs) -> (y -> m ()) -> m () +{-# INLINE (>..%~!>) #-} +(>..%~!>) = liftm (..%~!>) + +infixl 0 >..%~!> + +---------------------------------------------------------- +-- Caught element operations +---------------------------------------------------------- + +-- | Pop element, set the first value +(?~.>) :: forall x xs y ys m. + ( ys ~ Filter x xs + , Monad m + , MaybePopable x xs + ) => Variant xs -> (x -> m y) -> Flow m (y ': ys) +{-# INLINE (?~.>) #-} +(?~.>) 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 ~ Filter x xs + , Monad m + , MaybePopable x xs + ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys) +{-# INLINE (>?~.>) #-} +(>?~.>) = liftm (?~.>) + +infixl 0 >?~.> + +-- | Pop element, set the first value +(%~.>) :: forall x xs y ys m. + ( ys ~ Filter x xs + , Monad m + , Popable x xs + ) => Variant xs -> (x -> m y) -> Flow m (y ': ys) +{-# INLINE (%~.>) #-} +(%~.>) = (?~.>) + +infixl 0 %~.> + +-- | Pop element, set the first value +(>%~.>) :: + ( ys ~ Filter x xs + , Monad m + , Popable x xs + ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys) +{-# INLINE (>%~.>) #-} +(>%~.>) = liftm (%~.>) + +infixl 0 >%~.> + +-- | Pop element, concat the result +(?~+>) :: forall x xs ys m. + ( Monad m + , MaybePopable x xs + , KnownNat (Length ys) + ) => Variant xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) +{-# INLINE (?~+>) #-} +(?~+>) v f = case popVariantMaybe v of + Right x -> appendVariant @(Filter x xs) <$> f x + Left ys -> prependVariant @ys <$> return ys + +infixl 0 ?~+> + +-- | Pop element, concat the result +(>?~+>) :: forall x xs ys m. + ( Monad m + , MaybePopable x xs + , KnownNat (Length ys) + ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) +{-# INLINE (>?~+>) #-} +(>?~+>) = liftm (?~+>) + +infixl 0 >?~+> + +-- | Pop element, concat the result +(%~+>) :: forall x xs ys m. + ( Monad m + , Popable x xs + , KnownNat (Length ys) + ) => Variant xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) +{-# INLINE (%~+>) #-} +(%~+>) = (?~+>) + +infixl 0 %~+> + +-- | Pop element, concat the result +(>%~+>) :: forall x xs ys m. + ( Monad m + , Popable x xs + , KnownNat (Length ys) + ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs)) +{-# INLINE (>%~+>) #-} +(>%~+>) = liftm (%~+>) + +infixl 0 >%~+> + +-- | Pop element, lift the result +(?~^^>) :: forall x xs ys zs m. + ( Monad m + , MaybePopable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + ) => Variant xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (?~^^>) #-} +(?~^^>) 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 + , MaybePopable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (>?~^^>) #-} +(>?~^^>) = liftm (?~^^>) + +infixl 0 >?~^^> + +-- | Pop element, lift the result +(%~^^>) :: forall x xs ys zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + ) => Variant xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (%~^^>) #-} +(%~^^>) = (?~^^>) + +infixl 0 %~^^> + +-- | Pop element, lift the result +(>%~^^>) :: forall x xs ys zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (>%~^^>) #-} +(>%~^^>) = liftm (%~^^>) + +infixl 0 >%~^^> + +-- | Pop element, connect to the expected output +(?~^>) :: forall x xs zs m. + ( Monad m + , MaybePopable x xs + , Liftable (Filter x xs) zs + ) => Variant xs -> (x -> Flow m zs) -> Flow m zs +{-# INLINE (?~^>) #-} +(?~^>) 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 + , MaybePopable x xs + , Liftable (Filter x xs) zs + ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs +{-# INLINE (>?~^>) #-} +(>?~^>) = liftm (?~^>) + +infixl 0 >?~^> + +-- | Pop element, connect to the expected output +(%~^>) :: forall x xs zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + ) => Variant xs -> (x -> Flow m zs) -> Flow m zs +{-# INLINE (%~^>) #-} +(%~^>) = (?~^>) + +infixl 0 %~^> + +-- | Pop element, connect to the expected output +(>%~^>) :: forall x xs zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs +{-# INLINE (>%~^>) #-} +(>%~^>) = liftm (%~^>) + +infixl 0 >%~^> + +-- | Pop element, use the same output type +(?~$>) :: forall x xs m. + ( Monad m + , MaybePopable x xs + ) => Variant xs -> (x -> Flow m xs) -> Flow m xs +{-# INLINE (?~$>) #-} +(?~$>) 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 + , MaybePopable x xs + ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs +{-# INLINE (>?~$>) #-} +(>?~$>) = liftm (?~$>) + +infixl 0 >?~$> + +-- | Pop element, use the same output type +(%~$>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Variant xs -> (x -> Flow m xs) -> Flow m xs +{-# INLINE (%~$>) #-} +(%~$>) = (?~$>) + +infixl 0 %~$> + +-- | Pop element, use the same output type +(>%~$>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs +{-# INLINE (>%~$>) #-} +(>%~$>) = liftm (%~$>) + +infixl 0 >%~$> + +-- | Pop element, fusion the result +(?~|>) :: forall x xs ys zs m. + ( Monad m + , MaybePopable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + , zs ~ Union (Filter x xs) ys + ) => Variant xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (?~|>) #-} +(?~|>) 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 + , MaybePopable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + , zs ~ Union (Filter x xs) ys + ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (>?~|>) #-} +(>?~|>) = liftm (?~|>) + +infixl 0 >?~|> + +-- | Pop element, fusion the result +(%~|>) :: forall x xs ys zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + , zs ~ Union (Filter x xs) ys + ) => Variant xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (%~|>) #-} +(%~|>) = (?~|>) + +infixl 0 %~|> + +-- | Pop element, fusion the result +(>%~|>) :: forall x xs ys zs m. + ( Monad m + , Popable x xs + , Liftable (Filter x xs) zs + , Liftable ys zs + , zs ~ Union (Filter x xs) ys + ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs +{-# INLINE (>%~|>) #-} +(>%~|>) = liftm (%~|>) + +infixl 0 >%~|> + +-- | Pop element and perform effect. Passthrough the input value. +(?~=>) :: forall x xs m. + ( Monad m + , MaybePopable x xs + ) => Variant xs -> (x -> m ()) -> Flow m xs +{-# INLINE (?~=>) #-} +(?~=>) 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 + , MaybePopable x xs + ) => Flow m xs -> (x -> m ()) -> Flow m xs +{-# INLINE (>?~=>) #-} +(>?~=>) = liftm (?~=>) + +infixl 0 >?~=> + +-- | Pop element and perform effect. Passthrough the input value. +(%~=>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Variant xs -> (x -> m ()) -> Flow m xs +{-# INLINE (%~=>) #-} +(%~=>) = (?~=>) + +infixl 0 %~=> + +-- | Pop element and perform effect. Passthrough the input value. +(>%~=>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Flow m xs -> (x -> m ()) -> Flow m xs +{-# INLINE (>%~=>) #-} +(>%~=>) = liftm (%~=>) + +infixl 0 >%~=> + +-- | Pop element and perform effect. +(?~!>) :: forall x xs m. + ( Monad m + , MaybePopable x xs + ) => Variant xs -> (x -> m ()) -> m () +{-# INLINE (?~!>) #-} +(?~!>) 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 + , MaybePopable x xs + ) => Flow m xs -> (x -> m ()) -> m () +{-# INLINE (>?~!>) #-} +(>?~!>) = liftm (?~!>) + +infixl 0 >?~!> + +-- | Pop element and perform effect. +(%~!>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Variant xs -> (x -> m ()) -> m () +{-# INLINE (%~!>) #-} +(%~!>) = (?~!>) + +infixl 0 %~!> + +-- | Pop element and perform effect. +(>%~!>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Flow m xs -> (x -> m ()) -> m () +{-# INLINE (>%~!>) #-} +(>%~!>) = liftm (%~!>) + +infixl 0 >%~!> + +-- | Pop element and perform effect. +(?~!!>) :: forall x xs m. + ( Monad m + , MaybePopable x xs + ) => Variant xs -> (x -> m ()) -> Flow m (Filter x xs) +{-# INLINE (?~!!>) #-} +(?~!!>) 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 + , MaybePopable x xs + ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs) +{-# INLINE (>?~!!>) #-} +(>?~!!>) = liftm (?~!!>) + +infixl 0 >?~!!> + +-- | Pop element and perform effect. +(%~!!>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Variant xs -> (x -> m ()) -> Flow m (Filter x xs) +{-# INLINE (%~!!>) #-} +(%~!!>) = (?~!!>) + +infixl 0 %~!!> + +-- | Pop element and perform effect. +(>%~!!>) :: forall x xs m. + ( Monad m + , Popable x xs + ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs) +{-# INLINE (>%~!!>) #-} +(>%~!!>) = liftm (%~!!>) + +infixl 0 >%~!!> + +-------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------- + + +-- | Make a flow operator +makeFlowOp :: Monad m => + (Variant as -> Either (Variant bs) (Variant cs)) + -> (Variant cs -> Flow m ds) + -> (Either (Variant bs) (Variant ds) -> es) + -> Variant as -> m es +{-# INLINE makeFlowOp #-} +makeFlowOp select apply combine v = combine <$> traverse apply (select v) + +-- | Make a flow operator +makeFlowOpM :: Monad m => + (Variant as -> Either (Variant bs) (Variant cs)) + -> (Variant cs -> Flow m ds) + -> (Either (Variant bs) (Variant ds) -> es) + -> Flow m as -> m es +{-# INLINE makeFlowOpM #-} +makeFlowOpM select apply combine v = v >>= makeFlowOp select apply combine + + +-- | Select the first value +selectFirst :: Variant (x ': xs) -> Either (Variant xs) (Variant '[x]) +{-# INLINE selectFirst #-} +selectFirst = fmap (toVariantAt @0) . popVariantHead + +-- | Select the tail +selectTail :: Variant (x ': xs) -> Either (Variant '[x]) (Variant xs) +{-# INLINE selectTail #-} +selectTail = flipEither . selectFirst + where + flipEither (Left x) = Right x + flipEither (Right x) = Left x + +-- | Select by type +selectType :: + ( Popable x xs + ) => Variant xs -> Either (Variant (Filter x xs)) (Variant '[x]) +{-# INLINE selectType #-} +selectType = fmap (toVariantAt @0) . popVariant + +-- | Const application +applyConst :: Flow m ys -> (Variant xs -> Flow m ys) +{-# INLINE applyConst #-} +applyConst = const + +-- | Pure application +applyPure :: Monad m => (Variant xs -> Variant ys) -> Variant xs -> Flow m ys +{-# INLINE applyPure #-} +applyPure f = return . f + +-- | Lift a monadic function +applyM :: Monad m => (a -> m b) -> Variant '[a] -> Flow m '[b] +{-# INLINE applyM #-} +applyM = liftF + +-- | Lift a monadic function +applyVM :: Monad m => (Variant a -> m b) -> Variant a -> Flow m '[b] +{-# INLINE applyVM #-} +applyVM f = fmap (toVariantAt @0) . f + +-- | Lift a monadic function +applyF :: (a -> Flow m b) -> Variant '[a] -> Flow m b +{-# INLINE applyF #-} +applyF f = f . variantToValue + +-- | Set the first value (the "correct" one) +combineFirst :: forall x xs. Either (Variant xs) (Variant '[x]) -> Variant (x ': xs) +{-# INLINE 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 (Variant xs) (Variant (x ': xs)) -> Variant (x ': xs) +{-# INLINE combineSameTail #-} +combineSameTail = \case + Right x -> x + Left xs -> prependVariant @'[x] xs + +-- | Return the valid variant unmodified +combineEither :: Either (Variant xs) (Variant xs) -> Variant xs +{-# INLINE combineEither #-} +combineEither = \case + Right x -> x + Left x -> x + +-- | Concatenate unselected values +combineConcat :: forall xs ys. + ( KnownNat (Length xs) + ) => Either (Variant ys) (Variant xs) -> Variant (Concat xs ys) +{-# INLINE combineConcat #-} +combineConcat = \case + Right xs -> appendVariant @ys xs + Left ys -> prependVariant @xs ys + +-- | Union +combineUnion :: + ( Liftable xs (Union xs ys) + , Liftable ys (Union xs ys) + ) => Either (Variant ys) (Variant xs) -> Variant (Union xs ys) +{-# INLINE combineUnion #-} +combineUnion = \case + Right xs -> liftVariant xs + Left ys -> liftVariant ys + +-- | Lift unselected +combineLiftUnselected :: + ( Liftable ys xs + ) => Either (Variant ys) (Variant xs) -> Variant xs +{-# INLINE combineLiftUnselected #-} +combineLiftUnselected = \case + Right xs -> xs + Left ys -> liftVariant ys + +-- | Lift both +combineLiftBoth :: + ( Liftable ys zs + , Liftable xs zs + ) => Either (Variant ys) (Variant xs) -> Variant zs +{-# INLINE combineLiftBoth #-} +combineLiftBoth = \case + Right xs -> liftVariant xs + Left ys -> liftVariant ys + +-- | Single value +combineSingle :: Either (Variant '[x]) (Variant '[x]) -> x +{-# INLINE combineSingle #-} +combineSingle = \case + Right x -> variantToValue x + Left x -> variantToValue x + + +-- | Lift a pure function into a Variant to Variant function +liftV :: (a -> b) -> Variant '[a] -> Variant '[b] +liftV = updateVariantAt @0 + +-- | Lift a function into a Flow +liftF :: Monad m => (a -> m b) -> Variant '[a] -> Flow m '[b] +liftF = updateVariantFirstM @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) (Variant (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 (Variant zs) + , ContVariant xs + ) => Variant xs -> fs -> Variant 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 (Variant zs) + , ContVariant xs + , ks ~ ExtractMonad m zs + , Applicative m + ) => Variant 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 (Variant zs) + , ContVariant xs + , ks ~ ExtractMonad m zs + , Monad m + ) => 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 (Variant zs) + , ContVariant xs + , ys ~ FlattenVariant zs + , Flattenable (Variant zs) (Variant ys) + , Liftable ys (Nub ys) + , rs ~ Nub ys + ) => Variant xs -> fs -> Variant 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 (Variant zs) + , ks ~ ExtractMonad m zs + , ys ~ FlattenVariant ks + , Flattenable (Variant ks) (Variant ys) + , rs ~ Nub ys + , Liftable ys rs + , Applicative m + ) => Variant 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 (Variant zs) + , ks ~ ExtractMonad m zs + , ys ~ FlattenVariant ks + , Flattenable (Variant ks) (Variant ys) + , rs ~ Nub ys + , Liftable ys rs + , Monad m + ) => Flow m xs -> fs -> Flow m rs +(>~||>) act fs = do + r <- act + r ~||> fs