diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,8 @@ +0.9.0.0 - TBA +============= + + +0.8.0.0 - 2018-02-21 +==================== + +* Enhanced Variant API diff --git a/haskus-utils.cabal b/haskus-utils.cabal --- a/haskus-utils.cabal +++ b/haskus-utils.cabal @@ -1,6 +1,6 @@ name: haskus-utils -version: 0.8.0.0 -cabal-version: >=1.20 +version: 1.0 +cabal-version: >=1.21 build-type: Simple license: BSD3 license-file: LICENSE @@ -9,9 +9,11 @@ homepage: http://www.haskus.org/system synopsis: Haskus utility modules description: - Various utility modules used by Haskus packages. + Haskus utility modules. Reexport all other utility modules category: System author: Sylvain Henry +extra-source-files: + CHANGES source-repository head type: git @@ -20,22 +22,11 @@ library exposed-modules: Haskus.Utils.Solver - Haskus.Utils.ContFlow - Haskus.Utils.Variant - Haskus.Utils.Monad Haskus.Utils.Parser Haskus.Utils.HArray - Haskus.Utils.Flow Haskus.Utils.MultiState - Haskus.Utils.HList Haskus.Utils.Embed - Haskus.Utils.List - Haskus.Utils.Map - Haskus.Utils.Map.Strict - Haskus.Utils.Maybe - Haskus.Utils.Types - Haskus.Utils.Types.List - Haskus.Utils.Types.Generics + Haskus.Utils.Flow Haskus.Utils.STM Haskus.Utils.STM.TEq Haskus.Utils.STM.TMap @@ -44,9 +35,27 @@ Haskus.Utils.STM.TTree Haskus.Utils.STM.Future Haskus.Utils.STM.TGraph - Haskus.Utils.Tuple + reexported-modules: Haskus.Utils.Types, + Haskus.Utils.Types.Generics, + Haskus.Utils.Types.List, + Haskus.Utils.Monad, + Haskus.Utils.HList, + Haskus.Utils.Functor, + Haskus.Utils.List, + Haskus.Utils.Map, + Haskus.Utils.Map.Strict, + Haskus.Utils.Maybe, + Haskus.Utils.Tuple, + Haskus.Utils.ContFlow, + Haskus.Utils.Variant, + Haskus.Utils.Variant.Flow, + Haskus.Utils.Variant.Cont, + Haskus.Utils.EADT build-depends: - base >=4.9 && <4.11, + base >=4.9 && <4.12, + haskus-utils-types ==1.0.*, + haskus-utils-data ==1.0.*, + haskus-utils-variant ==1.0.*, containers ==0.5.*, list-t >=0.4 && <1.1, stm ==2.4.*, @@ -54,9 +63,10 @@ vector >=0.11 && <0.13, transformers >=0.4 && <0.6, mtl ==2.2.*, - template-haskell >=2.10 && <2.13, + template-haskell >=2.10 && <2.14, file-embed >=0.0.10 && <0.1, - extra >=1.4 && <1.7 + extra >=1.4 && <1.7, + recursion-schemes ==5.0.* default-language: Haskell2010 hs-source-dirs: src/lib ghc-options: -Wall @@ -65,10 +75,10 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - base >=4.10.1.0 && <4.11, + base >=4.11.1.0 && <4.12, haskus-utils -any, - tasty ==0.11.*, - tasty-quickcheck >=0.8 && <0.10 + tasty >=0.11 && <1.2, + tasty-quickcheck >=0.8 && <0.11 default-language: Haskell2010 hs-source-dirs: src/tests other-modules: diff --git a/src/lib/Haskus/Utils/ContFlow.hs b/src/lib/Haskus/Utils/ContFlow.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/ContFlow.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE BangPatterns #-} - --- | Continuation based control-flow -module Haskus.Utils.ContFlow - ( ContFlow (..) - , (>::>) - , (>:-:>) - , (>:%:>) - , fret - , fretN - , freturn - , freturnN - , frec - , ContListToTuple - , ContTupleToList - , StripR - , AddR - -- * Control-flow - , fIf - , Then (..) - , Else (..) - ) -where - -import Haskus.Utils.Tuple -import Haskus.Utils.Types -import Haskus.Utils.Types.List - --- this define has to be defined in each module using ContFlow for now -#define fdo ContFlow $ \__cs -> let ?__cs = __cs in do - --- | 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 >:%:> - --- | 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/Flow.hs b/src/lib/Haskus/Utils/Flow.hs --- a/src/lib/Haskus/Utils/Flow.hs +++ b/src/lib/Haskus/Utils/Flow.hs @@ -1,1780 +1,69 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - --- | First-class control-flow (based on Variant) -module Haskus.Utils.Flow - ( Flow - , IOV - , MonadIO (..) - , MonadInIO (..) - -- * Flow utils - , flowRes - , flowSingle - , flowSetN - , flowSet - , flowLift - , flowToCont - , flowTraverse - , flowFor - , flowTraverseFilter - , flowForFilter - , Liftable - , Popable - , MaybePopable - -- * Non-variant single operations - , (|>) - , (<|) - , (||>) - , (<||) - -- * Monadic/applicative operators - , when - , unless - , whenM - , unlessM - , ifM - , guard - , void - , forever - , foldM - , foldM_ - , forM - , forM_ - , mapM - , mapM_ - , sequence - , replicateM - , replicateM_ - , filterM - , join - , (<=<) - , (>=>) - , loopM - , whileM - -- * Named operators - , flowMap - , flowBind - , flowBind' - , flowMatch - , flowMatchFail - -- * First element operations - , (.~.>) - , (>.~.>) - , (.~+>) - , (>.~+>) - , (.~^^>) - , (>.~^^>) - , (.~^>) - , (>.~^>) - , (.~$>) - , (>.~$>) - , (.~|>) - , (>.~|>) - , (.~=>) - , (>.~=>) - , (.~!>) - , (>.~!>) - , (.~!!>) - , (>.~!!>) - -- * First element, pure variant - , (.-.>) - , (>.-.>) - , (<.-.) - , (<.-.<) - -- * Functor, applicative equivalents - , (<$<) - , (<*<) - , (<|<) - -- * First element, const variant - , (.~~.>) - , (>.~~.>) - , (.~~+>) - , (>.~~+>) - , (.~~^^>) - , (>.~~^^>) - , (.~~^>) - , (>.~~^>) - , (.~~$>) - , (>.~~$>) - , (.~~|>) - , (>.~~|>) - , (.~~=>) - , (>.~~=>) - , (.~~!>) - , (>.~~!>) - -- * Tail operations - , (..~.>) - , (>..~.>) - , (..-.>) - , (>..-.>) - , (..-..>) - , (>..-..>) - , (..~..>) - , (>..~..>) - , (..~^^>) - , (>..~^^>) - , (..~^>) - , (>..~^>) - , (..~=>) - , (>..~=>) - , (..~!>) - , (>..~!>) - , (..~!!>) - , (>..~!!>) - -- * Tail pop operations - , (..%~^>) - , (>..%~^>) - , (..%~^^>) - , (>..%~^^>) - , (..%~$>) - , (>..%~$>) - , (..%~!!>) - , (>..%~!!>) - , (..%~!>) - , (>..%~!>) - , (..?~^>) - , (>..?~^>) - , (..?~^^>) - , (>..?~^^>) - , (..?~$>) - , (>..?~$>) - , (..?~!!>) - , (>..?~!!>) - , (..?~!>) - , (>..?~!>) - -- * Caught element operations - , (%~.>) - , (>%~.>) - , (%~+>) - , (>%~+>) - , (%~^^>) - , (>%~^^>) - , (%~^>) - , (>%~^>) - , (%~$>) - , (>%~$>) - , (%~|>) - , (>%~|>) - , (%~=>) - , (>%~=>) - , (%~!>) - , (>%~!>) - , (%~!!>) - , (>%~!!>) - , (?~.>) - , (>?~.>) - , (?~+>) - , (>?~+>) - , (?~^^>) - , (>?~^^>) - , (?~^>) - , (>?~^>) - , (?~$>) - , (>?~$>) - , (?~|>) - , (>?~|>) - , (?~=>) - , (>?~=>) - , (?~!>) - , (>?~!>) - , (?~!!>) - , (>?~!!>) - -- * 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.Monad -import Haskus.Utils.ContFlow - --- | 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 - ----------------------------------------------------------- --- Single element not wrapped into a variant ----------------------------------------------------------- - --- | Apply a function -(|>) :: a -> (a -> b) -> b -{-# INLINE (|>) #-} -x |> f = f x - -infixl 0 |> - --- | Apply a function -(<|) :: (a -> b) -> a -> b -{-# INLINE (<|) #-} -f <| x = f x - -infixr 0 <| - --- | Apply a function in a Functor -(||>) :: Functor f => f a -> (a -> b) -> f b -{-# INLINE (||>) #-} -x ||> f = fmap f x - -infixl 0 ||> - --- | Apply a function in a Functor -(<||) :: Functor f => (a -> b) -> f a -> f b -{-# INLINE (<||) #-} -f <|| x = fmap f x - -infixr 0 <|| - ----------------------------------------------------------- --- 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 +-- | Control-flow +module Haskus.Utils.Flow + ( MonadIO (..) + , MonadInIO (..) + -- * Basic operators + , (|>) + , (<|) + , (||>) + , (<||) + -- * Monadic/applicative operators + , when + , unless + , whenM + , unlessM + , ifM + , guard + , void + , forever + , foldM + , foldM_ + , forM + , forM_ + , mapM + , mapM_ + , sequence + , replicateM + , replicateM_ + , filterM + , join + , (<=<) + , (>=>) + , loopM + , whileM + -- * Variant based operators + , module Haskus.Utils.Variant.Flow + ) +where + +import Haskus.Utils.Variant +import Haskus.Utils.Variant.Flow +import Haskus.Utils.Monad + +-- | Apply a function +(|>) :: a -> (a -> b) -> b +{-# INLINE (|>) #-} +x |> f = f x + +infixl 0 |> + +-- | Apply a function +(<|) :: (a -> b) -> a -> b +{-# INLINE (<|) #-} +f <| x = f x + +infixr 0 <| + +-- | Apply a function in a Functor +(||>) :: Functor f => f a -> (a -> b) -> f b +{-# INLINE (||>) #-} +x ||> f = fmap f x + +infixl 0 ||> + +-- | Apply a function in a Functor +(<||) :: Functor f => (a -> b) -> f a -> f b +{-# INLINE (<||) #-} +f <|| x = fmap f x + +infixr 0 <|| diff --git a/src/lib/Haskus/Utils/HList.hs b/src/lib/Haskus/Utils/HList.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/HList.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | Heterogeneous list utils -module Haskus.Utils.HList - ( HList (..) - , hHead - , hTail - , hLength - , hAppend - , HFoldr' (..) - , HFoldl' (..) - , HTuple' (..) - , Apply (..) - , HZipList - , hZipList - , HFoldr - , hFoldr - , HFoldl - , hFoldl - , HReverse (..) - ) -where - -import Haskus.Utils.Tuple -import Haskus.Utils.Types -import Haskus.Utils.Types.List - --- | Heterogeneous list -data family HList (l :: [*]) -data instance HList '[] = HNil -data instance HList (x ': xs) = x `HCons` HList xs - -infixr 2 `HCons` - -deriving instance Eq (HList '[]) -deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) - -deriving instance Ord (HList '[]) -deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs)) - - -instance Show (HList '[]) where - show _ = "H[]" - -instance (Show e, Show (HList l)) => Show (HList (e ': l)) where - show (HCons x l) = let 'H':'[':s = show l - in "H[" ++ show x ++ - (if s == "]" then s else "," ++ s) - --- | Head -hHead :: HList (e ': l) -> e -hHead (HCons x _) = x - --- | Tail -hTail :: HList (e ': l) -> HList l -hTail (HCons _ l) = l - --- | Length -hLength :: forall xs. (KnownNat (Length xs)) => HList xs -> Word -hLength _ = natValue' @(Length xs) - -class HAppendList l1 l2 where - hAppend :: HList l1 -> HList l2 -> HList (Concat l1 l2) - -instance HAppendList '[] l2 where - hAppend HNil l = l - -instance HAppendList l l' => HAppendList (x ': l) l' where - hAppend (HCons x l) l' = HCons x (hAppend l l') - - --- | Apply the function identified by the data type f from type a to type b. -class Apply f a b where - apply :: f -> a -> b - --------------------------------------- --- Folding --------------------------------------- - -class HFoldr f v (l :: [*]) r where - hFoldr :: f -> v -> HList l -> r - -instance (v ~ v') => HFoldr f v '[] v' where - hFoldr _ v _ = v - -instance - ( Apply f (e, r) r' - , HFoldr f v l r - ) => HFoldr f v (e ': l) r' - where - hFoldr f v (HCons x l) = apply f (x, hFoldr f v l :: r) - - --- | Like HFoldr but only use types, not values! --- --- It allows us to foldr over a list of types, without any associated hlist of --- values. -class HFoldr' f v (l :: [*]) r where - hFoldr' :: f -> v -> HList l -> r - -instance (v ~ v') => HFoldr' f v '[] v' where - hFoldr' _ v _ = v - -instance - ( Apply f (e, r) r' - , HFoldr' f v l r - ) => HFoldr' f v (e ': l) r' - where - -- compared to hFoldr, we pass undefined values instead of the values - -- supposedly in the list (we don't have a real list associated to HList l) - hFoldr' f v _ = apply f (undefined :: e, hFoldr' f v (undefined :: HList l) :: r) - -class HFoldl f (z :: *) xs (r :: *) where - hFoldl :: f -> z -> HList xs -> r - -instance forall f z z' r x zx xs. - ( zx ~ (z,x) - , Apply f zx z' - , HFoldl f z' xs r - ) => HFoldl f z (x ': xs) r - where - hFoldl f z (x `HCons` xs) = hFoldl f (apply f (z,x) :: z') xs - -instance (z ~ z') => HFoldl f z '[] z' where - hFoldl _ z _ = z - --- | Like HFoldl but only use types, not values! --- --- It allows us to foldr over a list of types, without any associated hlist of --- values. -class HFoldl' f (z :: *) xs (r :: *) where - hFoldl' :: f -> z -> HList xs -> r - -instance forall f z z' r x zx xs. - ( zx ~ (z,x) - , Apply f zx z' - , HFoldl' f z' xs r - ) => HFoldl' f z (x ': xs) r - where - hFoldl' f z (_ `HCons` xs) = hFoldl' f (apply f (z,(undefined :: x)) :: z') xs - -instance (z ~ z') => HFoldl' f z '[] z' where - hFoldl' _ z _ = z - - - -class HZipList x y l | x y -> l, l -> x y where - hZipList :: HList x -> HList y -> HList l - hUnzipList :: HList l -> (HList x, HList y) - -instance HZipList '[] '[] '[] where - hZipList _ _ = HNil - hUnzipList _ = (HNil, HNil) - -instance ((x,y)~z, HZipList xs ys zs) => HZipList (x ': xs) (y ': ys) (z ': zs) where - hZipList (HCons x xs) (HCons y ys) = (x,y) `HCons` hZipList xs ys - hUnzipList (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzipList zs in (x `HCons` xs, y `HCons` ys) - - -class HRevApp l1 l2 l3 | l1 l2 -> l3 where - hRevApp :: HList l1 -> HList l2 -> HList l3 - -instance HRevApp '[] l2 l2 where - hRevApp _ l = l - -instance HRevApp l (x ': l') z => HRevApp (x ': l) l' z where - hRevApp (HCons x l) l' = hRevApp l (HCons x l') - - - -class HReverse xs sx | xs -> sx, sx -> xs where - hReverse :: HList xs -> HList sx - -instance - ( HRevApp xs '[] sx - , HRevApp sx '[] xs - ) => HReverse xs sx - where - hReverse l = hRevApp l HNil - - --------------------------------------- --- Tuple convertion --------------------------------------- - --- * Conversion to and from tuples - --- | Convert between hlists and tuples -class HTuple' v t | v -> t, t -> v where - -- | Convert an heterogeneous list into a tuple - hToTuple' :: HList v -> t - - -- | Convert a tuple into an heterogeneous list - hFromTuple' :: t -> HList v - - -instance HTuple' '[] () where - hToTuple' HNil = () - hFromTuple' () = HNil - -instance HTuple' '[a] (Single a) where - hToTuple' (a `HCons` HNil) = Single a - hFromTuple' (Single a) = a `HCons` HNil - -instance HTuple' '[a,b] (a,b) where - hToTuple' (a `HCons` b `HCons` HNil) = (a,b) - hFromTuple' (a,b) = a `HCons` b `HCons` HNil - -instance HTuple' '[a,b,c] (a,b,c) where - hToTuple' (a `HCons` b `HCons` c `HCons` HNil) = (a,b,c) - hFromTuple' (a,b,c) = a `HCons` b `HCons` c `HCons` HNil - -instance HTuple' '[a,b,c,d] (a,b,c,d) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a,b,c,d) - hFromTuple' (a,b,c,d) = a `HCons` b `HCons` c `HCons` d `HCons` HNil - -instance HTuple' '[a,b,c,d,e] (a,b,c,d,e) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) = (a,b,c,d,e) - hFromTuple' (a,b,c,d,e) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil - -instance HTuple' '[a,b,c,d,e,f] (a,b,c,d,e,f) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a,b,c,d,e,f) - hFromTuple' (a,b,c,d,e,f) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil - -instance HTuple' '[a,b,c,d,e,f,g] (a,b,c,d,e,f,g) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` HNil) = (a,b,c,d,e,f,g) - hFromTuple' (a,b,c,d,e,f,g) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` HNil - -instance HTuple' '[a,b,c,d,e,f,g,h] (a,b,c,d,e,f,g,h) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` HNil) = (a,b,c,d,e,f,g,h) - hFromTuple' (a,b,c,d,e,f,g,h) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` HNil - -instance HTuple' '[a,b,c,d,e,f,g,h,i] (a,b,c,d,e,f,g,h,i) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` HNil) = (a,b,c,d,e,f,g,h,i) - hFromTuple' (a,b,c,d,e,f,g,h,i) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` HNil - -instance HTuple' '[a,b,c,d,e,f,g,h,i,j] (a,b,c,d,e,f,g,h,i,j) where - hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` HNil) = (a,b,c,d,e,f,g,h,i,j) - hFromTuple' (a,b,c,d,e,f,g,h,i,j) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` HNil diff --git a/src/lib/Haskus/Utils/List.hs b/src/lib/Haskus/Utils/List.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/List.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Haskus.Utils.List - ( checkLength - , module Data.List - , module Data.List.Extra - ) -where - -import Data.List -import Data.List.Extra - --- | Check that a list has the given length (support infinite lists) -checkLength :: Word -> [a] -> Bool -checkLength 0 [] = True -checkLength 0 _ = False -checkLength _ [] = False -checkLength i (_:xs) = checkLength (i-1) xs diff --git a/src/lib/Haskus/Utils/Map.hs b/src/lib/Haskus/Utils/Map.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Map.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Haskus.Utils.Map - ( module Data.Map - ) -where - -import Data.Map diff --git a/src/lib/Haskus/Utils/Map/Strict.hs b/src/lib/Haskus/Utils/Map/Strict.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Map/Strict.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Haskus.Utils.Map.Strict - ( module Data.Map.Strict - ) -where - -import Data.Map.Strict - diff --git a/src/lib/Haskus/Utils/Maybe.hs b/src/lib/Haskus/Utils/Maybe.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Maybe.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - --- | Utils for Maybe data type -module Haskus.Utils.Maybe - ( onNothing - , onNothingM - , fromMaybeM - , headMaybe - , module Data.Maybe - ) -where - -import Data.Maybe - --- | Flipped `fromMaybe` -onNothing :: Maybe a -> a -> a -onNothing = flip fromMaybe - --- | Flipped `fromMaybeM` -onNothingM :: Monad m => m (Maybe a) -> m a -> m a -onNothingM = flip fromMaybeM - --- | fromMaybe in a Monad -fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a -fromMaybeM v f = f >>= \case - Nothing -> v - Just x -> return x - --- | Get the head of the list if the latter is not empty -headMaybe :: [a] -> Maybe a -headMaybe [] = Nothing -headMaybe (x:_) = Just x diff --git a/src/lib/Haskus/Utils/Monad.hs b/src/lib/Haskus/Utils/Monad.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Monad.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} - --- | Utils for Monads -module Haskus.Utils.Monad - ( MonadInIO (..) - , module Control.Monad - , module Control.Monad.IO.Class - , module Control.Monad.Extra - , module Control.Monad.Trans.Class - ) -where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad -import Control.Monad.Extra -import Control.Monad.State - -class MonadIO m => MonadInIO m where - -- | Lift with*-like functions into IO (alloca, etc.) - liftWith :: (forall c. (a -> IO c) -> IO c) -> (a -> m b) -> m b - - -- | Lift with*-like functions into IO (alloca, etc.) - liftWith2 :: (forall c. (a -> b -> IO c) -> IO c) -> (a -> b -> m e) -> m e - -instance MonadInIO IO where - {-# INLINE liftWith #-} - liftWith = id - - {-# INLINE liftWith2 #-} - liftWith2 = id - -instance MonadInIO m => MonadInIO (StateT s m) where - {-# INLINE liftWith #-} - liftWith wth f = - StateT $ \s -> do - liftWith wth (\a -> runStateT (f a) s) - - {-# INLINE liftWith2 #-} - liftWith2 wth f = - StateT $ \s -> - liftWith2 wth (\a b -> runStateT (f a b) s) diff --git a/src/lib/Haskus/Utils/Tuple.hs b/src/lib/Haskus/Utils/Tuple.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Tuple.hs +++ /dev/null @@ -1,502 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - --- | Tuple helpers -module Haskus.Utils.Tuple - ( uncurry3 - , uncurry4 - , take4 - , fromTuple4 - , module Data.Tuple - , Single (..) - , TupleToList - , ListToTuple - , ExtractTuple (..) - , TupleHead (..) - , TupleTail (..) - , TupleCons (..) - , ReorderTuple (..) - ) -where - -import Data.Tuple -import Haskus.Utils.Types - --- | Uncurry specialised for triple -uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e -{-# INLINE uncurry3 #-} -uncurry3 f (a,b,c) = f a b c - --- | Uncurry specialised for quadruple -uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e -{-# INLINE uncurry4 #-} -uncurry4 f (a,b,c,d) = f a b c d - - --- | Take specialised for quadruple -take4 :: [a] -> (a,a,a,a) -{-# INLINE take4 #-} -take4 [a,b,c,d] = (a,b,c,d) -take4 _ = error "take4: invalid list (exactly 4 elements required)" - - --- | toList for quadruple -fromTuple4 :: (a,a,a,a) -> [a] -{-# INLINE fromTuple4 #-} -fromTuple4 (a,b,c,d) = [a,b,c,d] - --- | Singleton type -newtype Single a = Single a deriving (Show,Eq) - - -type family TupleToList t where - TupleToList (Single a) = '[a] - TupleToList (a,b) = '[a,b] - TupleToList (a,b,c) = '[a,b,c] - TupleToList (a,b,c,d) = '[a,b,c,d] - TupleToList (a,b,c,d,e) = '[a,b,c,d,e] - TupleToList (a,b,c,d,e,f) = '[a,b,c,d,e,f] - TupleToList (a,b,c,d,e,f,g) = '[a,b,c,d,e,f,g] - TupleToList (a,b,c,d,e,f,g,h) = '[a,b,c,d,e,f,g,h] - TupleToList (a,b,c,d,e,f,g,h,i) = '[a,b,c,d,e,f,g,h,i] - TupleToList (a,b,c,d,e,f,g,h,i,j) = '[a,b,c,d,e,f,g,h,i,j] - TupleToList (a,b,c,d,e,f,g,h,i,j,k) = '[a,b,c,d,e,f,g,h,i,j,k] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l) = '[a,b,c,d,e,f,g,h,i,j,k,l] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m) = '[a,b,c,d,e,f,g,h,i,j,k,l,m] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y] - TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] - -type family ListToTuple t where - ListToTuple '[a] = Single a - ListToTuple '[a,b] = (a,b) - ListToTuple '[a,b,c] = (a,b,c) - ListToTuple '[a,b,c,d] = (a,b,c,d) - ListToTuple '[a,b,c,d,e] = (a,b,c,d,e) - ListToTuple '[a,b,c,d,e,f] = (a,b,c,d,e,f) - ListToTuple '[a,b,c,d,e,f,g] = (a,b,c,d,e,f,g) - ListToTuple '[a,b,c,d,e,f,g,h] = (a,b,c,d,e,f,g,h) - ListToTuple '[a,b,c,d,e,f,g,h,i] = (a,b,c,d,e,f,g,h,i) - ListToTuple '[a,b,c,d,e,f,g,h,i,j] = (a,b,c,d,e,f,g,h,i,j) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k] = (a,b,c,d,e,f,g,h,i,j,k) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l] = (a,b,c,d,e,f,g,h,i,j,k,l) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m] = (a,b,c,d,e,f,g,h,i,j,k,l,m) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) - ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) - --- | Extract a tuple value statically -class ExtractTuple (n :: Nat) t x | n t -> x where - -- | Extract a tuple value by type-level index - tupleN :: t -> x - -instance ExtractTuple 0 (Single t) t where - {-# INLINE tupleN #-} - tupleN (Single t) = t - -instance ExtractTuple 0 (e0, e1) e0 where - {-# INLINE tupleN #-} - tupleN (t,_) = t - -instance ExtractTuple 1 (e0, e1) e1 where - {-# INLINE tupleN #-} - tupleN (_,t) = t - -instance ExtractTuple 0 (e0, e1, e2) e0 where - {-# INLINE tupleN #-} - tupleN (t,_,_) = t - -instance ExtractTuple 1 (e0, e1, e2) e1 where - {-# INLINE tupleN #-} - tupleN (_,t,_) = t - -instance ExtractTuple 2 (e0, e1, e2) e2 where - {-# INLINE tupleN #-} - tupleN (_,_,t) = t - -instance ExtractTuple 0 (e0, e1, e2, e3) e0 where - {-# INLINE tupleN #-} - tupleN (t,_,_,_) = t - -instance ExtractTuple 1 (e0, e1, e2, e3) e1 where - {-# INLINE tupleN #-} - tupleN (_,t,_,_) = t - -instance ExtractTuple 2 (e0, e1, e2, e3) e2 where - {-# INLINE tupleN #-} - tupleN (_,_,t,_) = t - -instance ExtractTuple 3 (e0, e1, e2, e3) e3 where - {-# INLINE tupleN #-} - tupleN (_,_,_,t) = t - - -instance ExtractTuple 0 (e0, e1, e2, e3, e4) e0 where - {-# INLINE tupleN #-} - tupleN (t,_,_,_,_) = t - -instance ExtractTuple 1 (e0, e1, e2, e3, e4) e1 where - {-# INLINE tupleN #-} - tupleN (_,t,_,_,_) = t - -instance ExtractTuple 2 (e0, e1, e2, e3, e4) e2 where - {-# INLINE tupleN #-} - tupleN (_,_,t,_,_) = t - -instance ExtractTuple 3 (e0, e1, e2, e3, e4) e3 where - {-# INLINE tupleN #-} - tupleN (_,_,_,t,_) = t - -instance ExtractTuple 4 (e0, e1, e2, e3, e4) e4 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,t) = t - - -instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5) e0 where - {-# INLINE tupleN #-} - tupleN (t,_,_,_,_,_) = t - -instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5) e1 where - {-# INLINE tupleN #-} - tupleN (_,t,_,_,_,_) = t - -instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5) e2 where - {-# INLINE tupleN #-} - tupleN (_,_,t,_,_,_) = t - -instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5) e3 where - {-# INLINE tupleN #-} - tupleN (_,_,_,t,_,_) = t - -instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5) e4 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,t,_) = t - -instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5) e5 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,_,t) = t - - -instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5, e6) e0 where - {-# INLINE tupleN #-} - tupleN (t,_,_,_,_,_,_) = t - -instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5, e6) e1 where - {-# INLINE tupleN #-} - tupleN (_,t,_,_,_,_,_) = t - -instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5, e6) e2 where - {-# INLINE tupleN #-} - tupleN (_,_,t,_,_,_,_) = t - -instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5, e6) e3 where - {-# INLINE tupleN #-} - tupleN (_,_,_,t,_,_,_) = t - -instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5, e6) e4 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,t,_,_) = t - -instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5, e6) e5 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,_,t,_) = t - -instance ExtractTuple 6 (e0, e1, e2, e3, e4, e5, e6) e6 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,_,_,t) = t - - -instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5, e6, e7) e0 where - {-# INLINE tupleN #-} - tupleN (t,_,_,_,_,_,_,_) = t - -instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5, e6, e7) e1 where - {-# INLINE tupleN #-} - tupleN (_,t,_,_,_,_,_,_) = t - -instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5, e6, e7) e2 where - {-# INLINE tupleN #-} - tupleN (_,_,t,_,_,_,_,_) = t - -instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5, e6, e7) e3 where - {-# INLINE tupleN #-} - tupleN (_,_,_,t,_,_,_,_) = t - -instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5, e6, e7) e4 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,t,_,_,_) = t - -instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5, e6, e7) e5 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,_,t,_,_) = t - -instance ExtractTuple 6 (e0, e1, e2, e3, e4, e5, e6, e7) e6 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,_,_,t,_) = t - -instance ExtractTuple 7 (e0, e1, e2, e3, e4, e5, e6, e7) e7 where - {-# INLINE tupleN #-} - tupleN (_,_,_,_,_,_,_,t) = t - - -class TupleHead ts ts' | ts -> ts' where - tupleHead :: ts -> ts' - -instance TupleHead (Single a) a where - {-# INLINE tupleHead #-} - tupleHead (Single a) = a - -instance TupleHead (a,b) a where - {-# INLINE tupleHead #-} - tupleHead (a,_) = a - -instance TupleHead (a,b,c) a where - {-# INLINE tupleHead #-} - tupleHead (a,_,_) = a - -instance TupleHead (a,b,c,d) a where - {-# INLINE tupleHead #-} - tupleHead (a,_,_,_) = a - -instance TupleHead (a,b,c,d,e) a where - {-# INLINE tupleHead #-} - tupleHead (a,_,_,_,_) = a - -instance TupleHead (a,b,c,d,e,f) a where - {-# INLINE tupleHead #-} - tupleHead (a,_,_,_,_,_) = a - - -class TupleTail ts ts' | ts -> ts' where - tupleTail :: ts -> ts' - -instance TupleTail (a,b) (Single b) where - {-# INLINE tupleTail #-} - tupleTail (_,b) = Single b - -instance TupleTail (a,b,c) (b,c) where - {-# INLINE tupleTail #-} - tupleTail (_,b,c) = (b,c) - -instance TupleTail (a,b,c,d) (b,c,d) where - {-# INLINE tupleTail #-} - tupleTail (_,b,c,d) = (b,c,d) - -instance TupleTail (a,b,c,d,e) (b,c,d,e) where - {-# INLINE tupleTail #-} - tupleTail (_,b,c,d,e) = (b,c,d,e) - -instance TupleTail (a,b,c,d,e,f) (b,c,d,e,f) where - {-# INLINE tupleTail #-} - tupleTail (_,b,c,d,e,f) = (b,c,d,e,f) - - - -class TupleCons t ts ts' | t ts -> ts' where - tupleCons :: t -> ts -> ts' - -instance TupleCons a (Single b) (a,b) where - {-# INLINE tupleCons #-} - tupleCons a (Single b) = (a,b) - -instance TupleCons a (b,c) (a,b,c) where - {-# INLINE tupleCons #-} - tupleCons a (b,c) = (a,b,c) - -instance TupleCons a (b,c,d) (a,b,c,d) where - {-# INLINE tupleCons #-} - tupleCons a (b,c,d) = (a,b,c,d) - -instance TupleCons a (b,c,d,e) (a,b,c,d,e) where - {-# INLINE tupleCons #-} - tupleCons a (b,c,d,e) = (a,b,c,d,e) - -instance TupleCons a (b,c,d,e,f) (a,b,c,d,e,f) where - {-# INLINE tupleCons #-} - tupleCons a (b,c,d,e,f) = (a,b,c,d,e,f) - - --- | Reorder tuple elements -class ReorderTuple t1 t2 where - -- | Reorder tuple elements - tupleReorder :: t1 -> t2 - - -instance ReorderTuple (Single a) (Single a) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b) (a,b) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c) (a,b,c) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d) (a,b,c,d) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d,e) (a,b,c,d,e) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d,e,f) (a,b,c,d,e,f) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d,e,f,g) (a,b,c,d,e,f,g) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i) where - {-# INLINE tupleReorder #-} - tupleReorder = id - -instance ReorderTuple (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f,g,h,i,j) where - {-# INLINE tupleReorder #-} - tupleReorder = id - - -instance ReorderTuple (a,b) (b,a) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b) = (b,a) - -instance ReorderTuple (a,b,c) (a,c,b) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c) = (a,c,b) - -instance ReorderTuple (a,b,c) (b,a,c) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c) = (b,a,c) - -instance ReorderTuple (a,b,c) (b,c,a) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c) = (b,c,a) - -instance ReorderTuple (a,b,c) (c,a,b) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c) = (c,a,b) - -instance ReorderTuple (a,b,c) (c,b,a) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c) = (c,b,a) - -instance ReorderTuple (b,c,d) (x,y,z) => ReorderTuple (a,b,c,d) (a,x,y,z) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (b,c,d) in (a,x,y,z) - -instance ReorderTuple (a,c,d) (x,y,z) => ReorderTuple (a,b,c,d) (x,b,y,z) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (a,c,d) in (x,b,y,z) - -instance ReorderTuple (a,b,d) (x,y,z) => ReorderTuple (a,b,c,d) (x,y,c,z) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (a,b,d) in (x,y,c,z) - -instance ReorderTuple (a,b,c) (x,y,z) => ReorderTuple (a,b,c,d) (x,y,z,d) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (a,b,c) in (x,y,z,d) - -instance ReorderTuple (b,c,d,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (a,x,y,z,w) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (b,c,d,e) in (a,x,y,z,w) - -instance ReorderTuple (a,c,d,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,b,y,z,w) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,c,d,e) in (x,b,y,z,w) - -instance ReorderTuple (a,b,d,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,y,c,z,w) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,b,d,e) in (x,y,c,z,w) - -instance ReorderTuple (a,b,c,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,y,z,d,w) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,b,c,e) in (x,y,z,d,w) - -instance ReorderTuple (a,b,c,d) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,y,z,w,e) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,b,c,d) in (x,y,z,w,e) - -instance ReorderTuple (b,c,d,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (a,x,y,z,w,v) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (b,c,d,e,f) in (a,x,y,z,w,v) - -instance ReorderTuple (a,c,d,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,b,y,z,w,v) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,c,d,e,f) in (x,b,y,z,w,v) - -instance ReorderTuple (a,b,d,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,c,z,w,v) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,d,e,f) in (x,y,c,z,w,v) - -instance ReorderTuple (a,b,c,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,z,d,w,v) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,c,e,f) in (x,y,z,d,w,v) - -instance ReorderTuple (a,b,c,d,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,z,w,e,v) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,c,d,f) in (x,y,z,w,e,v) - -instance ReorderTuple (a,b,c,d,e) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,z,w,v,f) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,c,d,e) in (x,y,z,w,v,f) - - -instance ReorderTuple (b,c,d,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (a,x,y,z,w,v,u) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (b,c,d,e,f,g) in (a,x,y,z,w,v,u) - -instance ReorderTuple (a,c,d,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,b,y,z,w,v,u) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,c,d,e,f,g) in (x,b,y,z,w,v,u) - -instance ReorderTuple (a,b,d,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,c,z,w,v,u) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,d,e,f,g) in (x,y,c,z,w,v,u) - -instance ReorderTuple (a,b,c,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,d,w,v,u) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,e,f,g) in (x,y,z,d,w,v,u) - -instance ReorderTuple (a,b,c,d,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,w,e,v,u) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,d,f,g) in (x,y,z,w,e,v,u) - -instance ReorderTuple (a,b,c,d,e,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,w,v,f,u) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,d,e,g) in (x,y,z,w,v,f,u) - -instance ReorderTuple (a,b,c,d,e,f) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,w,v,u,g) where - {-# INLINE tupleReorder #-} - tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,d,e,f) in (x,y,z,w,v,u,g) diff --git a/src/lib/Haskus/Utils/Types.hs b/src/lib/Haskus/Utils/Types.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Types.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE PolyKinds #-} - --- | Common type functions -module Haskus.Utils.Types - ( Nat - , Symbol - , natValue - , natValue' - , symbolValue - , KnownNat - , KnownSymbol - , CmpNat - , CmpSymbol - , type (<=?) - , type (<=) - , type (+) - , type (-) - , type (*) - , type (^) - , Assert - , If - , Modulo - , Same - , Proxy (..) - , TypeError - , ErrorMessage (..) - ) -where - -import GHC.TypeLits -import Data.Proxy - --- | Get a Nat value -natValue :: forall (n :: Nat) a. (KnownNat n, Num a) => a -{-# INLINE natValue #-} -natValue = fromIntegral (natVal (Proxy :: Proxy n)) - --- | Get a Nat value -natValue' :: forall (n :: Nat). KnownNat n => Word -{-# INLINE natValue' #-} -natValue' = natValue @n - --- | Get a Symbol value -symbolValue :: forall (s :: Symbol). (KnownSymbol s) => String -{-# INLINE symbolValue #-} -symbolValue = symbolVal (Proxy :: Proxy s) - --- | If-then-else -type family If (c :: Bool) (t :: k) (e :: k) where - If 'True t e = t - If 'False t e = e - - --- | Like: If cond t (TypeError msg) --- --- The difference is that the TypeError doesn't appear in the RHS of the type --- which lead to better error messages (see GHC #14771). --- --- For instance: --- type family F n where --- F n = If (n <=? 8) Int8 (TypeError (Text "ERROR")) --- --- type family G n where --- G n = Assert (n <=? 8) Int8 (Text "ERROR") --- --- If GHC cannot solve `F n ~ Word`, it shows: ERROR --- If GHC cannot solve `G n ~ Word`, it shows: --- can't match `Assert...` with `Word` --- -type family Assert (prop :: Bool) (val :: k) (msg :: ErrorMessage) where - Assert 'True val msg = val - Assert 'False val msg = TypeError msg - --- | Modulo -type family Modulo (a :: Nat) (b :: Nat) where - Modulo a b = Modulo' (a <=? b) a b - --- | Helper for Modulo -type family Modulo' c a b where - Modulo' 'True a b = a - Modulo' 'False a b = Modulo' ((a-b) <=? b) (a-b) b - --- | Type equality to Nat -type family Same a b :: Nat where - Same a a = 1 - Same a b = 0 diff --git a/src/lib/Haskus/Utils/Types/Generics.hs b/src/lib/Haskus/Utils/Types/Generics.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Types/Generics.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Generics -module Haskus.Utils.Types.Generics - ( module GHC.Generics - -- * Fields - , Field - , FieldType - , LookupField - , LookupFieldType - -- * Data type fields - , ExtractFields - , ExtractFieldTypes - ) -where - -import Haskus.Utils.Types.List -import Haskus.Utils.Types -import GHC.Generics - --- | Named field -data Field (name :: Symbol) (t :: *) - -type family FieldType f where - FieldType (Field name t) = t - -type family LookupFieldType fs s where - LookupFieldType fs s = FieldType (LookupField fs s) - -type family LookupField (fs :: [*]) (s :: Symbol) where - LookupField (Field name t ': fs) name = Field name t - LookupField (Field name t ': fs) s = LookupField fs s - LookupField '[] name = - TypeError ('Text "Cannot find field with name: " ':<>: 'ShowType name) - - --- | Extract fields of a data type: --- - require selector symbols --- - only support data type with a single constructor -type family ExtractFields (a :: *) where - ExtractFields a = ExtractFields' (Rep a) - -type family ExtractFields' a where - -- extract constructors - ExtractFields' (D1 _ cs) = ExtractFields' cs - - -- extract selectors - ExtractFields' (C1 _ ss) = ExtractFields' ss - ExtractFields' (s1 :*: s2) = Concat (ExtractFields' s1) (ExtractFields' s2) - - -- extract field name and type from the selector - ExtractFields' (S1 ('MetaSel ('Just name) _ _ _) (Rec0 t)) = '[Field name t] - - - --- | Extract types of the fields of a data type --- - only support data type with a single constructor -type family ExtractFieldTypes (a :: *) where - ExtractFieldTypes a = ExtractFieldTypes' (Rep a) - -type family ExtractFieldTypes' a where - -- extract constructors - ExtractFieldTypes' (D1 _ cs) = ExtractFieldTypes' cs - - -- extract selectors - ExtractFieldTypes' (C1 _ ss) = ExtractFieldTypes' ss - ExtractFieldTypes' (s1 :*: s2) = - Concat (ExtractFieldTypes' s1) (ExtractFieldTypes' s2) - - -- extract field type from the selector - ExtractFieldTypes' (S1 _ (Rec0 t)) = '[t] diff --git a/src/lib/Haskus/Utils/Types/List.hs b/src/lib/Haskus/Utils/Types/List.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Types/List.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} - --- | Utils for type lists -module Haskus.Utils.Types.List - ( Map - , Max - , Tail - , Drop - , Take - , Init - , Head - , Snoc - , InsertAt - , ReplaceAt - , Replace - , ReplaceN - , ReplaceNS - , Reverse - , RemoveAt - , RemoveAt1 - , RemoveAtN - , Concat - , Length - , Replicate - , MapMaybe - , Generate - , IsMember - , IsSubset - , Indexes - , MapTest - , Zip - , Filter - , Nub - , NubHead - , IndexOf - , IndexesOf - , MaybeIndexOf - , Index - , Union - , Member - , CheckNub - ) -where - -import Haskus.Utils.Types - --- | Map a type function -type family Map (f :: a -> k) (xs :: [a]) where - Map f '[] = '[] - Map f (x ': xs) = f x ': Map f xs - --- | Get the max of a list of Nats -type family Max (xs :: [Nat]) where - Max (x ': xs) = Max' x xs - --- | Helper for Max -type family Max' (x :: Nat) (xs :: [Nat]) where - Max' x '[] = x - Max' x (a ': xs) = Max' (If (x <=? a) a x) xs - --- | Tail of a list -type family Tail (xs :: [*]) where - Tail (x ': xs) = xs - --- | Drop elements in a list -type family Drop (n :: Nat) (xs :: [*]) where - Drop 0 xs = xs - Drop n (x ': xs) = Drop (n-1) xs - --- | Take elements in a list -type family Take (n :: Nat) (xs :: [*]) where - Take 0 xs = '[] - Take n (x ': xs) = x ': (Take (n-1) xs) - --- | Init of a list -type family Init (xs :: [*]) where - Init '[x] = '[] - Init (x ': xs) = x ': (Init xs) - --- | Snoc -type family Snoc (xs :: [*]) x where - Snoc '[] x = '[x] - Snoc (y ': ys) x = y ': (Snoc ys x) - --- | Head of a list -type family Head (xs :: [*]) where - Head (x ': xs) = x - --- | Concat two type lists -type family Concat (xs :: [*]) (ys :: [*]) where - Concat '[] '[] = '[] - Concat '[] ys = ys - Concat (x ': xs) ys = x ': Concat xs ys - --- | Get list length -type family Length xs where - Length xs = Length' 0 xs - -type family Length' n xs where - Length' n '[] = n - Length' n (x ': xs) = Length' (n+1) xs - --- | Replicate -type family Replicate n s where - Replicate n s = Replicate' s n '[] - -type family Replicate' x n xs where - Replicate' x 0 xs = xs - Replicate' x n xs = Replicate' x (n-1) (x ': xs) - --- | Insert a list at n -type family InsertAt (n :: Nat) l l2 where - InsertAt 0 xs ys = Concat ys xs - InsertAt n (x ': xs) ys = x ': InsertAt (n-1) xs ys - --- | replace l[n] with l2 (folded) -type family ReplaceAt (n :: Nat) l l2 where - ReplaceAt 0 (x ': xs) ys = Concat ys xs - ReplaceAt n (x ': xs) ys = x ': ReplaceAt (n-1) xs ys - --- | replace a type by another in l -type family Replace t1 t2 l where - Replace t1 t2 '[] = '[] - Replace t1 t2 (t1 ': xs) = t2 ': (Replace t1 t2 xs) - Replace t1 t2 (x ': xs) = x ': (Replace t1 t2 xs) - --- | replace a type at offset n in l -type family ReplaceN n t l where - ReplaceN 0 t (x ': xs) = (t ': xs) - ReplaceN n t (x ': xs) = x ': ReplaceN (n-1) t xs - --- | replace types at offsets ns in l -type family ReplaceNS ns t l where - ReplaceNS '[] t l = l - ReplaceNS (i ': is) t l = ReplaceNS is t (ReplaceN i t l) - --- | Reverse a list -type family Reverse (l :: [*]) where - Reverse l = Reverse' l '[] - -type family Reverse' (l :: [*]) (l2 :: [*]) where - Reverse' '[] l = l - Reverse' (x ': xs) l = Reverse' xs (x ': l) - - --- | Remove a type at index -type family RemoveAt (n :: Nat) l where - RemoveAt 0 (x ': xs) = xs - RemoveAt n (x ': xs) = x ': RemoveAt (n-1) xs - --- | Remove a type at index (0 == don't remove) -type family RemoveAt1 (n :: Nat) l where - RemoveAt1 0 xs = xs - RemoveAt1 1 (x ': xs) = xs - RemoveAt1 n (x ': xs) = x ': RemoveAt1 (n-1) xs - --- | Remove types at several indexes -type family RemoveAtN (ns :: [Nat]) l where - RemoveAtN '[] xs = xs - RemoveAtN (i ': is) xs = RemoveAtN is (RemoveAt i xs) - --- | Apply Maybe to all the elements of the list -type family MapMaybe l where - MapMaybe '[] = '[] - MapMaybe (x ': xs) = Maybe x ': MapMaybe xs - --- | Generate a list of Nat [n..m-1] -type family Generate (n :: Nat) (m :: Nat) :: [Nat] where - Generate n n = '[] - Generate n m = n ': Generate (n+1) m - --- | Check that a type is member of a type list -type family IsMember a (l :: [*]) :: Bool where - IsMember a l = IsMember' l a l - --- | Check that a type is member of a type list -type family IsMember' (i :: [*]) a (l :: [*]) :: Bool where - IsMember' i a (a ': l) = 'True - IsMember' i a (b ': l) = IsMember' i a l - IsMember' i a '[] = TypeError ( 'Text "`" - ':<>: 'ShowType a - ':<>: 'Text "'" - ':<>: 'Text " is not a member of " - ':<>: 'ShowType i) - - --- | Check that a list is a subset of another -type family IsSubset l1 l2 :: Bool where - IsSubset l1 l1 = 'True - IsSubset l1 l2 = IsSubset' l2 l1 l2 - --- | Helper for IsSubset -type family IsSubset' i l1 l2 :: Bool where - IsSubset' i '[] l2 = 'True - IsSubset' i l1 '[] = TypeError ( 'ShowType l1 - ':$$: 'Text "is not a subset of" - ':$$: 'ShowType i) - IsSubset' i (x ': xs) (x ': ys) = IsSubset' i xs i - IsSubset' i (x ': xs) (y ': ys) = IsSubset' i (x ': xs) ys - --- | Get list indexes -type family Indexes (l :: [*]) where - Indexes xs = IndexesFrom 0 xs - -type family IndexesFrom (n :: Nat) (xs :: [*]) where - IndexesFrom n '[] = '[] - IndexesFrom n (x ': xs) = Proxy n ': IndexesFrom (n+1) xs - --- | Map to 1 if type equality, 0 otherwise -type family MapTest a (l :: [*]) where - MapTest a '[] = '[] - MapTest a (a ': xs) = Proxy 1 ': MapTest a xs - MapTest a (x ': xs) = Proxy 0 ': MapTest a xs - --- | Zip two lists -type family Zip (l :: [*]) (l2 :: [*]) where - Zip '[] xs = '[] - Zip xs '[] = '[] - Zip (x ': xs) (y ': ys) = (x,y) ': Zip xs ys - --- | Remove `a` in `l` -type family Filter a (l :: [*]) where - Filter a '[] = '[] - Filter a (a ': as) = Filter a as - Filter a (b ': as) = b ': Filter a as - --- | Keep only a single value of each type -type family Nub (l :: [*]) where - Nub xs = Reverse (Nub' xs '[]) - -type family Nub' as xs where - Nub' '[] xs = xs - Nub' (x ': as) xs = Nub' (Filter x as) (x ': xs) - --- | Keep only a single value of the head type -type family NubHead (l :: [*]) where - NubHead '[] = '[] - NubHead (x ': xs) = x ': Filter x xs - --- | Get the first index of a type -type family IndexOf a (l :: [*]) :: Nat where - IndexOf x xs = IndexOf' x xs xs - --- | Get the first index of a type -type family IndexOf' a (l :: [*]) (l2 :: [*]) :: Nat where - IndexOf' x (x ': xs) l2 = 0 - IndexOf' y (x ': xs) l2 = 1 + IndexOf' y xs l2 - IndexOf' y '[] l2 = TypeError ( 'Text "`" - ':<>: 'ShowType y - ':<>: 'Text "'" - ':<>: 'Text " is not a member of " - ':<>: 'ShowType l2) - --- | Get all the indexes of a type -type family IndexesOf a (l :: [*]) :: [Nat] where - IndexesOf x xs = IndexesOf' 0 x xs - --- | Get the first index of a type -type family IndexesOf' n a (l :: [*]) :: [Nat] where - IndexesOf' n x '[] = '[] - IndexesOf' n x (x ': xs) = n ': IndexesOf' (n+1) x xs - IndexesOf' n x (y ': xs) = IndexesOf' (n+1) x xs - --- | Get the first index (starting from 1) of a type or 0 if none -type family MaybeIndexOf a (l :: [*]) where - MaybeIndexOf x xs = MaybeIndexOf' 0 x xs - --- | Helper for MaybeIndexOf -type family MaybeIndexOf' (n :: Nat) a (l :: [*]) where - MaybeIndexOf' n x '[] = 0 - MaybeIndexOf' n x (x ': xs) = 1 + n - MaybeIndexOf' n x (y ': xs) = MaybeIndexOf' (n+1) x xs - --- | Indexed access into the list -type family Index (n :: Nat) (l :: [*]) where - Index 0 (x ': xs) = x - Index n (x ': xs) = Index (n-1) xs - --- | Union two lists -type family Union (xs :: [*]) (ys :: [*]) where - Union xs ys = Nub (Concat xs ys) - --------------------------------------- --- Constraints --------------------------------------- - --- | Constraint: x member of xs -type Member x xs = - ( IsMember x xs ~ 'True - , x ~ Index (IndexOf x xs) xs - , KnownNat (IndexOf x xs) - ) - --- | Check that a list only contain a value of each type -type CheckNub (l :: [*]) = - ( CheckNubEx l (Nub l) ~ 'True - ) - -type family CheckNubEx (l1 :: [*]) (l2 :: [*]) where - CheckNubEx l l = 'True - CheckNubEx l1 l2 = TypeError - ( 'Text "Type-list contains unallowed redundant types." - ':$$: 'Text "Got: " ':<>: 'ShowType l1 - ':$$: 'Text "Expected: " ':<>: 'ShowType l2 - ) - diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Variant.hs +++ /dev/null @@ -1,1162 +0,0 @@ -{-# 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 - -- * Operations by index - , toVariantAt - , toVariantHead - , toVariantTail - , fromVariantAt - , popVariantAt - , popVariantHead - , updateVariantAt - , foldMapVariantAt - , foldMapVariantAtM - -- * Operations by type - , toVariant - , Member - , Filter - , Popable - , MaybePopable - , popVariant - , popVariantMaybe - , fromVariant - , fromVariantMaybe - , fromVariantFirst - , updateVariantFirst - , updateVariantFirstM - , MappableVariant - , mapVariant - , foldMapVariantFirst - , foldMapVariantFirstM - , foldMapVariant - -- * Generic operations with type classes - , AlterVariant (..) - , TraverseVariant (..) - , NoConstraint - , alterVariant - , traverseVariant - , traverseVariant_ - -- * Conversions between variants - , appendVariant - , prependVariant - , Liftable - , liftVariant - , nubVariant - -- * Conversions to/from other data types - , variantToValue - , variantToEither - , variantFromEither - , variantToHList - , variantToTuple - -- ** Continuations - , ContVariant (..) - ) -where - -import Unsafe.Coerce -import GHC.Exts (Any,Constraint) - -import Haskus.Utils.Monad -import Haskus.Utils.Types -import Haskus.Utils.Tuple -import Haskus.Utils.HList -import Haskus.Utils.ContFlow -import Haskus.Utils.Types.List - --- | A variant contains a value whose type is at the given position in the type --- list -data Variant (l :: [*]) = Variant {-# UNPACK #-} !Word Any - -type V = Variant - --- | Make GHC consider `l` as a representational parameter to make coercions --- between Variant values unsafe -type role Variant representational - --- | Pattern synonym for Variant --- --- Usage: case v of --- V (x :: Int) -> ... --- 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 - --- | 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) - -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 - ) - --- | Extract a type from a variant. Return either the value of this type or the --- remaining variant -popVariant :: forall a xs. - ( Popable a xs - ) => 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 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 - , VariantLift xs ys - ) - -class VariantLift xs ys where - liftVariant' :: Variant xs -> Variant ys - -instance VariantLift '[] ys where - liftVariant' = error "Lifting empty variant" - -instance forall xs ys x. - ( VariantLift xs ys - , KnownNat (IndexOf x ys) - ) => VariantLift (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 - ------------------------------------------------------------ --- Conversions to other data types ------------------------------------------------------------ - --- | Retreive a single value -variantToValue :: Variant '[a] -> a -{-# INLINE variantToValue #-} -variantToValue (Variant _ a) = 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 (MapMaybe 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' (MapMaybe 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 - )