packages feed

haskus-utils (empty) → 0.6.0.0

raw patch · 31 files changed

+5675/−0 lines, 31 filesdep +basedep +containersdep +extrasetup-changed

Dependencies added: base, containers, extra, file-embed, haskus-utils, list-t, mtl, stm, stm-containers, tasty, tasty-quickcheck, template-haskell, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013-2017, Haskus organization+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.++    * Neither the name of Sylvain Henry nor the names of other contributors +      may be used to endorse or promote products derived from this software +      without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskus-utils.cabal view
@@ -0,0 +1,83 @@+name:                haskus-utils+version:             0.6.0.0+synopsis:            Haskus utility modules+license:             BSD3+license-file:        LICENSE+author:              Sylvain Henry+maintainer:          sylvain@haskus.fr+homepage:            http://www.haskus.org/system+copyright:           Sylvain Henry 2017+category:            System+build-type:          Simple+cabal-version:       >=1.20++description:+   Various utility modules used by Haskus packages.++source-repository head+  type: git+  location: git://github.com/haskus/haskus-utils.git++library+  exposed-modules:+    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.Maybe+    Haskus.Utils.Types+    Haskus.Utils.Types.List+    Haskus.Utils.Types.Generics+    Haskus.Utils.STM+    Haskus.Utils.STM.TEq+    Haskus.Utils.STM.TMap+    Haskus.Utils.STM.TSet+    Haskus.Utils.STM.TList+    Haskus.Utils.STM.TTree+    Haskus.Utils.STM.Future+    Haskus.Utils.STM.TGraph+    Haskus.Utils.Tuple++  other-modules:++  build-depends:       +         base                      >= 4.9 && < 4.10+      ,  containers                >= 0.5+      ,  list-t                    >= 0.4+      ,  stm                       >= 2.4+      ,  stm-containers            >= 0.2+      ,  vector                    >= 0.11+      ,  transformers              >= 0.4+      ,  mtl                       >= 2.2+      ,  template-haskell          >= 2.10+      ,  file-embed                >= 0.0.10+      ,  extra                     >= 1.4++  build-tools: +  ghc-options:          -Wall+  default-language:     Haskell2010+  hs-source-dirs:       src/lib++test-suite tests+   type:                exitcode-stdio-1.0+   main-is:             Main.hs+   hs-source-dirs:      src/tests+   ghc-options:         -O2 -Wall -threaded+   default-language:    Haskell2010+   other-modules:+         Haskus.Tests.Utils+      ,  Haskus.Tests.Utils.HArray+      ,  Haskus.Tests.Utils.Variant++   build-depends:    +         base+      ,  haskus-utils+      ,  tasty                   >= 0.11+      ,  tasty-quickcheck        >= 0.8
+ src/lib/Haskus/Utils/ContFlow.hs view
@@ -0,0 +1,159 @@+{-# 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
+ src/lib/Haskus/Utils/Embed.hs view
@@ -0,0 +1,14 @@+-- | Embed data into the executable binary+module Haskus.Utils.Embed+   ( embedBytes+   , module Data.FileEmbed+   )+where++import Language.Haskell.TH+import Data.FileEmbed+import Data.Word++-- | Embed bytes in a C array, return an Addr#+embedBytes :: [Word8] -> Q Exp+embedBytes bs = return $ LitE (StringPrimL bs)
+ src/lib/Haskus/Utils/Flow.hs view
@@ -0,0 +1,1775 @@+{-# 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+   , Catchable+   , MaybeCatchable+   -- * Non-variant single operations+   , (|>)+   , (<|)+   , (||>)+   , (<||)+   -- * Monadic/applicative operators+   , when+   , unless+   , guard+   , void+   , forever+   , foldM+   , foldM_+   , forM+   , forM_+   , mapM+   , mapM_+   , sequence+   , replicateM+   , replicateM_+   , filterM+   , join+   , (<=<)+   , (>=>)+   -- * Named operators+   , flowMap+   , flowBind+   , flowBind'+   , flowMatch+   , flowMatchFail+   -- * First element operations+   , (.~.>)+   , (>.~.>)+   , (.~+>)+   , (>.~+>)+   , (.~^^>)+   , (>.~^^>)+   , (.~^>)+   , (>.~^>)+   , (.~$>)+   , (>.~$>)+   , (.~|>)+   , (>.~|>)+   , (.~=>)+   , (>.~=>)+   , (.~!>)+   , (>.~!>)+   , (.~!!>)+   , (>.~!!>)+   -- * First element, pure variant+   , (.-.>)+   , (>.-.>)+   , (<.-.)+   , (<.-.<)+   -- * Functor, applicative equivalents+   , (<$<)+   , (<*<)+   , (<|<)+   -- * First element, const variant+   , (.~~.>)+   , (>.~~.>)+   , (.~~+>)+   , (>.~~+>)+   , (.~~^^>)+   , (>.~~^^>)+   , (.~~^>)+   , (>.~~^>)+   , (.~~$>)+   , (>.~~$>)+   , (.~~|>)+   , (>.~~|>)+   , (.~~=>)+   , (>.~~=>)+   , (.~~!>)+   , (>.~~!>)+   -- * Tail operations+   , (..~.>)+   , (>..~.>)+   , (..-.>)+   , (>..-.>)+   , (..-..>)+   , (>..-..>)+   , (..~..>)+   , (>..~..>)+   , (..~^^>)+   , (>..~^^>)+   , (..~^>)+   , (>..~^>)+   , (..~=>)+   , (>..~=>)+   , (..~!>)+   , (>..~!>)+   , (..~!!>)+   , (>..~!!>)+   -- * Tail catch 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 . setVariantN @n++-- | Return in the first well-typed element+flowSet :: (Member x xs, Monad m) => x -> Flow m xs+{-# INLINE flowSet #-}+flowSet = return . setVariant++-- | 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 singleVariant+++-- | 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+   , Catchable 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+   , Catchable 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 headVariant 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 headVariant 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 headVariant 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 headVariant 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 headVariant 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 headVariant 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 headVariant 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 headVariant 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+   , MaybeCatchable 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+   , MaybeCatchable 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+   , Catchable 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+   , Catchable 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+   , MaybeCatchable 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+   , MaybeCatchable 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+   , Catchable 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+   , Catchable 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+   , MaybeCatchable a xs+   , Liftable (Filter a xs) (x ': xs)+   ) => Variant (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)+{-# INLINE (..?~$>) #-}+(..?~$>) v f = case headVariant v of+   Right _ -> return v+   Left xs -> xs ?~^> f++infixl 0 ..?~$>++-- | Match in the tail, keep the same types+(>..?~$>) ::+   ( Monad m+   , MaybeCatchable 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+   , Catchable a xs+   , Liftable (Filter a xs) (x ': xs)+   ) => Variant (x ': xs) -> (a -> Flow m (x ': xs)) -> Flow m (x ': xs)+{-# INLINE (..%~$>) #-}+(..%~$>) v f = case headVariant v of+   Right _ -> return v+   Left xs -> xs %~^> f++infixl 0 ..%~$>++-- | Match in the tail, keep the same types+(>..%~$>) ::+   ( Monad m+   , Catchable 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 headVariant 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 headVariant 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 headVariant 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+   , MaybeCatchable 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+   , MaybeCatchable 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+   , Catchable 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+   , Catchable 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+   , MaybeCatchable y xs+   ) => Variant (x ': xs) -> (y -> m ()) -> m ()+{-# INLINE (..?~!>) #-}+(..?~!>) v f = case headVariant v of+   Right _ -> return ()+   Left xs -> xs ?~!> f++infixl 0 ..?~!>++-- | Match in the tail and perform an effect+(>..?~!>) ::+   ( Monad m+   , MaybeCatchable y xs+   ) => Flow m (x ': xs) -> (y -> m ()) -> m ()+{-# INLINE (>..?~!>) #-}+(>..?~!>) = liftm (..?~!>)++infixl 0 >..?~!>++-- | Match in the tail and perform an effect+(..%~!>) ::+   ( Monad m+   , Catchable y xs+   ) => Variant (x ': xs) -> (y -> m ()) -> m ()+{-# INLINE (..%~!>) #-}+(..%~!>) v f = case headVariant v of+   Right _ -> return ()+   Left xs -> xs %~!> f++infixl 0 ..%~!>++-- | Match in the tail and perform an effect+(>..%~!>) ::+   ( Monad m+   , Catchable y xs+   ) => Flow m (x ': xs) -> (y -> m ()) -> m ()+{-# INLINE (>..%~!>) #-}+(>..%~!>) = liftm (..%~!>)++infixl 0 >..%~!>++----------------------------------------------------------+-- Caught element operations+----------------------------------------------------------++-- | Catch element, set the first value+(?~.>) :: forall x xs y ys m.+   ( ys ~ Filter x xs+   , Monad m+   , MaybeCatchable x xs+   ) => Variant xs -> (x -> m y) -> Flow m (y ': ys)+{-# INLINE (?~.>) #-}+(?~.>) v f = case catchVariantMaybe v of+   Right x -> flowSetN @0 =<< f x+   Left ys -> prependVariant @'[y] <$> return ys++infixl 0 ?~.>++-- | Catch element, set the first value+(>?~.>) ::+   ( ys ~ Filter x xs+   , Monad m+   , MaybeCatchable x xs+   ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys)+{-# INLINE (>?~.>) #-}+(>?~.>) = liftm (?~.>)++infixl 0 >?~.>++-- | Catch element, set the first value+(%~.>) :: forall x xs y ys m.+   ( ys ~ Filter x xs+   , Monad m+   , Catchable x xs+   ) => Variant xs -> (x -> m y) -> Flow m (y ': ys)+{-# INLINE (%~.>) #-}+(%~.>) = (?~.>)++infixl 0 %~.>++-- | Catch element, set the first value+(>%~.>) ::+   ( ys ~ Filter x xs+   , Monad m+   , Catchable x xs+   ) => Flow m xs -> (x -> m y) -> Flow m (y ': ys)+{-# INLINE (>%~.>) #-}+(>%~.>) = liftm (%~.>)++infixl 0 >%~.>++-- | Catch element, concat the result+(?~+>) :: forall x xs ys m.+   ( Monad m+   , MaybeCatchable x xs+   , KnownNat (Length ys)+   ) => Variant xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs))+{-# INLINE (?~+>) #-}+(?~+>) v f = case catchVariantMaybe v of+   Right x -> appendVariant  @(Filter x xs) <$> f x+   Left ys -> prependVariant @ys            <$> return ys++infixl 0 ?~+>++-- | Catch element, concat the result+(>?~+>) :: forall x xs ys m.+   ( Monad m+   , MaybeCatchable x xs+   , KnownNat (Length ys)+   ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs))+{-# INLINE (>?~+>) #-}+(>?~+>) = liftm (?~+>)++infixl 0 >?~+>++-- | Catch element, concat the result+(%~+>) :: forall x xs ys m.+   ( Monad m+   , Catchable x xs+   , KnownNat (Length ys)+   ) => Variant xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs))+{-# INLINE (%~+>) #-}+(%~+>) = (?~+>)++infixl 0 %~+>++-- | Catch element, concat the result+(>%~+>) :: forall x xs ys m.+   ( Monad m+   , Catchable x xs+   , KnownNat (Length ys)+   ) => Flow m xs -> (x -> Flow m ys) -> Flow m (Concat ys (Filter x xs))+{-# INLINE (>%~+>) #-}+(>%~+>) = liftm (%~+>)++infixl 0 >%~+>++-- | Catch element, lift the result+(?~^^>) :: forall x xs ys zs m.+   ( Monad m+   , MaybeCatchable x xs+   , Liftable (Filter x xs) zs+   , Liftable ys zs+   ) => Variant xs -> (x -> Flow m ys) -> Flow m zs+{-# INLINE (?~^^>) #-}+(?~^^>) v f = case catchVariantMaybe v of+   Right x -> liftVariant <$> f x+   Left ys -> liftVariant <$> return ys++infixl 0 ?~^^>++-- | Catch element, lift the result+(>?~^^>) :: forall x xs ys zs m.+   ( Monad m+   , MaybeCatchable x xs+   , Liftable (Filter x xs) zs+   , Liftable ys zs+   ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs+{-# INLINE (>?~^^>) #-}+(>?~^^>) = liftm (?~^^>)++infixl 0 >?~^^>++-- | Catch element, lift the result+(%~^^>) :: forall x xs ys zs m.+   ( Monad m+   , Catchable x xs+   , Liftable (Filter x xs) zs+   , Liftable ys zs+   ) => Variant xs -> (x -> Flow m ys) -> Flow m zs+{-# INLINE (%~^^>) #-}+(%~^^>) = (?~^^>)++infixl 0 %~^^>++-- | Catch element, lift the result+(>%~^^>) :: forall x xs ys zs m.+   ( Monad m+   , Catchable x xs+   , Liftable (Filter x xs) zs+   , Liftable ys zs+   ) => Flow m xs -> (x -> Flow m ys) -> Flow m zs+{-# INLINE (>%~^^>) #-}+(>%~^^>) = liftm (%~^^>)++infixl 0 >%~^^>++-- | Catch element, connect to the expected output+(?~^>) :: forall x xs zs m.+   ( Monad m+   , MaybeCatchable x xs+   , Liftable (Filter x xs) zs+   ) => Variant xs -> (x -> Flow m zs) -> Flow m zs+{-# INLINE (?~^>) #-}+(?~^>) v f = case catchVariantMaybe v of+   Right x -> f x+   Left ys -> return (liftVariant ys)++infixl 0 ?~^>++-- | Catch element, connect to the expected output+(>?~^>) :: forall x xs zs m.+   ( Monad m+   , MaybeCatchable x xs+   , Liftable (Filter x xs) zs+   ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs+{-# INLINE (>?~^>) #-}+(>?~^>) = liftm (?~^>)++infixl 0 >?~^>++-- | Catch element, connect to the expected output+(%~^>) :: forall x xs zs m.+   ( Monad m+   , Catchable x xs+   , Liftable (Filter x xs) zs+   ) => Variant xs -> (x -> Flow m zs) -> Flow m zs+{-# INLINE (%~^>) #-}+(%~^>) = (?~^>)++infixl 0 %~^>++-- | Catch element, connect to the expected output+(>%~^>) :: forall x xs zs m.+   ( Monad m+   , Catchable x xs+   , Liftable (Filter x xs) zs+   ) => Flow m xs -> (x -> Flow m zs) -> Flow m zs+{-# INLINE (>%~^>) #-}+(>%~^>) = liftm (%~^>)++infixl 0 >%~^>++-- | Catch element, use the same output type+(?~$>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Variant xs -> (x -> Flow m xs) -> Flow m xs+{-# INLINE (?~$>) #-}+(?~$>) v f = case catchVariantMaybe v of+   Right x -> f x+   Left _  -> return v++infixl 0 ?~$>++-- | Catch element, use the same output type+(>?~$>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs+{-# INLINE (>?~$>) #-}+(>?~$>) = liftm (?~$>)++infixl 0 >?~$>++-- | Catch element, use the same output type+(%~$>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Variant xs -> (x -> Flow m xs) -> Flow m xs+{-# INLINE (%~$>) #-}+(%~$>) = (?~$>)++infixl 0 %~$>++-- | Catch element, use the same output type+(>%~$>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Flow m xs -> (x -> Flow m xs) -> Flow m xs+{-# INLINE (>%~$>) #-}+(>%~$>) = liftm (%~$>)++infixl 0 >%~$>++-- | Catch element, fusion the result+(?~|>) :: forall x xs ys zs m.+   ( Monad m+   , MaybeCatchable 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 catchVariantMaybe v of+   Right x -> liftVariant <$> f x+   Left ys -> return (liftVariant ys)++infixl 0 ?~|>++-- | Catch element, fusion the result+(>?~|>) :: forall x xs ys zs m.+   ( Monad m+   , MaybeCatchable 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 >?~|>++-- | Catch element, fusion the result+(%~|>) :: forall x xs ys zs m.+   ( Monad m+   , Catchable 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 %~|>++-- | Catch element, fusion the result+(>%~|>) :: forall x xs ys zs m.+   ( Monad m+   , Catchable 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 >%~|>++-- | Catch element and perform effect. Passthrough the input value.+(?~=>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Variant xs -> (x -> m ()) -> Flow m xs+{-# INLINE (?~=>) #-}+(?~=>) v f = case catchVariantMaybe v of+   Right x -> f x >> return v+   Left _  -> return v++infixl 0 ?~=>++-- | Catch element and perform effect. Passthrough the input value.+(>?~=>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Flow m xs -> (x -> m ()) -> Flow m xs+{-# INLINE (>?~=>) #-}+(>?~=>) = liftm (?~=>)++infixl 0 >?~=>++-- | Catch element and perform effect. Passthrough the input value.+(%~=>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Variant xs -> (x -> m ()) -> Flow m xs+{-# INLINE (%~=>) #-}+(%~=>) = (?~=>)++infixl 0 %~=>++-- | Catch element and perform effect. Passthrough the input value.+(>%~=>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Flow m xs -> (x -> m ()) -> Flow m xs+{-# INLINE (>%~=>) #-}+(>%~=>) = liftm (%~=>)++infixl 0 >%~=>++-- | Catch element and perform effect.+(?~!>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Variant xs -> (x -> m ()) -> m ()+{-# INLINE (?~!>) #-}+(?~!>) v f = case catchVariantMaybe v of+   Right x -> f x+   Left _  -> return ()++infixl 0 ?~!>++-- | Catch element and perform effect.+(>?~!>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Flow m xs -> (x -> m ()) -> m ()+{-# INLINE (>?~!>) #-}+(>?~!>) = liftm (?~!>)++infixl 0 >?~!>++-- | Catch element and perform effect.+(%~!>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Variant xs -> (x -> m ()) -> m ()+{-# INLINE (%~!>) #-}+(%~!>) = (?~!>)++infixl 0 %~!>++-- | Catch element and perform effect.+(>%~!>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Flow m xs -> (x -> m ()) -> m ()+{-# INLINE (>%~!>) #-}+(>%~!>) = liftm (%~!>)++infixl 0 >%~!>++-- | Catch element and perform effect.+(?~!!>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Variant xs -> (x -> m ()) -> Flow m (Filter x xs)+{-# INLINE (?~!!>) #-}+(?~!!>) v f = case catchVariantMaybe v of+   Right x -> f x >> error "?~!!> error"+   Left u  -> return u++infixl 0 ?~!!>++-- | Catch element and perform effect.+(>?~!!>) :: forall x xs m.+   ( Monad m+   , MaybeCatchable x xs+   ) => Flow m xs -> (x -> m ()) -> Flow m (Filter x xs)+{-# INLINE (>?~!!>) #-}+(>?~!!>) = liftm (?~!!>)++infixl 0 >?~!!>++-- | Catch element and perform effect.+(%~!!>) :: forall x xs m.+   ( Monad m+   , Catchable x xs+   ) => Variant xs -> (x -> m ()) -> Flow m (Filter x xs)+{-# INLINE (%~!!>) #-}+(%~!!>) = (?~!!>)++infixl 0 %~!!>++-- | Catch element and perform effect.+(>%~!!>) :: forall x xs m.+   ( Monad m+   , Catchable 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 (setVariantN @0) . headVariant++-- | 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 ::+   ( Catchable x xs+   ) => Variant xs -> Either (Variant (Filter x xs)) (Variant '[x])+{-# INLINE selectType #-}+selectType = fmap (setVariantN @0) . catchVariant++-- | 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 (setVariantN @0) . f++-- | Lift a monadic function+applyF :: (a -> Flow m b) -> Variant '[a] -> Flow m b+{-# INLINE applyF #-}+applyF f = f . singleVariant++-- | 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 -> singleVariant x+   Left  x -> singleVariant x+++-- | Lift a pure function into a Variant to Variant function+liftV :: (a -> b) -> Variant '[a] -> Variant '[b]+liftV = updateVariantN @0++-- | Lift a function into a Flow+liftF :: Monad m => (a -> m b) -> Variant '[a] -> Flow m '[b]+liftF = updateVariantM @0
+ src/lib/Haskus/Utils/HArray.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Heterogeneous array: like a HList but indexed in O(1)+module Haskus.Utils.HArray+   ( HArray+   , HArrayIndex+   , HArrayIndexT+   , HArrayTryIndexT+   , emptyHArray+   , singleHArray+   , getHArrayN+   , getHArray0+   , setHArrayN+   , getHArrayT+   , setHArrayT+   , tryGetHArrayT+   , appendHArray+   , prependHArray+   , concatHArray+   , initHArray+   , tailHArray+   , HArrayT (..)+   , (>~:~>)+   )+where++import Data.Vector as V+import Unsafe.Coerce++import Haskus.Utils.Types.List+import Haskus.Utils.Types+import Haskus.Utils.Flow++-- | heterogeneous array+data HArray (types :: [*]) = forall a. HArray (Vector a)++type role HArray representational++-- | Empty array+emptyHArray :: HArray '[]+emptyHArray = HArray V.empty++-- | Empty array+singleHArray :: a -> HArray '[a]+singleHArray = HArray . V.singleton++-- | The type `t` with index `n` is indexable in the array+type HArrayIndex (n :: Nat) t (ts :: [*]) =+   ( KnownNat n+   , t ~ Index n ts+   , KnownNat (Length ts)+   , CmpNat n (Length ts) ~ 'LT+   )++-- | A type `t` is indexable in the array+type HArrayIndexT t (ts :: [*]) =+   ( IsMember t ts ~ 'True+   , HArrayIndex (IndexOf t ts) t ts+   )++-- | A type `t` is maybe indexable in the array+type HArrayTryIndexT t (ts :: [*]) =+   ( HArrayIndex (MaybeIndexOf t ts) t (t ': ts)+   )+++-- | Get an element by index+getHArrayN :: forall (n :: Nat) (ts :: [*]) t.+   ( HArrayIndex n t ts) => HArray ts -> t+getHArrayN (HArray as) = unsafeCoerce (as ! natValue @n)++-- | Get first element+getHArray0 :: (HArrayIndex 0 t ts) => HArray ts -> t+getHArray0 = getHArrayN @0++-- | Set an element by index+setHArrayN :: forall (n :: Nat) (ts :: [*]) t.+   (HArrayIndex n t ts) => t -> HArray ts -> HArray ts+setHArrayN a (HArray as) = HArray (as V.// [(natValue @n,unsafeCoerce a)])++-- | Get an element by type (select the first one with this type)+getHArrayT :: forall t ts.+   (HArrayIndexT t ts) => HArray ts -> t+getHArrayT = getHArrayN @(IndexOf t ts)++-- | Set an element by type (select the first one with this type)+setHArrayT :: forall t ts.+   (HArrayIndexT t ts) => t -> HArray ts -> HArray ts+setHArrayT = setHArrayN @(IndexOf t ts)++-- | Get an element by type (select the first one with this type)+tryGetHArrayT :: forall t ts.+   (HArrayTryIndexT t ts) => HArray ts -> Maybe t+tryGetHArrayT as = if n == 0+      then Nothing+      else Just $ getHArrayN @(MaybeIndexOf t ts) as'+   where+      n   = natValue' @(MaybeIndexOf t ts)+      as' :: HArray (t ': ts)+      as' = prependHArray undefined as++-- | Append a value to an array (O(n))+appendHArray :: HArray ts -> t -> HArray (Snoc ts t)+appendHArray (HArray as) a = HArray (V.snoc as (unsafeCoerce a))++-- | Prepend a value to an array (O(n))+prependHArray :: t -> HArray ts -> HArray (t ': ts)+prependHArray a (HArray as) = HArray (V.cons (unsafeCoerce a) as)++-- | Concat arrays+concatHArray :: HArray ts1 -> HArray ts2 -> HArray (Concat ts1 ts2)+concatHArray (HArray as1) (HArray as2) = HArray (V.concat [as1,unsafeCoerce as2])++-- | Drop the last element+initHArray :: HArray ts -> HArray (Init ts)+initHArray (HArray as) = HArray (V.init as)++-- | Drop the first element+tailHArray :: HArray ts -> HArray (Tail ts)+tailHArray (HArray as) = HArray (V.tail as)++newtype HArrayT m xs ys = HArrayT+   { runHArrayT :: HArray xs -> m (HArray ys)+   }++-- | Compose HArrayT+(>~:~>) :: (Monad m) => HArrayT m xs ys -> HArrayT m ys zs -> HArrayT m xs zs+(>~:~>) (HArrayT f) (HArrayT g) = HArrayT (f >=> g)
+ src/lib/Haskus/Utils/HList.hs view
@@ -0,0 +1,252 @@+{-# 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
+ src/lib/Haskus/Utils/List.hs view
@@ -0,0 +1,14 @@+module Haskus.Utils.List+   ( checkLength+   , module Data.List+   )+where++import Data.List++-- | 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
+ src/lib/Haskus/Utils/Map.hs view
@@ -0,0 +1,6 @@+module Haskus.Utils.Map+   ( module Data.Map+   )+where++import Data.Map
+ src/lib/Haskus/Utils/Maybe.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE LambdaCase #-}++-- | Utils for Maybe data type+module Haskus.Utils.Maybe+   ( onNothing+   , onNothingM+   , fromMaybeM+   , 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+
+ src/lib/Haskus/Utils/Monad.hs view
@@ -0,0 +1,43 @@+{-# 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)
+ src/lib/Haskus/Utils/MultiState.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | State monad with multiple states (extensible)+--+-- Similar to the multistate package, with the following differences (as of+-- 0.7.0.0):+--    * don't pollute Data.HList.HList+--    * use HArray instead of a HList, for fast indexing+module Haskus.Utils.MultiState+   ( MStateT+   , MState+   , mSet+   , mGet+   , mTryGet+   , mModify+   , mModify'+   , mWith+   , runMState+   , evalMState+   , execMState+   , liftMStateT+   , (>~:>)+   , (>:>)+   )+where++import Control.Monad.State.Lazy+import Control.Monad.Identity++import Haskus.Utils.HArray++-- | Multi-state monad transformer+--+-- States are stacked in a heterogeneous array.+type MStateT (s :: [*]) m a = StateT (HArray s) m a++-- | Multi-state+type MState (s :: [*]) a = MStateT s Identity a++-- | Run MState+runMState :: MState s a -> HArray s -> (a,HArray s)+runMState act s = runIdentity (runStateT act s)++-- | Evaluate MState+evalMState :: MState s a -> HArray s -> a+evalMState act s = runIdentity (evalStateT act s)++-- | Execute MState+execMState :: MState s a -> HArray s -> HArray s+execMState act s = runIdentity (execStateT act s)++-- | Set a value in the state+mSet :: (Monad m, HArrayIndexT a s) => a -> MStateT s m ()+mSet = modify' . setHArrayT++-- | Get a value in the state+mGet :: (Monad m, HArrayIndexT a s) => MStateT s m a+mGet = getHArrayT <$> get++-- | Try to get a value in the state+mTryGet :: (Monad m, HArrayTryIndexT a s) => MStateT s m (Maybe a)+mTryGet = tryGetHArrayT <$> get+++-- | Modify a value in the state+mModify :: (Monad m, HArrayIndexT a s) => (a -> a) -> MStateT s m ()+mModify f = modify (\s -> setHArrayT (f (getHArrayT s)) s)++-- | Modify a value in the state (strict version)+mModify' :: (Monad m, HArrayIndexT a s) => (a -> a) -> MStateT s m ()+mModify' f = modify' (\s -> setHArrayT (f (getHArrayT s)) s)++-- | Execute an action with an extended state+mWith :: forall s a m b.+   ( Monad m+   ) => a -> MStateT (a ': s) m b -> MStateT s m b+mWith v act = do+   s <- get+   (r,s') <- lift $ runStateT act (prependHArray v s)+   put (tailHArray s')+   return r++-- | Lift a multi-state into an HArray transformer+liftMStateT :: (Monad m) => MStateT xs m x -> HArrayT m xs (x ': xs)+liftMStateT act = HArrayT $ \xs -> do+   (x,xs') <- runStateT act xs+   return (prependHArray x xs')++-- | Compose MStateT+(>~:>) :: (Monad m) => HArrayT m xs ys -> MStateT ys m y -> HArrayT m xs (y ': ys)+(>~:>) f g = f >~:~> liftMStateT g++-- | Compose MStateT+(>:>) :: (Monad m) => MStateT xs m x -> MStateT (x ': xs) m y -> HArrayT m xs (y ': x ': xs)+(>:>) f g = liftMStateT f >~:~> liftMStateT g
+ src/lib/Haskus/Utils/Parser.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Tools to write parsers using Flows+module Haskus.Utils.Parser+   ( ParseError (..)+   , Choice (..)+   , choice+   , choice'+   , manyBounded+   , manyAtMost+   , manyAtMost'+   , manyAtMost''+   , many+   , manyAtLeast+   , manyTill+   , manyTill'+   )+where++import Prelude hiding (min,max)+import Haskus.Utils.HList+import Haskus.Utils.Types.List+import Haskus.Utils.Flow+import Haskus.Utils.Variant+++-- A parser is a Flow function that can either:+--    - return a parsed value or a semantic error+--    - fail with a ParseError:+--       - not enough input+--       - syntax error+--++-- | Parser error+data ParseError+   = SyntaxError+   | EndOfInput+   deriving (Show,Eq)++-- We can define combinators between parsers++data Choice a = Choice++instance forall x y z xs ys zs m a.+      ( x ~ Flow m xs+      , y ~ Flow m ys+      , z ~ Flow m zs+      , Catchable a xs+      , Liftable ys zs+      , Liftable (Filter a xs) zs+      , zs ~ Union (Filter a xs) ys+      , Monad m+      ) => Apply (Choice a) (x,y) z+   where+      apply _ (x,y) = x >%~|> \(_ :: a) -> y++-- | Try to apply the actions in the list in order, until one of them succeeds.+-- Returns the value of the succeeding action, or the value of the last one.+-- Failures are detected with values of type "ParseError".+choice :: forall m fs zs.+   ( Monad m+   , HFoldl (Choice ParseError) (Flow m '[ParseError]) fs (Flow m zs)+   ) => HList fs -> Flow m zs+choice = choice' @ParseError++-- | Try to apply the actions in the list in order, until one of them succeeds.+-- Returns the value of the succeeding action, or the value of the last one.+-- Failures are detected with values of type "a".+choice' :: forall a m fs zs.+   ( Monad m+   , HFoldl (Choice a) (Flow m '[a]) fs (Flow m zs)+   ) => HList fs -> Flow m zs+choice' = hFoldl (Choice :: Choice a) (flowSingle undefined :: Flow m '[a])++-- | Apply the action zero or more times (until a ParseError result is+-- returned)+many ::+   ( zs ~ Filter ParseError xs+   , Monad m+   , Catchable ParseError xs+   ) => Flow m xs -> Flow m '[[Variant zs]]+many f = manyBounded Nothing Nothing f+            >%~^> \(_ :: ParseError) -> flowSingle []++-- | Apply the action zero or more times (up to max) until a ParseError result+-- is returned+manyAtMost ::+   ( zs ~ Filter ParseError xs+   , Monad m+   , Catchable ParseError xs+   ) => Word -> Flow m xs -> Flow m '[[Variant zs]]+manyAtMost max f = manyBounded Nothing (Just max) f+                     >%~^> \(_ :: ParseError) -> flowSingle []++-- | Apply the action zero or more times (up to max) until a ParseError result+-- is returned+manyAtMost' ::+   ( zs ~ Filter ParseError xs+   , Monad m+   , Catchable ParseError xs+   ) => Word -> Flow m xs -> m [Variant zs]+manyAtMost' max f = singleVariant <$> manyAtMost max f++-- | Apply the action zero or more times (up to max) until a ParseError result+-- is returned+manyAtMost'' ::+   ( '[x] ~ Filter ParseError xs+   , Monad m+   , Catchable ParseError xs+   ) => Word -> Flow m xs -> m [x]+manyAtMost'' max f = fmap singleVariant <$> manyAtMost' max f++-- | Apply the action at least n times or more times (until a ParseError+-- result is returned)+manyAtLeast ::+   ( zs ~ Filter ParseError xs+   , Monad m+   , Catchable ParseError xs+   ) => Word -> Flow m xs -> Flow m '[[Variant zs],ParseError]+manyAtLeast min = manyBounded (Just min) Nothing++-- | Apply the first action zero or more times until the second succeeds.+-- If the first action fails, the whole operation fails.+--+-- Return both the list of first values and the ending value+manyTill ::+   ( zs ~ Filter ParseError xs+   , zs' ~ Filter ParseError ys+   , Monad m+   , MaybeCatchable ParseError xs+   , Catchable ParseError ys+   ) => Flow m xs -> Flow m ys -> Flow m '[([Variant zs],Variant zs'),ParseError]+manyTill f g = go []+   where+      go xs = do+         v <- g+         case catchVariant v of+            Right EndOfInput  -> flowSet EndOfInput+            Right SyntaxError -> do+               u <- f+               case catchVariantMaybe u of+                  Right (e :: ParseError) -> flowSet e+                  Left x                  -> go (x:xs)+            Left x            -> flowSet (reverse xs,x)++-- | Apply the first action zero or more times until the second succeeds.+-- If the first action fails, the whole operation fails.+--+-- Return only the list of first values+manyTill' ::+   ( zs ~ Filter ParseError xs+   , Monad m+   , MaybeCatchable ParseError xs+   , Catchable ParseError ys+   ) => Flow m xs -> Flow m ys -> Flow m '[[Variant zs],ParseError]+manyTill' f g = manyTill f g >.-.> fst++-- | Apply the given action at least 'min' times and at most 'max' time+--+-- On failure, fails.+manyBounded :: forall zs xs m.+   ( zs ~ Filter ParseError xs+   , Monad m+   , MaybeCatchable ParseError xs+   ) => Maybe Word -> Maybe Word -> Flow m xs -> Flow m '[[Variant zs],ParseError]+manyBounded _ (Just 0) _   = flowSet ([] :: [Variant zs])+manyBounded (Just 0) max f = manyBounded Nothing max f+manyBounded min max f      = do+   v <- f+   case catchVariantMaybe v of+      Right (e :: ParseError) -> case min of+         Just n | n > 0 -> flowSet e+         _              -> flowSet ([] :: [Variant zs])+      Left x           -> do+         let minus1 = fmap (\k -> k - 1)+         xs <- manyBounded (minus1 min) (minus1 max) f+         case toEither xs of+            Left (e :: ParseError) -> flowSet e+            Right xs'              -> flowSet (x : xs')+
+ src/lib/Haskus/Utils/STM.hs view
@@ -0,0 +1,61 @@+-- | STM helpers+module Haskus.Utils.STM+   ( S.STM+   , S.retry+   , atomically+   -- ** TVar+   , S.TVar+   , newTVarIO+   , readTVarIO+   , S.writeTVar+   , S.readTVar+   , S.newTVar+   , S.swapTVar+   , S.modifyTVar+   , S.modifyTVar'+   -- ** TMVar+   , S.TMVar+   , newTMVarIO+   , S.isEmptyTMVar+   , S.newEmptyTMVar+   , S.newEmptyTMVarIO+   , S.readTMVar+   , S.takeTMVar+   , S.putTMVar+   , S.swapTMVar+   , S.tryReadTMVar+   , S.tryPutTMVar+   , S.tryTakeTMVar+   -- ** TChan+   , S.TChan+   , newBroadcastTChanIO+   , S.newBroadcastTChan+   , S.writeTChan+   , S.dupTChan+   , S.readTChan+   )+where++import Control.Concurrent.STM (STM, TVar, TMVar, TChan)+import qualified Control.Concurrent.STM as S+import Haskus.Utils.Monad++-- | Execute an STM transaction atomically+atomically :: MonadIO m => STM a -> m a+atomically = liftIO . S.atomically++-- | Read a TVar in an IO monad+readTVarIO :: MonadIO m => TVar a -> m a+readTVarIO = liftIO . S.readTVarIO++-- | Create a broadcast channel+newBroadcastTChanIO :: MonadIO m => m (TChan a)+newBroadcastTChanIO = liftIO S.newBroadcastTChanIO++-- | Create a TVar+newTVarIO :: MonadIO m => a -> m (TVar a)+newTVarIO = liftIO . S.newTVarIO++-- | Create a TMVar+newTMVarIO :: MonadIO m => a -> m (TMVar a)+newTMVarIO = liftIO . S.newTMVarIO
+ src/lib/Haskus/Utils/STM/Future.hs view
@@ -0,0 +1,59 @@+-- | Future values (values that can only be set once)+module Haskus.Utils.STM.Future+   ( Future+   , FutureSource+   , newFuture+   , newFutureIO+   , waitFuture+   , pollFuture+   , pollFutureIO+   , setFuture+   , setFutureIO+   , setFuture'+   )+where++import Haskus.Utils.STM+import Haskus.Utils.Flow++-- | Future value of type a+newtype Future a       = Future (TMVar a)++-- | Setter for a future value+newtype FutureSource a = FutureSource (TMVar a)++-- | Create a Future and its source+newFuture :: STM (Future a, FutureSource a)+newFuture = do+   m <- newEmptyTMVar+   return (Future m, FutureSource m)++-- | `newFuture` in `IO`+newFutureIO :: MonadIO m => m (Future a, FutureSource a)+newFutureIO = atomically newFuture++-- | Set a future+setFuture :: a -> FutureSource a -> STM ()+setFuture a m = void (setFuture' a m)++-- | Set a future in IO+setFutureIO :: MonadIO m => a -> FutureSource a -> m ()+setFutureIO a m = atomically (setFuture a m)++-- | Set a future+--+-- Return False if it has already been set+setFuture' :: a -> FutureSource a -> STM Bool+setFuture' a (FutureSource m) = tryPutTMVar m a++-- | Wait for a future+waitFuture :: Future a -> STM a+waitFuture (Future m) = readTMVar m++-- | Poll a future+pollFuture :: Future a -> STM (Maybe a)+pollFuture (Future m) = tryReadTMVar m++-- | `pollFuture` in `IO`+pollFutureIO :: MonadIO m => Future a -> m (Maybe a)+pollFutureIO = atomically . pollFuture
+ src/lib/Haskus/Utils/STM/TEq.hs view
@@ -0,0 +1,17 @@+-- | Equality in a STM context+module Haskus.Utils.STM.TEq+   ( TEq (..)+   )+where++import Haskus.Utils.STM++class TEq a where+   teq :: a -> a -> STM Bool+++instance Eq a => TEq (TVar a) where+   teq a b = do+      a' <- readTVar a+      b' <- readTVar b+      return (a' == b')
+ src/lib/Haskus/Utils/STM/TGraph.hs view
@@ -0,0 +1,85 @@+-- | Transactionnal graph+module Haskus.Utils.STM.TGraph+   ( deepFirst+   , breadthFirst+   , TNode (..)+   , singleton+   , linkTo+   )+where++import qualified Data.Set as Set++import Haskus.Utils.STM+import Haskus.Utils.Flow+import Haskus.Utils.STM.TList (TList)+import qualified Haskus.Utils.STM.TList as TList++-- | Deep-first graph traversal+--+-- before is executed when the node is entered+-- after is executed when the node is leaved+-- children gets node's children+--+deepFirst :: (Monad m, Ord a) => (a -> m ()) -> (a -> m ()) -> (a -> m [a]) -> [a] -> m ()+deepFirst before after children = foldM_ go Set.empty+   where+      go visited x +         | Set.member x visited = +            -- the node is already visited+            return visited++         | otherwise = do+            before x+            cs <- children x+            -- add current node to the visited ones to avoid "loops"+            let visited' = Set.insert x visited+            -- visited "children" nodes+            visited'' <- foldM go visited' cs+            after x+            return visited''++-- | Breadth-first graph traversal+--+-- visit is executed when the node is entered. If False is returned, the traversal ends+-- children gets node's children+--+breadthFirst :: (Monad m, Ord a) => (a -> m Bool) -> (a -> m [a]) -> [a] -> m ()+breadthFirst visit children = go Set.empty+   where+      go _ [] = +         -- there are no more nodes to visit+         return ()++      go visited (x:xs) +         | Set.member x visited = +            -- the node is already visited, we skip it+            go visited xs++         | otherwise = do+            b <- visit x+            -- if "visit" returns False, we stop the traversal+            when b $ do+               -- otherwise we add children to the list of nodes to+               -- visit and we continue the traversal+               cs <- children x+               go (Set.insert x visited) (xs ++ cs)+++-- | A node contains a value and two lists of incoming/outgoing edges+data TNode a r = TNode+   { nodeValue :: a+   , nodeEdgeIn :: TList (r, TNode a r)+   , nodeEdgeOut :: TList (r, TNode a r)+   }++-- | Create a graph node+singleton :: a -> STM (TNode a r)+singleton v = TNode v <$> TList.empty <*> TList.empty++-- | Link two nodes together+linkTo :: TNode a r -> r -> TNode a r -> STM ()+linkTo src rel dst = do+   void $ TList.append (rel, src) (nodeEdgeIn dst)+   void $ TList.append (rel, dst) (nodeEdgeOut src)+
+ src/lib/Haskus/Utils/STM/TList.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}++-- | Transactional list+module Haskus.Utils.STM.TList+   ( TList+   , TNode+   , empty+   , singleton+   , null+   , length+   , first+   , last+   , prev+   , next+   , value+   , deleteAll+   , delete+   , filter+   , find+   , append+   , append_+   , prepend+   , prepend_+   , insertBefore+   , insertAfter+   , toList+   , toReverseList+   , fromList+   , index+   , take+   )+where++import Prelude hiding (null,length,last,filter,take)++import Haskus.Utils.STM+import Haskus.Utils.Flow+import Haskus.Utils.Maybe++-- | A double linked-list+newtype TList a = TList (TNode a)++-- | A node in the list+--+-- Every list has a marker node whose value is Nothing. Its nodePrev links to+-- the last node and its nodeNext links to the first node.+data TNode a = TNode+   { nodeValue :: Maybe a         -- value (Nothing if list marker)+   , nodePrev  :: TVar (TNode a)  -- previous node+   , nodeNext  :: TVar (TNode a)  -- next node+   }++-- | Get value associated with a node+value :: TNode a -> a+value node = case nodeValue node of+   Just v  -> v+   Nothing -> error "TList: empty node value"++-- | Empty node singleton+empty :: STM (TList a)+empty = do+   p <- newTVar undefined+   n <- newTVar undefined+   let node = TNode Nothing p n+   -- initially the marker node refers to itself+   writeTVar p node+   writeTVar n node+   return (TList node)++-- | Remove all the elements of the list (O(1))+deleteAll :: TList a -> STM ()+deleteAll (TList m) = do+   -- make the marker node refer to itself+   writeTVar (nodeNext m) m+   writeTVar (nodePrev m) m++-- | Create a singleton list+singleton :: e -> STM (TList e)+singleton e = do+   m <- empty+   void $ append e m+   return m++-- | Indicate if the list is empty+null :: TList e -> STM Bool+null (TList m) = do+   h <- readTVar (nodeNext m)+   -- if the list is empty, the marker node refers to itself, hence the value of+   -- the nodeNext node is Nothing+   return (isNothing (nodeValue h))++-- | Count the number of elements in the list (0(n))+length :: TList e -> STM Word+length (TList m) = go 0 m+   where+      go !n node = do+         node' <- readTVar (nodeNext node)+         case nodeValue node' of+            Nothing -> return n+            Just _  -> go (n+1) node'++-- | Get the first element if any+first :: TList e -> STM (Maybe (TNode e))+first (TList m) = next m++-- | Get the last element if any+last :: TList e -> STM (Maybe (TNode e))+last (TList m) = prev m++-- | Get the previous element if any+prev :: TNode a -> STM (Maybe (TNode a))+prev n = do+   h <- readTVar (nodePrev n)+   case nodeValue h of+      Nothing -> return Nothing+      Just _  -> return (Just h)++-- | Get the next element if any+next :: TNode a -> STM (Maybe (TNode a))+next n = do+   h <- readTVar (nodeNext n)+   case nodeValue h of+      Nothing -> return Nothing+      Just _  -> return (Just h)+++-- | Delete a element of the list+delete :: TNode a -> STM ()+delete n = do+   -- if somehow we delete the marker node, we get a ring-list+   left <- readTVar $ nodePrev n+   right <- readTVar $ nodeNext n+   writeTVar (nodeNext left) right+   writeTVar (nodePrev right) left+   -- Link list node to itself so subsequent 'delete' calls will be harmless.+   writeTVar (nodePrev n) n+   writeTVar (nodeNext n) n++-- | Insert a node between two adjacent nodes.+insertBetween :: a -> TNode a -> TNode a -> STM (TNode a)+insertBetween v left right = do+   n <- TNode (Just v) <$> newTVar left +                       <*> newTVar right+   writeTVar (nodeNext left)  n+   writeTVar (nodePrev right) n+   return n++-- | Append an element to the list+append :: a -> TList a -> STM (TNode a)+append v (TList m) = insertAfter v m++-- | Append an element to the list+append_ :: a -> TList a -> STM ()+append_ a = void . append a++-- | Prepend an element to the list+prepend :: a -> TList a -> STM (TNode a)+prepend v (TList m) = insertBefore v m++-- | Prepend an element to the list+prepend_ :: a -> TList a -> STM ()+prepend_ a = void . prepend a++-- | Insert an element before another+insertBefore :: a -> TNode a -> STM (TNode a)+insertBefore v n = do+   right <- readTVar $ nodeNext n+   insertBetween v n right++-- | Insert an element after another+insertAfter :: a -> TNode a -> STM (TNode a)+insertAfter v n = do+   left <- readTVar $ nodePrev n+   insertBetween v left n++-- | Convert into a list (O(n))+toList :: TList a -> STM [a]+toList (TList m) = go [] m+   where+      go !xs node = do+         node' <- readTVar (nodePrev node)+         case nodeValue node' of+            Nothing -> return xs+            Just x  -> go (x:xs) node'++-- | Convert into a reversed list (O(n))+toReverseList :: TList a -> STM [a]+toReverseList (TList m) = go [] m+   where+      go !xs node = do+         node' <- readTVar (nodeNext node)+         case nodeValue node' of+            Nothing -> return xs+            Just x  -> go (x:xs) node'++-- | Create from a list+fromList :: [e] -> STM (TList e)+fromList xs = do+   s <- empty+   forM_ xs (`append` s)+   return s++-- | Only keep element matching the criterium+filter :: (e -> STM Bool) -> TList e -> STM ()+filter f (TList m) = go m+   where+      go node = do+         node' <- readTVar (nodeNext node)+         case nodeValue node' of+            Nothing -> return ()+            Just v  -> do+               p <- f v+               if not p+                  then delete node' >> go node+                  else go node'++-- | Find the first node matching the predicate (if any)+find :: (e -> STM Bool) -> TList e -> STM (Maybe (TNode e))+find f (TList m) = go m+   where+      go node = do+         node' <- readTVar (nodeNext node)+         case nodeValue node' of+            Nothing -> return Nothing+            Just v  -> do+               p <- f v+               if p+                  then return (Just node')+                  else go node'++-- | Get the node from its index+index :: Word -> TList e -> STM (Maybe (TNode e))+index n (TList m) = go n m+   where+      go !i node = do+         node' <- readTVar (nodeNext node)+         case nodeValue node' of+            Nothing        -> return Nothing+            Just _+               | i == 0    -> return (Just node')+               | otherwise -> go (i-1) node'++-- | Take (and remove) up to n elements in the list (O(n))+take :: Word -> TList e -> STM [e]+take n l = index n l >>= \case+   -- return the whole list+   Nothing -> do+      r <- toList l+      deleteAll l+      return r++   -- build the list and remove elements at the same time+   Just node -> go [] node+      where+         go !xs node' = do+            case nodeValue node' of+               Nothing -> return xs+               Just x  -> do+                  p <- readTVar (nodePrev node')+                  delete node'+                  go (x:xs) p
+ src/lib/Haskus/Utils/STM/TMap.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ConstraintKinds #-}++-- | STm hashmap+module Haskus.Utils.STM.TMap+   ( TMap+   , Key+   , null+   , size+   , lookup+   , member+   , notMember+   , empty+   , singleton+   , insert+   , fromList+   , delete+   , elems+   , keys+   , (!)+   )+where++import Prelude hiding (lookup,null)++import Haskus.Utils.STM+import qualified STMContainers.Map as SMAP+import STMContainers.Map (Key)+import ListT (fold)+import qualified ListT++import Haskus.Utils.Maybe (fromJust,isJust,isNothing)++-- | STM hashmap+type TMap a b = SMAP.Map a b++-- | Indicate if the map is empty+null :: TMap a b -> STM Bool+null = SMAP.null++-- | Get the number of elements in the map+size :: TMap a b -> STM Int+size = fold f 0 . SMAP.stream+   where +      f n _ = return (n+1)++-- | Lookup an element in the map from its key+lookup :: Key k => k -> TMap k a -> STM (Maybe a)+lookup = SMAP.lookup++-- | Check if a key is in the map+member :: Key k => k -> TMap k b -> STM Bool+member k m = isJust <$> lookup k m++-- | Check if a key is not in the map+notMember :: Key k => k -> TMap k b -> STM Bool+notMember k m = isNothing <$> lookup k m++-- | Create an empty map+empty :: STM (TMap a b)+empty = SMAP.new++-- | Create a map containing a single element+singleton :: Key k => k -> v -> STM (TMap k v)+singleton k v = do+   m <- empty+   insert k v m+   return m++-- | Insert an element in the map+insert :: Key k => k -> v -> TMap k v -> STM ()+insert k v = SMAP.insert v k++-- | Create a new TMap from a list+fromList :: Key k => [(k,v)] -> STM (TMap k v)+fromList vs = do+   m <- empty+   mapM_ (\(k,v) -> insert k v m) vs+   return m++-- | Delete an element from the map+delete :: Key k => k -> TMap k v -> STM ()+delete = SMAP.delete++-- | Create a list of (key,value)+toList :: TMap a b -> STM [(a,b)]+toList = ListT.toList . SMAP.stream++-- | Get values+elems :: TMap a b -> STM [b]+elems = fmap (fmap snd) . toList++-- | Get keys+keys :: TMap a b -> STM [a]+keys = fmap (fmap fst) . toList++-- | Unsafe lookup in the map+(!) :: Key k => TMap k v -> k -> STM v+(!) m k = fromJust <$> lookup k m
+ src/lib/Haskus/Utils/STM/TSet.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ConstraintKinds #-}++-- | STM mutable set+module Haskus.Utils.STM.TSet+   ( TSet+   , null+   , size+   , member+   , notMember+   , empty+   , singleton+   , insert+   , delete+   , toList+   , fromList+   , elems+   , stream+   , unions+   , map+   )+where++import Prelude hiding (lookup,null,map)++import Haskus.Utils.STM+import qualified STMContainers.Set as SSET+import STMContainers.Set (Element)+import ListT (ListT, fold)+import qualified ListT++import Haskus.Utils.Flow (forM_)++-- | STM Set+type TSet a = SSET.Set a++-- | Indicate if the set is empty+null :: TSet a -> STM Bool+null = SSET.null++-- | Number of elements in the set+size :: TSet a -> STM Int+size = fold f 0 . SSET.stream+   where +      f n _ = return (n+1)++-- | Check if an element is in the set+member :: Element e => e -> TSet e -> STM Bool+member = SSET.lookup++-- | Check if an element is not in the set+notMember :: Element e => e -> TSet e -> STM Bool+notMember e s = not <$> member e s++-- | Create an empty set+empty :: STM (TSet e)+empty = SSET.new++-- | Create a set containing a single element+singleton :: Element e => e -> STM (TSet e)+singleton e = do+   m <- empty+   insert e m+   return m++-- | Insert an element in a set+insert :: Element e => e -> TSet e -> STM ()+insert = SSET.insert++-- | Delete an element from a set+delete :: Element e => e -> TSet e -> STM ()+delete = SSET.delete++-- | Convert a set into a list+toList :: TSet e -> STM [e]+toList = ListT.toList . SSET.stream++-- | Create a set from a list+fromList :: Element e => [e] -> STM (TSet e)+fromList xs = do+   s <- empty+   forM_ xs (`insert` s)+   return s++-- | Get the set elements+elems :: TSet e -> STM [e]+elems = toList++-- | Get the set as a ListT stream+stream :: TSet e -> ListT STM e+stream = SSET.stream++-- | Perform a set union+unions :: Element e => [TSet e] -> STM (TSet e)+unions ss = do+   ret <- empty+   forM_ ss $ \s -> +      ListT.traverse_ (`insert` ret) (stream s)+   return ret++-- | Apply a function to each element in the set+map :: (Element b) => (a -> b) -> TSet a -> STM (TSet b)+map f m = do+   r <- empty+   ListT.traverse_ (\x -> insert (f x) r) (stream m)+   return r++--filter :: (a -> Bool) -> TSet a -> STM ()+--filter f = withTVar (Set.filter f)
+ src/lib/Haskus/Utils/STM/TTree.hs view
@@ -0,0 +1,78 @@+-- | STM mutable tree+module Haskus.Utils.STM.TTree+   ( TTree (..)+   , TTreePath (..)+   , singleton+   , addChild+   , detachChild+   , attachChild+   , treeFollowPath+   )+where++import qualified Haskus.Utils.STM.TList as TList+import Haskus.Utils.STM.TList (TList)+import Haskus.Utils.STM.TEq+import Haskus.Utils.STM++-- | A STM mutable tree+data TTree k v = TTree+   { treeKey      :: k                        -- ^ Node identifier+   , treeValue    :: v                        -- ^ Node value+   , treeChildren :: TList (TTree k v)        -- ^ Children+   , treeParent   :: TVar (Maybe (TTree k v)) -- ^ Parent+   }++-- | Path in the tree+newtype TTreePath k = TTreePath [k]+++-- | Create a singleton node+singleton :: k -> v -> STM (TTree k v)+singleton k v =+   TTree k v+      <$> TList.empty+      <*> newTVar Nothing++-- | Add a child+addChild :: k -> v -> TTree k v -> STM (TTree k v)+addChild k v parent = do+   n <- TTree k v+      <$> TList.empty+      <*> newTVar (Just parent)++   TList.append_ n (treeChildren parent)+   return n++-- | Detach a child+detachChild :: TEq k => TTree k v -> STM ()+detachChild n = do+   +   -- remove child from parent+   let f c = not <$> (treeKey c `teq` treeKey n)+   p <- readTVar (treeParent n)+   mapM_ (TList.filter f . treeChildren) p++   -- remove parent from child+   writeTVar (treeParent n) Nothing++-- | Attach a child a node (detaching it from a previous one if necessary)+attachChild :: TEq k => TTree k v -> TTree k v -> STM ()+attachChild newparent child = do+   -- detach from the previous parent (if any)+   detachChild child++   -- add to newparent's children list+   TList.append_ child (treeChildren newparent)++   -- set newparent+   writeTVar (treeParent child) (Just newparent)++-- | Follow a path from a parent node+treeFollowPath :: TEq k => TTree k v -> TTreePath k -> STM (Maybe (TTree k v))+treeFollowPath p (TTreePath [])     = return (Just p)+treeFollowPath p (TTreePath (x:xs)) = do+   child <- TList.find (\y -> x `teq` treeKey y) (treeChildren p)+   case TList.value <$> child of+      Just c  -> treeFollowPath c (TTreePath xs)+      Nothing -> return Nothing
+ src/lib/Haskus/Utils/Tuple.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++-- | Tuple helpers+module Haskus.Utils.Tuple+   ( 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 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)
+ src/lib/Haskus/Utils/Types.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Common type functions+module Haskus.Utils.Types+   ( Nat+   , Symbol+   , natValue+   , natValue'+   , symbolValue+   , KnownNat+   , KnownSymbol+   , CmpNat+   , CmpSymbol+   , type (<=?)+   , type (<=)+   , type (+)+   , type (-)+   , type (*)+   , type (^)+   , If+   , IfNat+   , 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 t e where+   If 'True  t e = t+   If 'False t e = e++-- | If-then-else+type family IfNat c (t :: Nat) (e :: Nat) where+   IfNat 'True  t e = t+   IfNat 'False t e = e++-- | 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
+ src/lib/Haskus/Utils/Types/Generics.hs view
@@ -0,0 +1,75 @@+{-# 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]
+ src/lib/Haskus/Utils/Types/List.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Utils for type lists+module Haskus.Utils.Types.List+   ( MapNat+   , Max+   , Tail+   , Drop+   , Take+   , Init+   , Head+   , Snoc+   , ReplaceAt+   , Replace+   , ReplaceN+   , Reverse+   , RemoveAt+   , RemoveAt1+   , Concat+   , Length+   , Replicate+   , MapMaybe+   , Generate+   , IsMember+   , IsSubset+   , Indexes+   , MapTest+   , Zip+   , Filter+   , Nub+   , NubHead+   , IndexOf+   , MaybeIndexOf+   , Index+   , Union+   , Member+   , CheckNub+   )+where++import Haskus.Utils.Types++-- | Map a type function returning a Nat+type family MapNat (f :: * -> Nat) (xs :: [*]) where+   MapNat f '[]       = '[]+   MapNat f (x ': xs) = f x ': MapNat 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' (IfNat (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 '[]       = 0+   Length (x ': xs) = 1 + Length xs++-- | Replicate+type family Replicate n s where+   Replicate 0 s = '[]+   Replicate n s = s ': Replicate (n-1) s++-- | 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++-- | Reverse a list+type family Reverse (l :: [*]) where+   Reverse l = ReverseEx l '[]++type family ReverseEx (l :: [*]) (l2 :: [*]) where+   ReverseEx '[] l       = l+   ReverseEx (x ': xs) l = ReverseEx 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++-- | 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 = IsMemberEx a l l++-- | Check that a type is member of a type list+type family IsMemberEx a l (i :: [*]) :: Bool where+   IsMemberEx a (a ': l) i = 'True+   IsMemberEx a (b ': l) i = IsMemberEx a l i+   IsMemberEx a '[]      i = 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 = IsSubsetEx l1 l2 l2++-- | Helper for IsSubset+type family IsSubsetEx l1 l2 i :: Bool where+   IsSubsetEx '[] l2 i = 'True+   IsSubsetEx l1 '[] i = TypeError (     'ShowType l1+                                   ':$$: 'Text "is not a subset of"+                                   ':$$: 'ShowType i)+   IsSubsetEx (x ': xs) (x ': ys) i = IsSubsetEx xs i i+   IsSubsetEx (x ': xs) (y ': ys) i = IsSubsetEx (x ': xs) ys i++-- | 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 ': xs) = Filter a xs+   Filter a (x ': xs) = x ': Filter a xs++-- | Keep only a single value of each type+type family Nub (l :: [*]) where+   Nub '[]       = '[]+   Nub (x ': xs) = x ': Nub (Filter 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 = IndexOfEx x xs xs++-- | Get the first index of a type+type family IndexOfEx a (l :: [*]) (l2 :: [*]) :: Nat where+   IndexOfEx x (x ': xs) l2 = 0+   IndexOfEx y (x ': xs) l2 = 1 + IndexOfEx y xs l2+   IndexOfEx y '[]       l2 = TypeError ( 'Text "`"+                                    ':<>: 'ShowType y+                                    ':<>: 'Text "'"+                                    ':<>: 'Text " is not a member of "+                                    ':<>: 'ShowType l2)+++-- | 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+      )+
+ src/lib/Haskus/Utils/Variant.hs view
@@ -0,0 +1,932 @@+{-# 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 #-}++-- | Typed Variant type (union)+module Haskus.Utils.Variant+   ( Variant+   , variantIndex+   , getVariantN+   , setVariantN+   , updateVariantN+   , setVariant+   , getVariant+   , updateVariant+   , updateVariantM+   , updateVariantFold+   , updateVariantFoldN+   , updateVariantFoldM+   , variantToHList+   , variantToTuple+   , liftEither+   , liftEitherM+   , variantRemoveType+   , Member+   , Catchable+   , MaybeCatchable+   , Liftable+   , catchVariant+   , catchVariantMaybe+   , pickVariant+   , headVariant+   , singleVariant+   , appendVariant+   , prependVariant+   , liftVariant+   , liftVariantM+   , toEither+   , ContVariant (..)+   )+where++import Unsafe.Coerce+import GHC.Exts (Any)++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++-- | Make GHC consider `l` as a representational parameter to make coercions+-- between Variant values unsafe+type role Variant representational++-- | Get Variant index+variantIndex :: Variant a -> Word+variantIndex (Variant n _) = n++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 (headVariant v1, headVariant 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 (headVariant v1, headVariant 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 headVariant v of+         Right x -> show x+         Left xs -> show xs++-- | Set the value with the given indexed type+setVariantN :: forall (n :: Nat) (l :: [*]).+   ( KnownNat n+   ) => Index n l -> Variant l+{-# INLINE setVariantN #-}+setVariantN a = Variant (natValue @n) (unsafeCoerce a)++-- | Get the value if it has the indexed type+getVariantN :: forall (n :: Nat) (l :: [*]).+   ( KnownNat n+   ) => Variant l -> Maybe (Index n l)+{-# INLINE getVariantN #-}+getVariantN (Variant t a) = do+   guard (t == natValue @n)+   return (unsafeCoerce a) -- we know it is the effective type++-- | Lift an Either into a Variant (reversed order by convention)+liftEither :: Either a b -> Variant '[b,a]+{-# INLINE liftEither #-}+liftEither (Left a)  = setVariantN @1 a+liftEither (Right b) = setVariantN @0 b++-- | Lift an Either into a Variant (reversed order by convention)+liftEitherM :: (Monad m) => m (Either a b) -> m (Variant '[b,a])+liftEitherM = fmap liftEither++-- | Update a variant value+updateVariantN :: forall (n :: Nat) a b l.+   ( KnownNat n+   , a ~ Index n l+   ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)+{-# INLINE updateVariantN #-}+updateVariantN f v@(Variant t a) =+   case getVariantN @n v of+      Nothing -> Variant t a+      Just x  -> Variant t (unsafeCoerce (f x))++-- | Update a variant value in a Monad+updateVariantM :: forall (n :: Nat) l l2 m .+   (KnownNat n, Monad m)+   => (Index n l -> m (Index n l2)) -> Variant l -> m (Variant l2)+{-# INLINE updateVariantM #-}+updateVariantM f v@(Variant t a) =+   case getVariantN @n v of+      Nothing -> return (Variant t a)+      Just x  -> Variant t <$> unsafeCoerce (f x)++-- | Update a variant value with a variant and fold the result+updateVariantFoldN :: forall (n :: Nat) l l2 .+   ( KnownNat n+   , KnownNat (Length l2)+   ) => (Index n l -> Variant l2) -> Variant l -> Variant (ReplaceAt n l l2)+updateVariantFoldN f v@(Variant t a) =+   case getVariantN @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+updateVariantFold :: 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)+updateVariantFold f v = updateVariantFoldN @n f v++-- | Update a variant value with a variant and fold the result+updateVariantFoldM :: 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))+updateVariantFoldM f v@(Variant t a) =+   case getVariantN @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)+++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) =+            getVariantN @0 v `HCons` variantToHList v'+         where+            v' :: Variant xs+            v' = Variant (t-1) a+++class VariantRemoveType a xs where+   -- | Remove a type from a variant+   variantRemoveType :: Variant xs -> Either (Variant (Filter a xs)) a++instance VariantRemoveType a '[] where+   variantRemoveType _ = undefined++instance forall a xs n xs' y ys.+      ( VariantRemoveType a xs'+      , n ~ MaybeIndexOf a xs+      , xs' ~ RemoveAt1 n xs+      , Filter a xs' ~ Filter a xs+      , KnownNat n+      , xs ~ (y ': ys)+      ) => VariantRemoveType a (y ': ys)+   where+      {-# INLINE variantRemoveType #-}+      variantRemoveType (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   -> variantRemoveType @a @xs' (Variant (t-1) a)+              | otherwise -> Left (Variant t a)++-- | a is catchable in xs+type Catchable a xs =+   ( IsMember a xs ~ 'True+   , VariantRemoveType a xs+   )++-- | a may be catchable in xs+type MaybeCatchable a xs =+   ( VariantRemoveType a xs+   )++-- | Extract a type from a variant. Return either the value of this type or the+-- remaining variant+catchVariant :: forall a xs.+   ( Catchable a xs+   ) => Variant xs -> Either (Variant (Filter a xs)) a+catchVariant v = variantRemoveType @a v++-- | Extract a type from a variant. Return either the value of this type or the+-- remaining variant+catchVariantMaybe :: forall a xs.+   ( MaybeCatchable a xs+   ) => Variant xs -> Either (Variant (Filter a xs)) a+catchVariantMaybe v = variantRemoveType @a v++-- | Pick a variant value+pickVariant :: forall (n :: Nat) l. +   ( KnownNat n+   ) => Variant l -> Either (Variant (RemoveAt n l)) (Index n l)+{-# INLINE pickVariant #-}+pickVariant v@(Variant t a) = case getVariantN @n v of+   Just x  -> Right x+   Nothing -> Left $ if t > natValue @n+      then Variant (t-1) a+      else Variant t a++-- | Pick the head of a variant value+headVariant :: forall x xs. Variant (x ': xs) -> Either (Variant xs) x+{-# INLINE headVariant #-}+headVariant v@(Variant t a) = case getVariantN @0 v of+   Just x  -> Right x+   Nothing -> Left $ 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++-- | Retreive the last v+singleVariant :: Variant '[a] -> a+{-# INLINE singleVariant #-}+singleVariant (Variant _ a) = unsafeCoerce a+++-- | 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)++-- | Set the first matching type of a Variant+setVariant :: forall a l.+   ( Member a l+   ) => a -> Variant l+{-# INLINE setVariant #-}+setVariant = setVariantN @(IndexOf a l)++-- | Set the first matching type of a Variant+getVariant :: forall a l.+   ( Member a l+   ) => Variant l -> Maybe a+{-# INLINE getVariant #-}+getVariant = getVariantN @(IndexOf a l)++-- | Update a variant value+updateVariant :: forall a b n l.+   ( Member a l+   , n ~ IndexOf a l+   ) => (a -> b) -> Variant l -> Variant (ReplaceN n b l)+{-# INLINE updateVariant #-}+updateVariant f v = updateVariantN @n f v+++-- | 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 x xs ys.+      ( VariantLift xs ys+      , KnownNat (IndexOf x ys)+      ) => VariantLift (x ': xs) ys+   where+      {-# INLINE liftVariant' #-}+      liftVariant' v = case headVariant v of+         Right a  -> Variant (natValue @(IndexOf x ys)) (unsafeCoerce a)+         Left  v' -> liftVariant' v'+++-- | 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'++liftVariantM ::+   ( Liftable xs ys+   , Monad m+   ) => Variant xs -> m (Variant ys)+{-# INLINE liftVariantM #-}+liftVariantM = return . liftVariant+++-- | Convert a variant of two values in a Either+toEither :: forall a b. Variant '[a,b] -> Either b a+toEither (Variant 0 a) = Right (unsafeCoerce a)+toEither (Variant _ a) = Left (unsafeCoerce a)+++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 (setVariantN @0)++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      Single (return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      , setVariantN @6+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @5+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      , setVariantN @6+      , setVariantN @7+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @5+      , return . setVariantN @6+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      , setVariantN @6+      , setVariantN @7+      , setVariantN @8+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @5+      , return . setVariantN @6+      , return . setVariantN @7+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      , setVariantN @6+      , setVariantN @7+      , setVariantN @8+      , setVariantN @9+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @5+      , return . setVariantN @6+      , return . setVariantN @7+      , return . setVariantN @8+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      , setVariantN @6+      , setVariantN @7+      , setVariantN @8+      , setVariantN @9+      , setVariantN @10+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @5+      , return . setVariantN @6+      , return . setVariantN @7+      , return . setVariantN @8+      , return . setVariantN @9+      , return . setVariantN @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 >::>+      ( setVariantN @0+      , setVariantN @1+      , setVariantN @2+      , setVariantN @3+      , setVariantN @4+      , setVariantN @5+      , setVariantN @6+      , setVariantN @7+      , setVariantN @8+      , setVariantN @9+      , setVariantN @10+      , setVariantN @11+      )++   {-# INLINE contToVariantM #-}+   contToVariantM c = c >::>+      ( return . setVariantN @0+      , return . setVariantN @1+      , return . setVariantN @2+      , return . setVariantN @3+      , return . setVariantN @4+      , return . setVariantN @5+      , return . setVariantN @6+      , return . setVariantN @7+      , return . setVariantN @8+      , return . setVariantN @9+      , return . setVariantN @10+      , return . setVariantN @11+      )
+ src/tests/Haskus/Tests/Utils.hs view
@@ -0,0 +1,14 @@+module Haskus.Tests.Utils where++import Test.Tasty++import Haskus.Tests.Utils.HArray+import Haskus.Tests.Utils.Variant++testsUtils :: TestTree+testsUtils = testGroup "Utils"+   [ testsHArray+   , testsVariant+   ]++
+ src/tests/Haskus/Tests/Utils/HArray.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Haskus.Tests.Utils.HArray+   ( testsHArray+   )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Haskus.Utils.HArray++testsHArray :: TestTree+testsHArray = testGroup "HArray" $+   [ testGroup "Getters"+      [ testProperty "Get by index 0" (getHArrayN @0 arr1 == 10)+      , testProperty "Get by index 1" (getHArrayN @1 arr1 == "Hello")+      , testProperty "Get by index 2" (getHArrayN @2 arr1 == False)+      , testProperty "Get by type 0"  (getHArrayT arr1 == (10 :: Int))+      , testProperty "Get by type 1"  (getHArrayT arr1 == "Hello")+      , testProperty "Get by type 2"  (getHArrayT arr1 == False)+      ]+   , testGroup "Setters"+      [ testProperty "Set by index 0" (testSetGetN @0 20      arr1)+      , testProperty "Set by index 1" (testSetGetN @1 "World" arr1)+      , testProperty "Set by index 2" (testSetGetN @2 True    arr1)+      , testProperty "Set by type 0"  (testSetGetT (20 :: Int) arr1)+      , testProperty "Set by type 1"  (testSetGetT "World"     arr1)+      , testProperty "Set by type 2"  (testSetGetT True        arr1)+      ]+   , testGroup "Concat"+      [ testProperty "Get by type 0"  (getHArrayT arr12 == (10 :: Int))+      , testProperty "Get by type 1"  (getHArrayT arr12 == "Hello")+      , testProperty "Get by type 2"  (getHArrayT arr12 == False)+      , testProperty "Get by type 3"  (getHArrayT arr12 == (2.5 :: Double))+      , testProperty "Get by type 4"  (getHArrayT arr12 == 'E')+      , testProperty "Get by type 0"  (getHArrayT arr21 == (10 :: Int))+      , testProperty "Get by type 1"  (getHArrayT arr21 == "Hello")+      , testProperty "Get by type 2"  (getHArrayT arr21 == False)+      , testProperty "Get by type 3"  (getHArrayT arr21 == (2.5 :: Double))+      , testProperty "Get by type 4"  (getHArrayT arr21 == 'E')+      , testProperty "Get by index 0" (getHArrayN @0 arr12 == 10)+      , testProperty "Get by index 1" (getHArrayN @1 arr12 == "Hello")+      , testProperty "Get by index 2" (getHArrayN @2 arr12 == False)+      , testProperty "Get by index 3" (getHArrayN @3 arr12 == 2.5)+      , testProperty "Get by index 4" (getHArrayN @4 arr12 == 'E')+      , testProperty "Get by index 0" (getHArrayN @0 arr21 == 2.5)+      , testProperty "Get by index 1" (getHArrayN @1 arr21 == 'E')+      , testProperty "Get by index 2" (getHArrayN @2 arr21 == 10)+      , testProperty "Get by index 3" (getHArrayN @3 arr21 == "Hello")+      , testProperty "Get by index 4" (getHArrayN @4 arr21 == False)+      ]+   , testGroup "TryGetHArray"+      [ testProperty "Try get by type valid"   (tryGetHArrayT arr1 == Just "Hello")+      , testProperty "Try get by type invalid" (tryGetHArrayT arr1 == (Nothing :: Maybe Char))+      ]+   ]+++arr1 :: HArray '[Int,String,Bool]+arr1 = prependHArray 10+   $ prependHArray "Hello"+   $ prependHArray False+   $ emptyHArray++testSetGetN :: forall n t ts.+   ( Eq t+   , HArrayIndex n t ts+   ) => t -> HArray ts -> Bool+testSetGetN a as = getHArrayN @n (setHArrayN @n a as) == a++testSetGetT ::+   ( Eq t+   , HArrayIndexT t ts+   ) => t -> HArray ts -> Bool+testSetGetT a as = getHArrayT (setHArrayT a as) == a++arr2 :: HArray '[Double,Char]+arr2 = prependHArray 2.5+   $ prependHArray 'E'+   $ emptyHArray++arr12 :: HArray '[Int,String,Bool,Double,Char]+arr12 = concatHArray arr1 arr2++arr21 :: HArray '[Double,Char,Int,String,Bool]+arr21 = concatHArray arr2 arr1
+ src/tests/Haskus/Tests/Utils/Variant.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++module Haskus.Tests.Utils.Variant+   ( testsVariant+   )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Data.Either++import Haskus.Utils.Variant++data A = A deriving (Show,Eq)+data B = B deriving (Show,Eq)+data C = C deriving (Show,Eq)+data D = D deriving (Show,Eq)+data E = E deriving (Show,Eq)+data F = F deriving (Show,Eq)++type ABC = Variant '[A,B,C]+type DEF = Variant '[D,E,F]++b :: ABC+b = setVariantN @1 B++b2d :: B -> D+b2d = const D++c2d :: C -> D+c2d = const D++b2def :: B -> DEF+b2def = const (setVariant E)++c2def :: C -> DEF+c2def = const (setVariant E)+++testsVariant :: TestTree+testsVariant = testGroup "Variant" $+   [ testProperty "set/get by index (match)"+         (getVariantN @1 b == Just B)+   , testProperty "set/get by index (dont' match)"+         (getVariantN @0 b == Nothing)+   , testProperty "set/get by type (match)"+         (getVariant    (setVariant B :: ABC) == Just B)+   , testProperty "set/get by type (don't match)"+         (getVariant @C (setVariant B :: ABC) == Nothing)++   , testProperty "variant equality (match)"+         (b == b)+   , testProperty "variant equality (don't match)"+         (b /= setVariant C)++   , testProperty "update by index (match)"+         (updateVariantN @1 (const D) b == setVariantN @1 D)+   , testProperty "update by index (don't match)"+         (updateVariantN @0 (const F) b == setVariantN @1 B)+   , testProperty "update by type (match)"+         (updateVariant b2d b == setVariantN @1 D)+   , testProperty "update by type (don't match)"+         (updateVariant c2d b == setVariant B)+   , testProperty "update/fold by index (match)"+         (updateVariantFoldN @1 b2def b == setVariant E)+   , testProperty "update/fold by index (don't match)"+         (updateVariantFoldN @2 c2def b == setVariant B)++   , testProperty "Convert into tuple"+         (variantToTuple b == (Nothing, Just B, Nothing))+   , testProperty "Convert single variant"+         (singleVariant (setVariant A :: Variant '[A]) == A)++   , testProperty "Lift Either: Left"+         (liftEither (Left A :: Either A B) == setVariant A)+   , testProperty "Lift Either: Right"+         (liftEither (Right B :: Either A B) == setVariant B)++   , testProperty "To Either: Left"+         (toEither (setVariant B :: Variant '[A,B]) == Left B)+   , testProperty "To Either: Right"+         (toEither (setVariant A :: Variant '[A,B]) == Right A)++   , testProperty "headVariant (match)"+         (headVariant (setVariant A :: ABC) == Right A)+   , testProperty "headVariant (don't match)"+         (isLeft (headVariant b))++   , testProperty "pickVariant (match)"+         (pickVariant @1 b == Right B)+   , testProperty "pickVariant (don't match)"+         (isLeft (pickVariant @2 b))++   , testProperty "catchVariant (match)"+         (catchVariant @D (setVariantN @4 D :: Variant '[A,B,C,B,D,E,D]) == Right D)+   , testProperty "catchVariant (match)"+         (catchVariant @D (setVariantN @6 D :: Variant '[A,B,C,B,D,E,D]) == Right D)+   , testProperty "catchVariant (don't match)"+         (catchVariant @B (setVariantN @4 D :: Variant '[A,B,C,B,D,E,D]) == Left (setVariantN @2 D))++   , testProperty "prependVariant"+         (getVariantN @4 (prependVariant @'[D,E,F] b) == Just B)+   , testProperty "appendVariant"+         (getVariantN @1 (appendVariant @'[D,E,F] b)  == Just B)++   , testProperty "liftVariant"+         (getVariant (liftVariant b :: Variant '[D,A,E,B,F,C])  == Just B)+   ]
+ src/tests/Main.hs view
@@ -0,0 +1,5 @@+import Haskus.Tests.Utils+import Test.Tasty++main :: IO ()+main = defaultMain testsUtils