diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2013-2017, Haskus organization +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of Sylvain Henry nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskus-utils.cabal b/haskus-utils.cabal new file mode 100644 --- /dev/null +++ b/haskus-utils.cabal @@ -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 diff --git a/src/lib/Haskus/Utils/ContFlow.hs b/src/lib/Haskus/Utils/ContFlow.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/ContFlow.hs @@ -0,0 +1,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 diff --git a/src/lib/Haskus/Utils/Embed.hs b/src/lib/Haskus/Utils/Embed.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Embed.hs @@ -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) diff --git a/src/lib/Haskus/Utils/Flow.hs b/src/lib/Haskus/Utils/Flow.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Flow.hs @@ -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 diff --git a/src/lib/Haskus/Utils/HArray.hs b/src/lib/Haskus/Utils/HArray.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/HArray.hs @@ -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) diff --git a/src/lib/Haskus/Utils/HList.hs b/src/lib/Haskus/Utils/HList.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/HList.hs @@ -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 diff --git a/src/lib/Haskus/Utils/List.hs b/src/lib/Haskus/Utils/List.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/List.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Map.hs b/src/lib/Haskus/Utils/Map.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Map.hs @@ -0,0 +1,6 @@ +module Haskus.Utils.Map + ( module Data.Map + ) +where + +import Data.Map diff --git a/src/lib/Haskus/Utils/Maybe.hs b/src/lib/Haskus/Utils/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Maybe.hs @@ -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 + diff --git a/src/lib/Haskus/Utils/Monad.hs b/src/lib/Haskus/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Monad.hs @@ -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) diff --git a/src/lib/Haskus/Utils/MultiState.hs b/src/lib/Haskus/Utils/MultiState.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/MultiState.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Parser.hs b/src/lib/Haskus/Utils/Parser.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Parser.hs @@ -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') + diff --git a/src/lib/Haskus/Utils/STM.hs b/src/lib/Haskus/Utils/STM.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM.hs @@ -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 diff --git a/src/lib/Haskus/Utils/STM/Future.hs b/src/lib/Haskus/Utils/STM/Future.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/Future.hs @@ -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 diff --git a/src/lib/Haskus/Utils/STM/TEq.hs b/src/lib/Haskus/Utils/STM/TEq.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/TEq.hs @@ -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') diff --git a/src/lib/Haskus/Utils/STM/TGraph.hs b/src/lib/Haskus/Utils/STM/TGraph.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/TGraph.hs @@ -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) + diff --git a/src/lib/Haskus/Utils/STM/TList.hs b/src/lib/Haskus/Utils/STM/TList.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/TList.hs @@ -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 diff --git a/src/lib/Haskus/Utils/STM/TMap.hs b/src/lib/Haskus/Utils/STM/TMap.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/TMap.hs @@ -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 diff --git a/src/lib/Haskus/Utils/STM/TSet.hs b/src/lib/Haskus/Utils/STM/TSet.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/TSet.hs @@ -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) diff --git a/src/lib/Haskus/Utils/STM/TTree.hs b/src/lib/Haskus/Utils/STM/TTree.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/STM/TTree.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Tuple.hs b/src/lib/Haskus/Utils/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Tuple.hs @@ -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) diff --git a/src/lib/Haskus/Utils/Types.hs b/src/lib/Haskus/Utils/Types.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Types.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Types/Generics.hs b/src/lib/Haskus/Utils/Types/Generics.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Types/Generics.hs @@ -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] diff --git a/src/lib/Haskus/Utils/Types/List.hs b/src/lib/Haskus/Utils/Types/List.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Types/List.hs @@ -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 + ) + diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Variant.hs @@ -0,0 +1,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 + ) diff --git a/src/tests/Haskus/Tests/Utils.hs b/src/tests/Haskus/Tests/Utils.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Utils.hs @@ -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 + ] + + diff --git a/src/tests/Haskus/Tests/Utils/HArray.hs b/src/tests/Haskus/Tests/Utils/HArray.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Utils/HArray.hs @@ -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 diff --git a/src/tests/Haskus/Tests/Utils/Variant.hs b/src/tests/Haskus/Tests/Utils/Variant.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Utils/Variant.hs @@ -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) + ] diff --git a/src/tests/Main.hs b/src/tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/tests/Main.hs @@ -0,0 +1,5 @@ +import Haskus.Tests.Utils +import Test.Tasty + +main :: IO () +main = defaultMain testsUtils