variant (empty) → 1.0
raw patch · 18 files changed
+4965/−0 lines, 18 filesdep +QuickCheckdep +basedep +criterion
Dependencies added: QuickCheck, base, criterion, deepseq, exceptions, mtl, recursion-schemes, tasty, tasty-quickcheck, template-haskell, transformers, unliftio-core, variant
Files
- LICENSE +27/−0
- src/bench/Main.hs +102/−0
- src/lib/Data/Variant.hs +1766/−0
- src/lib/Data/Variant/ContFlow.hs +100/−0
- src/lib/Data/Variant/EADT.hs +187/−0
- src/lib/Data/Variant/EADT/TH.hs +219/−0
- src/lib/Data/Variant/EGADT.hs +124/−0
- src/lib/Data/Variant/Excepts.hs +429/−0
- src/lib/Data/Variant/Functor.hs +187/−0
- src/lib/Data/Variant/Syntax.hs +29/−0
- src/lib/Data/Variant/Tuple.hs +553/−0
- src/lib/Data/Variant/Types.hs +202/−0
- src/lib/Data/Variant/VEither.hs +281/−0
- src/lib/Data/Variant/VariantF.hs +422/−0
- src/tests/EADT.hs +122/−0
- src/tests/Main.hs +10/−0
- src/tests/Variant.hs +117/−0
- variant.cabal +88/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013-2017, Haskus organization+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ * Neither the name of Sylvain Henry nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ src/bench/Main.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where+++import Data.Variant+import Data.Variant.ContFlow++import Criterion+import Criterion.Main (defaultMain)+import Test.QuickCheck+import Control.DeepSeq+import GHC.Generics+++data Node a+ = NValue a+ | NPlus (Node a) (Node a)+ | NMinus (Node a) (Node a)+ deriving (Generic,NFData)++instance Arbitrary a => Arbitrary (Node a) where+ arbitrary = do+ n <- getSize+ if n == 0+ then (NValue <$> arbitrary)+ else oneof+ [ resize (n-1) (NPlus <$> arbitrary <*> arbitrary)+ , resize (n-1) (NMinus <$> arbitrary <*> arbitrary)+ ]++evalNode :: Num a => Node a -> a+evalNode (NValue v) = v+evalNode (NPlus a b) = evalNode a + evalNode b+evalNode (NMinus a b) = evalNode a - evalNode b+++------------------------------------------+-- Variant+------------------------------------------++data Plus a = Plus a a deriving (Generic,NFData)+data Minus a = Minus a a deriving (Generic,NFData)+newtype Value a = Value a deriving newtype (NFData)++newtype VariantNode a+ = VariantNode (V '[Value a, Plus (VariantNode a), Minus (VariantNode a)])++deriving newtype instance (NFData a) => NFData (VariantNode a)++evalVariantNode :: Num a => VariantNode a -> a+evalVariantNode (VariantNode (V (Value v))) = v+evalVariantNode (VariantNode (V (Plus a b))) = evalVariantNode a + evalVariantNode b+evalVariantNode (VariantNode (V (Minus a b))) = evalVariantNode a - evalVariantNode b+evalVariantNode _ = undefined++evalVariantNodeSafe :: Num a => VariantNode a -> a+evalVariantNodeSafe (VariantNode v) = toCont v >::>+ ( \(Value x) -> x+ , \(Plus a b) -> evalVariantNodeSafe a + evalVariantNodeSafe b+ , \(Minus a b) -> evalVariantNodeSafe a - evalVariantNodeSafe b+ )++nodeToVariantNode :: Node a -> VariantNode a+nodeToVariantNode (NValue a) = VariantNode (toVariantAt @0 (Value a))+nodeToVariantNode (NPlus a b) = VariantNode (toVariantAt @1 (Plus (nodeToVariantNode a) (nodeToVariantNode b)))+nodeToVariantNode (NMinus a b) = VariantNode (toVariantAt @2 (Minus (nodeToVariantNode a) (nodeToVariantNode b)))++main :: IO ()+main = do+ let+ evalEnv n = do+ tree1 <- generate (resize n (arbitrary :: Gen (Node Int)))+ let tree2 = nodeToVariantNode tree1+ return (n,tree1,tree2)++ evalTest (n,tree1,tree2) = bgroup ("Tree Eval at size=" ++ show n)+ [ bench "ADT" $ whnf evalNode tree1+ , bench "Variant ADT - V" $ whnf evalVariantNode tree2+ , bench "Variant ADT - Safe match" $ whnf evalVariantNodeSafe tree2+ ]+++ defaultMain+ [ env (evalEnv 10) evalTest+ ]++++
+ src/lib/Data/Variant.hs view
@@ -0,0 +1,1766 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Open sum type+module Data.Variant+ ( V (..)+ , variantIndex+ , variantSize+ -- * Patterns+ , pattern V+ , pattern VMaybe+ , (:<)+ , (:<<)+ , (:<?)+ -- * Operations by index+ , toVariantAt+ , toVariantHead+ , toVariantTail+ , fromVariantAt+ , fromVariantHead+ , popVariantAt+ , popVariantHead+ , mapVariantAt+ , mapVariantAtM+ , foldMapVariantAt+ , foldMapVariantAtM+ , bindVariant+ , constBindVariant+ , variantHeadTail+ , mapVariantHeadTail+ -- * Operations by type+ , toVariant+ , popVariant+ , popVariantMaybe+ , fromVariant+ , fromVariantMaybe+ , fromVariantFirst+ , mapVariantFirst+ , mapVariantFirstM+ , mapVariant+ , mapNubVariant+ , foldMapVariantFirst+ , foldMapVariantFirstM+ , foldMapVariant+ , Member+ , Remove+ , ReplaceAll+ , MapVariant+ -- * Generic operations with type classes+ , alterVariant+ , traverseVariant+ , traverseVariant_+ , reduceVariant+ , NoConstraint+ , AlterVariant+ , TraverseVariant+ , ReduceVariant+ -- * Conversions between variants+ , appendVariant+ , prependVariant+ , liftVariant+ , nubVariant+ , productVariant+ , flattenVariant+ , joinVariant+ , joinVariantUnsafe+ , splitVariant+ , LiftVariant+ , Flattenable+ , FlattenVariant+ , ExtractM+ , JoinVariant+ , SplitVariant+ -- * Conversions to/from other data types+ , variantToValue+ , variantFromValue+ , variantToEither+ , variantFromEither+ -- ** Continuations+ , ContVariant (..)+ -- ** Internals+ , pattern VSilent+ , liftVariant'+ , fromVariant'+ , popVariant'+ , toVariant'+ , LiftVariant'+ , PopVariant+ , ToVariantMaybe(..)+ , showsVariant+ )+where++import Unsafe.Coerce+import GHC.Exts (Any)+import Data.Typeable+import Data.Kind+import GHC.TypeLits+import Control.DeepSeq+import Control.Exception+import Control.Monad++import Data.Variant.Types+import Data.Variant.Tuple+import Data.Variant.ContFlow++-- $setup+-- >>> :seti -XDataKinds+-- >>> :seti -XTypeApplications+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeFamilies+++-- | A variant contains a value whose type is at the given position in the type+-- list+data V (l :: [Type]) = Variant {-# UNPACK #-} !Word Any++-- Make GHC consider `l` as a representational parameter to make coercions+-- between Variant values unsafe+type role V representational++-- | Pattern synonym for Variant+--+-- Usage: case v of+-- V (x :: Int) -> ...+-- V (x :: String) -> ...+pattern V :: forall c cs. (c :< cs) => c -> V cs+pattern V x <- (fromVariant -> Just x)+ where+ V x = toVariant x++-- | Silent pattern synonym for Variant+--+-- Usage: case v of+-- VSilent (x :: Int) -> ...+-- VSilent (x :: String) -> ...+pattern VSilent :: forall c cs.+ ( Member c cs+ , PopVariant c cs+ ) => c -> V cs+pattern VSilent x <- (fromVariant' -> Just x)+ where+ VSilent x = toVariant' x++-- | Statically unchecked matching on a Variant+pattern VMaybe :: forall c cs. (c :<? cs) => c -> V cs+pattern VMaybe x <- (fromVariantMaybe -> Just x)++instance Eq (V '[]) where+ (==) _ _ = True++instance+ ( Eq (V xs)+ , Eq x+ ) => Eq (V (x ': xs))+ where+ {-# INLINABLE (==) #-}+ (==) v1@(Variant t1 _) v2@(Variant t2 _)+ | t1 /= t2 = False+ | otherwise = case (popVariantHead v1, popVariantHead v2) of+ (Right a, Right b) -> a == b+ (Left as, Left bs) -> as == bs+ _ -> False++instance Ord (V '[]) where+ compare = error "Empty variant"++instance+ ( Ord (V xs)+ , Ord x+ ) => Ord (V (x ': xs))+ where+ compare v1 v2 = case (popVariantHead v1, popVariantHead v2) of+ (Right a, Right b) -> compare a b+ (Left as, Left bs) -> compare as bs+ (Right _, Left _) -> LT+ (Left _, Right _) -> GT++class ShowVariantValue a where+ showVariantValue :: a -> ShowS++instance ShowVariantValue (V '[]) where+ {-# INLINABLE showVariantValue #-}+ showVariantValue _ = showString "undefined"++instance+ ( ShowVariantValue (V xs)+ , Show x+ , Typeable x+ ) => ShowVariantValue (V (x ': xs))+ where+ {-# INLINABLE showVariantValue #-}+ showVariantValue v = case popVariantHead v of+ Right x -> showString "V @"+ . showsPrec 10 (typeOf x)+ . showChar ' '+ . showsPrec 11 x+ Left xs -> showVariantValue xs++-- | Haskell code corresponding to a Variant+--+-- >>> showsVariant 0 (V @Double 5.0 :: V [Int,String,Double]) ""+-- "V @Double 5.0 :: V '[Int, [Char], Double]"+showsVariant ::+ ( Typeable xs+ , ShowTypeList (V xs)+ , ShowVariantValue (V xs)+ ) => Int -> V xs -> ShowS+showsVariant d v = showParen (d /= 0) $+ showVariantValue v+ . showString " :: "+ -- disabled until GHC fixes #14341+ -- . showsPrec 0 (typeOf v)+ -- workaround:+ . showString "V "+ . showList__ (showTypeList v)++instance Show (V '[]) where+ {-# INLINABLE showsPrec #-}+ showsPrec _ _ = undefined+++-- | Show instance+--+-- >>> show (V @Int 10 :: V '[Int,String,Double])+-- "10"+instance+ ( Show x+ , Show (V xs)+ ) => Show (V (x ': xs))+ where+ showsPrec d v = case popVariantHead v of+ Right x -> showsPrec d x+ Left xs -> showsPrec d xs++-- | Show a list of ShowS+showList__ :: [ShowS] -> ShowS+showList__ [] s = "'[]" ++ s+showList__ (x:xs) s = '\'' : '[' : x (showl xs)+ where+ showl [] = ']' : s+ showl (y:ys) = ',' : ' ' : y (showl ys)++-- Workaround as GHC doesn't print type-level lists correctly as of GHC 8.6+-- (see https://ghc.haskell.org/trac/ghc/ticket/14341)+--+-- We use V as we would use Proxy+class ShowTypeList a where+ showTypeList :: a -> [ShowS]++instance ShowTypeList (V '[]) where+ {-# INLINABLE showTypeList #-}+ showTypeList _ = []++instance (Typeable x, ShowTypeList (V xs)) => ShowTypeList (V (x ': xs)) where+ {-# INLINABLE showTypeList #-}+ showTypeList _ = showsPrec 0 (typeOf (undefined :: x)) : showTypeList (undefined :: V xs)++instance Exception (V '[]) where++instance+ ( Exception x+ , Typeable xs+ , Exception (V xs)+ ) => Exception (V (x ': xs))++-- | Get Variant index+--+-- >>> let x = V "Test" :: V [Int,String,Double]+-- >>> variantIndex x+-- 1+-- >>> let y = toVariantAt @0 10 :: V [Int,String,Double]+-- >>> variantIndex y+-- 0+--+variantIndex :: V a -> Word+variantIndex (Variant n _) = n++-- | Get variant size+--+-- >>> let x = V "Test" :: V '[Int,String,Double]+-- >>> variantSize x+-- 3+-- >>> let y = toVariantAt @0 10 :: V [Int,String,Double,Int]+-- >>> variantSize y+-- 4+variantSize :: forall xs. (KnownNat (Length xs)) => V xs -> Word+variantSize _ = natValue @(Length xs)++-----------------------------------------------------------+-- Operations by index+-----------------------------------------------------------++-- | Set the value with the given indexed type+--+-- >>> toVariantAt @1 10 :: V [Word,Int,Double]+-- 10+--+toVariantAt :: forall (n :: Nat) (l :: [Type]).+ ( KnownNat n+ ) => Index n l -> V l+{-# INLINABLE toVariantAt #-}+toVariantAt a = Variant (natValue' @n) (unsafeCoerce a)++-- | Set the first value+--+-- >>> toVariantHead 10 :: V [Int,Float,Word]+-- 10+--+toVariantHead :: forall x xs. x -> V (x ': xs)+{-# INLINABLE toVariantHead #-}+toVariantHead a = Variant 0 (unsafeCoerce a)++-- | Set the tail+--+-- >>> let x = V @Int 10 :: V [Int,String,Float]+-- >>> let y = toVariantTail @Double x+-- >>> :t y+-- y :: V [Double, Int, String, Float]+--+toVariantTail :: forall x xs. V xs -> V (x ': xs)+{-# INLINABLE toVariantTail #-}+toVariantTail (Variant t a) = Variant (t+1) a++-- | Try to get a value by index into the type list+--+-- >>> let x = V "Test" :: V [Int,String,Float]+-- >>> fromVariantAt @0 x+-- Nothing+-- >>> fromVariantAt @1 x+-- Just "Test"+-- >>> fromVariantAt @2 x+-- Nothing+--+fromVariantAt :: forall (n :: Nat) (l :: [Type]).+ ( KnownNat n+ ) => V l -> Maybe (Index n l)+{-# INLINABLE fromVariantAt #-}+fromVariantAt (Variant t a) = do+ guard (t == natValue' @n)+ return (unsafeCoerce a) -- we know it is the effective type++-- | Try to get the first variant value+--+-- >>> let x = V "Test" :: V [Int,String,Float]+-- >>> fromVariantHead x+-- Nothing+-- >>> let y = V @Int 10 :: V [Int,String,Float]+-- >>> fromVariantHead y+-- Just 10+--+fromVariantHead :: V (x ': xs) -> Maybe x+{-# INLINABLE fromVariantHead #-}+fromVariantHead v = fromVariantAt @0 v++-- | Pop a variant value by index, return either the value or the remaining+-- variant+--+-- >>> let x = V @Word 10 :: V [Int,Word,Float]+-- >>> popVariantAt @0 x+-- Left 10+-- >>> popVariantAt @1 x+-- Right 10+-- >>> popVariantAt @2 x+-- Left 10+--+popVariantAt :: forall (n :: Nat) l. + ( KnownNat n+ ) => V l -> Either (V (RemoveAt n l)) (Index n l)+{-# INLINABLE popVariantAt #-}+popVariantAt v@(Variant t a) = case fromVariantAt @n v of+ Just x -> Right x+ Nothing -> Left $ if t > natValue' @n+ then Variant (t-1) a+ else Variant t a++-- | Pop the head of a variant value+--+-- >>> let x = V @Word 10 :: V [Int,Word,Float]+-- >>> popVariantHead x+-- Left 10+--+-- >>> let y = V @Int 10 :: V [Int,Word,Float]+-- >>> popVariantHead y+-- Right 10+--+popVariantHead :: forall x xs. V (x ': xs) -> Either (V xs) x+{-# INLINABLE popVariantHead #-}+popVariantHead v@(Variant t a) = case fromVariantAt @0 v of+ Just x -> Right x+ Nothing -> Left $ Variant (t-1) a++-- | Update a single variant value by index+--+-- >>> import Data.Char (toUpper)+-- >>> let x = V @String "Test" :: V [Int,String,Float]+-- >>> mapVariantAt @1 (fmap toUpper) x+-- "TEST"+--+-- >>> mapVariantAt @0 (+1) x+-- "Test"+mapVariantAt :: forall (n :: Nat) a b l.+ ( KnownNat n+ , a ~ Index n l+ ) => (a -> b) -> V l -> V (ReplaceN n b l)+{-# INLINABLE mapVariantAt #-}+mapVariantAt f v@(Variant t a) =+ case fromVariantAt @n v of+ Nothing -> Variant t a+ Just x -> Variant t (unsafeCoerce (f x))++-- | Applicative update of a single variant value by index+--+-- Example with `Maybe`:+--+-- >>> let f s = if s == "Test" then Just (42 :: Word) else Nothing+-- >>> let x = V @String "Test" :: V [Int,String,Float]+-- >>> mapVariantAtM @1 f x+-- Just 42+--+-- >>> let y = V @String "NotTest" :: V [Int,String,Float]+-- >>> mapVariantAtM @1 f y+-- Nothing+--+-- Example with `IO`:+--+-- >>> v <- mapVariantAtM @0 print x+--+-- >>> :t v+-- v :: V [(), String, Float]+--+-- >>> v <- mapVariantAtM @1 print x+-- "Test"+--+-- >>> :t v+-- v :: V [Int, (), Float]+--+-- >>> v <- mapVariantAtM @2 print x+-- +-- >>> :t v+-- v :: V [Int, [Char], ()]+--+mapVariantAtM :: forall (n :: Nat) a b l m .+ ( KnownNat n+ , Applicative m+ , a ~ Index n l+ )+ => (a -> m b) -> V l -> m (V (ReplaceN n b l))+{-# INLINABLE mapVariantAtM #-}+mapVariantAtM f v@(Variant t a) =+ case fromVariantAt @n v of+ Nothing -> pure (Variant t a)+ Just x -> Variant t <$> unsafeCoerce (f x)++-- | Bind (>>=) for a Variant+bindVariant :: forall x xs ys.+ ( KnownNat (Length ys)+ ) => V (x ': xs) -> (x -> V ys) -> V (Concat ys xs)+{-# INLINABLE bindVariant #-}+v `bindVariant` f = case popVariantHead v of+ Right x -> appendVariant @xs (f x)+ Left xs -> prependVariant @ys xs++-- | Const bind (>>) for a Variant+constBindVariant :: forall xs ys.+ V xs -> V ys -> V (Concat ys xs)+{-# INLINABLE constBindVariant #-}+_ `constBindVariant` v2 = appendVariant @xs v2+++-- | List-like catamorphism+--+-- >>> let f = variantHeadTail (\i -> "Found Int: " ++ show i) (const "Something else")+-- >>> f (V @String "Test" :: V [Int,String,Float])+-- "Something else"+--+-- >>> f (V @Int 10 :: V [Int,String,Float])+-- "Found Int: 10"+--+variantHeadTail :: (x -> u) -> (V xs -> u) -> V (x ': xs) -> u+{-# INLINABLE variantHeadTail #-}+variantHeadTail fh ft x = case popVariantHead x of+ Right h -> fh h+ Left t -> ft t++-- | Bimap Variant head and tail +--+-- >>> let f = mapVariantHeadTail (+5) (appendVariant @'[Double,Char])+-- >>> f (V @Int 10 :: V [Int,Word,Float])+-- 15+--+-- >>> f (V @Word 20 :: V [Int,Word,Float])+-- 20+--+mapVariantHeadTail :: (x -> y) -> (V xs -> V ys) -> V (x ': xs) -> V (y ': ys)+{-# INLINABLE mapVariantHeadTail #-}+mapVariantHeadTail fh ft x = case popVariantHead x of+ Right h -> toVariantHead (fh h)+ Left t -> toVariantTail (ft t)++-----------------------------------------------------------+-- Operations by type+-----------------------------------------------------------++-- | Put a value into a Variant+--+-- Use the first matching type index.+toVariant :: forall a l.+ ( a :< l+ ) => a -> V l+{-# INLINABLE toVariant #-}+toVariant = toVariantAt @(IndexOf a l)++-- | Put a value into a Variant (silent)+--+-- Use the first matching type index.+toVariant' :: forall a l.+ ( Member a l+ ) => a -> V l+{-# INLINABLE toVariant' #-}+toVariant' = toVariantAt @(IndexOf a l)+++-- | Put a value into a variant if possible+--+-- >>> toVariantMaybe "Test" :: Maybe (V [Int,Float])+-- Nothing+--+-- >>> toVariantMaybe "Test" :: Maybe (V [Int,Float,String])+-- Just "Test"+--+class ToVariantMaybe a xs where+ -- | Put a value into a Variant, when the Variant's row contains that type.+ toVariantMaybe :: a -> Maybe (V xs)++instance ToVariantMaybe a '[] where+ {-# INLINABLE toVariantMaybe #-}+ toVariantMaybe _ = Nothing++instance forall a xs n y ys.+ ( n ~ MaybeIndexOf a xs+ , KnownNat n+ , xs ~ (y ': ys)+ ) => ToVariantMaybe a (y ': ys)+ where+ {-# INLINABLE toVariantMaybe #-}+ toVariantMaybe a+ = case natValue' @n of+ 0 -> Nothing+ n -> Just (Variant (n-1) (unsafeCoerce a))++class PopVariant a xs where+ -- | Remove a type from a variant+ popVariant' :: V xs -> Either (V (Remove a xs)) a++instance PopVariant a '[] where+ {-# INLINABLE popVariant' #-}+ popVariant' _ = undefined++instance forall a xs n xs' y ys.+ ( PopVariant a xs'+ , n ~ MaybeIndexOf a xs+ , xs' ~ RemoveAt1 n xs+ , Remove a xs' ~ Remove a xs+ , KnownNat n+ , xs ~ (y ': ys)+ ) => PopVariant a (y ': ys)+ where+ {-# INLINABLE popVariant' #-}+ popVariant' (Variant t a)+ = case natValue' @n of+ 0 -> Left (Variant t a) -- no 'a' left in xs+ n | n-1 == t -> Right (unsafeCoerce a)+ | n-1 < t -> popVariant' @a @xs' (Variant (t-1) a)+ | otherwise -> Left (Variant t a)++class SplitVariant as rs xs where+ splitVariant' :: V xs -> Either (V rs) (V as)++instance SplitVariant as rs '[] where+ {-# INLINABLE splitVariant' #-}+ splitVariant' _ = undefined++instance forall as rs xs x n m.+ ( n ~ MaybeIndexOf x as+ , m ~ MaybeIndexOf x rs+ , SplitVariant as rs xs+ , KnownNat m+ , KnownNat n+ ) => SplitVariant as rs (x ': xs)+ where+ {-# INLINABLE splitVariant' #-}+ splitVariant' (Variant 0 v)+ = case natValue' @n of+ -- we assume that if `x` isn't in `as`, it is in `rs`+ -- hence we don't test if `m == 0`+ 0 -> Left (Variant (natValue' @m - 1) v)+ t -> Right (Variant (t-1) v)+ splitVariant' (Variant t v)+ = splitVariant' @as @rs (Variant (t-1) v :: V xs)++-- | Split a variant in two+splitVariant :: forall as xs.+ ( SplitVariant as (Complement xs as) xs+ ) => V xs -> Either (V (Complement xs as)) (V as)+splitVariant = splitVariant' @as @(Complement xs as) @xs++-- | A value of type "x" can be extracted from (V xs)+type (:<) x xs =+ ( Member x xs+ , x :<? xs+ )++-- | Forall `x` in `xs`, `x :< ys`+type family (:<<) xs ys :: Constraint where+ '[] :<< ys = ()+ (x ': xs) :<< ys = (x :< ys, xs :<< ys)++-- | A value of type "x" **might** be extracted from (V xs).+-- We don't check that "x" is in "xs".+type (:<?) x xs =+ ( PopVariant x xs+ , ToVariantMaybe x xs+ )++-- | Extract a type from a variant. Return either the value of this type or the+-- remaining variant+popVariant :: forall a xs.+ ( a :< xs+ ) => V xs -> Either (V (Remove a xs)) a+{-# INLINABLE popVariant #-}+popVariant v = popVariant' @a v++-- | Extract a type from a variant. Return either the value of this type or the+-- remaining variant+popVariantMaybe :: forall a xs.+ ( a :<? xs+ ) => V xs -> Either (V (Remove a xs)) a+{-# INLINABLE popVariantMaybe #-}+popVariantMaybe v = popVariant' @a v++-- | Pick the first matching type of a Variant+--+-- >>> let x = toVariantAt @2 10 :: V '[Int,String,Int]+-- >>> fromVariantFirst @Int x+-- Nothing+--+fromVariantFirst :: forall a l.+ ( Member a l+ ) => V l -> Maybe a+{-# INLINABLE fromVariantFirst #-}+fromVariantFirst = fromVariantAt @(IndexOf a l)++-- | Try to a get a value of a given type from a Variant+--+-- Equivalent to pattern `V`.+--+-- >>> let x = toVariantAt @2 10 :: V [Int,String,Int]+-- >>> fromVariant @Int x+-- Just 10+--+-- > fromVariant @Double x+-- ... error: Double not found in list: [Int, String, Int]+-- ...+--+fromVariant :: forall a xs.+ ( a :< xs+ ) => V xs -> Maybe a+{-# INLINABLE fromVariant #-}+fromVariant v = case popVariant v of+ Right a -> Just a+ Left _ -> Nothing++-- | Try to a get a value of a given type from a Variant (silent)+fromVariant' :: forall a xs.+ ( PopVariant a xs+ ) => V xs -> Maybe a+{-# INLINABLE fromVariant' #-}+fromVariant' v = case popVariant' v of+ Right a -> Just a+ Left _ -> Nothing++-- | Try to a get a value of a given type from a Variant that may not even+-- support the given type.+--+-- >>> let x = V @Int 10 :: V [Int,String,Float]+-- >>> fromVariantMaybe @Int x+-- Just 10+-- >>> fromVariantMaybe @Double x+-- Nothing+--+fromVariantMaybe :: forall a xs.+ ( a :<? xs+ ) => V xs -> Maybe a+{-# INLINABLE fromVariantMaybe #-}+fromVariantMaybe v = case popVariantMaybe v of+ Right a -> Just a+ Left _ -> Nothing++-- | Update the first matching variant value+--+-- >>> let x = toVariantAt @0 10 :: V [Int,String,Int]+-- >>> mapVariantFirst @Int (+32) x+-- 42+--+-- >>> let y = toVariantAt @2 10 :: V [Int,String,Int]+-- >>> mapVariantFirst @Int (+32) y+-- 10+--+mapVariantFirst :: forall a b n l.+ ( Member a l+ , n ~ IndexOf a l+ ) => (a -> b) -> V l -> V (ReplaceN n b l)+{-# INLINABLE mapVariantFirst #-}+mapVariantFirst f v = mapVariantAt @n f v++-- | Applicative update of the first matching variant value+--+-- Example with `Maybe`:+--+-- >>> let f s = if s == (42 :: Int) then Just "Yeah!" else Nothing+-- >>> mapVariantFirstM f (toVariantAt @0 42 :: V [Int,Float,Int])+-- Just "Yeah!"+--+-- >>> mapVariantFirstM f (toVariantAt @2 42 :: V [Int,Float,Int])+-- Just 42+--+-- >>> mapVariantFirstM f (toVariantAt @0 10 :: V [Int,Float,Int])+-- Nothing+--+-- >>> mapVariantFirstM f (toVariantAt @2 10 :: V [Int,Float,Int])+-- Just 10+--+-- Example with `IO`:+--+-- >>> mapVariantFirstM @Int print (toVariantAt @0 42 :: V [Int,Float,Int])+-- 42+-- ()+--+-- >>> mapVariantFirstM @Int print (toVariantAt @2 42 :: V [Int,Float,Int])+-- 42+--+mapVariantFirstM :: forall a b n l m.+ ( Member a l+ , n ~ IndexOf a l+ , Applicative m+ ) => (a -> m b) -> V l -> m (V (ReplaceN n b l))+{-# INLINABLE mapVariantFirstM #-}+mapVariantFirstM f v = mapVariantAtM @n f v++class MapVariantIndexes a b cs (is :: [Nat]) where+ mapVariant' :: (a -> b) -> V cs -> V (ReplaceNS is b cs)++instance MapVariantIndexes a b '[] is where+ {-# INLINABLE mapVariant' #-}+ mapVariant' = undefined++instance MapVariantIndexes a b cs '[] where+ {-# INLINABLE mapVariant' #-}+ mapVariant' _ v = v++instance forall a b cs is i.+ ( MapVariantIndexes a b (ReplaceN i b cs) is+ , a ~ Index i cs+ , KnownNat i+ ) => MapVariantIndexes a b cs (i ': is) where+ {-# INLINABLE mapVariant' #-}+ mapVariant' f v = mapVariant' @a @b @(ReplaceN i b cs) @is f (mapVariantAt @i f v)++type MapVariant a b cs =+ ( MapVariantIndexes a b cs (IndexesOf a cs)+ )++type ReplaceAll a b cs = ReplaceNS (IndexesOf a cs) b cs+++-- | Map the matching types of a variant+--+-- >>> let add1 = mapVariant @Int (+1)+-- >>> add1 (toVariantAt @0 10 :: V [Int,Float,Int,Double])+-- 11+--+-- >>> add1 (toVariantAt @2 10 :: V [Int,Float,Int, Double])+-- 11+--+mapVariant :: forall a b cs.+ ( MapVariant a b cs+ ) => (a -> b) -> V cs -> V (ReplaceAll a b cs)+{-# INLINABLE mapVariant #-}+mapVariant = mapVariant' @a @b @cs @(IndexesOf a cs)++-- | Map the matching types of a variant and nub the result+--+-- >>> let add1 = mapNubVariant @Int (+1)+-- >>> add1 (toVariantAt @0 10 :: V [Int,Float,Int,Double])+-- 11+--+-- >>> add1 (toVariantAt @2 10 :: V [Int,Float,Int, Double])+-- 11+--+mapNubVariant :: forall a b cs ds rs.+ ( MapVariant a b cs+ , ds ~ ReplaceNS (IndexesOf a cs) b cs+ , rs ~ Nub ds+ , LiftVariant ds rs+ ) => (a -> b) -> V cs -> V rs+{-# INLINABLE mapNubVariant #-}+mapNubVariant f = nubVariant . mapVariant f+++-- | Update a variant value with a variant and fold the result+--+-- >>> newtype Odd = Odd Int deriving (Show)+-- >>> newtype Even = Even Int deriving (Show)+-- >>> let f x = if even x then V (Even x) else V (Odd x) :: V '[Odd, Even]+-- >>> foldMapVariantAt @1 f (V @Int 10 :: V [Float,Int,Double])+-- Even 10+--+-- >>> foldMapVariantAt @1 f (V @Float 0.5 :: V [Float,Int,Double])+-- 0.5+--+foldMapVariantAt :: forall (n :: Nat) l l2 .+ ( KnownNat n+ , KnownNat (Length l2)+ ) => (Index n l -> V l2) -> V l -> V (ReplaceAt n l l2)+foldMapVariantAt f v@(Variant t a) =+ case fromVariantAt @n v of+ Nothing ->+ -- we need to adapt the tag if new valid tags (from l2) are added before+ if t < n+ then Variant t a+ else Variant (t+nl2-1) a++ Just x -> case f x of+ Variant t2 a2 -> Variant (t2+n) a2+ where+ n = natValue' @n+ nl2 = natValue' @(Length l2)++-- | Update a variant value with a variant and fold the result+foldMapVariantAtM :: forall (n :: Nat) m l l2.+ ( KnownNat n+ , KnownNat (Length l2)+ , Monad m+ ) => (Index n l -> m (V l2)) -> V l -> m (V (ReplaceAt n l l2))+foldMapVariantAtM f v@(Variant t a) =+ case fromVariantAt @n v of+ Nothing ->+ -- we need to adapt the tag if new valid tags (from l2) are added before+ return $ if t < n+ then Variant t a+ else Variant (t+nl2-1) a++ Just x -> do+ y <- f x+ case y of+ Variant t2 a2 -> return (Variant (t2+n) a2)+ where+ n = natValue' @n+ nl2 = natValue' @(Length l2)++-- | Update a variant value with a variant and fold the result+foldMapVariantFirst :: forall a (n :: Nat) l l2 .+ ( KnownNat n+ , KnownNat (Length l2)+ , n ~ IndexOf a l+ , a ~ Index n l+ ) => (a -> V l2) -> V l -> V (ReplaceAt n l l2)+foldMapVariantFirst f v = foldMapVariantAt @n f v++-- | Update a variant value with a variant and fold the result+foldMapVariantFirstM :: forall a (n :: Nat) l l2 m.+ ( KnownNat n+ , KnownNat (Length l2)+ , n ~ IndexOf a l+ , a ~ Index n l+ , Monad m+ ) => (a -> m (V l2)) -> V l -> m (V (ReplaceAt n l l2))+foldMapVariantFirstM f v = foldMapVariantAtM @n f v++++-- | Update a variant value with a variant and fold the result+--+-- >>> newtype Odd = Odd Int deriving (Show)+-- >>> newtype Even = Even Int deriving (Show)+-- >>> let f x = if even x then V (Even x) else V (Odd x) :: V [Odd, Even]+-- >>> foldMapVariant @Int f (V @Int 10 :: V [Float,Int,Double])+-- Even 10+--+-- >>> foldMapVariant @Int f (V @Float 0.5 :: V [Float,Int,Double])+-- 0.5+--+foldMapVariant :: forall a cs ds i.+ ( i ~ IndexOf a cs+ , a :< cs+ ) => (a -> V ds) -> V cs -> V (InsertAt i (Remove a cs) ds)+foldMapVariant f v = case popVariant v of+ Right a -> case f a of+ Variant t x -> Variant (i + t) x+ Left (Variant t x)+ | t < i -> Variant t x+ | otherwise -> Variant (i+t) x+ where+ i = natValue' @i+++++-----------------------------------------------------------+-- Generic operations with type classes+-----------------------------------------------------------++-- | Useful to specify a "Type -> Constraint" function returning an empty constraint+class NoConstraint a+instance NoConstraint a++class AlterVariant c (b :: [Type]) where+ alterVariant' :: (forall a. c a => a -> a) -> Word -> Any -> Any++instance AlterVariant c '[] where+ {-# INLINABLE alterVariant' #-}+ alterVariant' _ = undefined++instance+ ( AlterVariant c xs+ , c x+ ) => AlterVariant c (x ': xs)+ where+ {-# INLINABLE alterVariant' #-}+ alterVariant' f t v =+ case t of+ 0 -> unsafeCoerce (f (unsafeCoerce v :: x))+ n -> alterVariant' @c @xs f (n-1) v++-- | Alter a variant. You need to specify the constraints required by the+-- modifying function.+--+-- Usage:+-- alterVariant @NoConstraint id v+-- alterVariant @Resizable (resize 4) v+--+--+-- -- Multiple constraints:+-- class (Ord a, Num a) => OrdNum a+-- instance (Ord a, Num a) => OrdNum a+-- alterVariant @OrdNum foo v+--+alterVariant :: forall c (a :: [Type]).+ ( AlterVariant c a+ ) => (forall x. c x => x -> x) -> V a -> V a+{-# INLINABLE alterVariant #-}+alterVariant f (Variant t a) = + Variant t (alterVariant' @c @a f t a)+++++class TraverseVariant c (b :: [Type]) m where+ traverseVariant' :: (forall a . (Monad m, c a) => a -> m a) -> Word -> Any -> m Any++instance TraverseVariant c '[] m where+ {-# INLINABLE traverseVariant' #-}+ traverseVariant' _ = undefined++instance+ ( TraverseVariant c xs m+ , c x+ , Monad m+ ) => TraverseVariant c (x ': xs) m+ where+ {-# INLINABLE traverseVariant' #-}+ traverseVariant' f t v =+ case t of+ 0 -> unsafeCoerce <$> f (unsafeCoerce v :: x)+ n -> traverseVariant' @c @xs f (n-1) v+++-- | Traverse a variant. You need to specify the constraints required by the+-- modifying function.+traverseVariant :: forall c (a :: [Type]) m.+ ( TraverseVariant c a m+ , Monad m+ ) => (forall x. c x => x -> m x) -> V a -> m (V a)+{-# INLINABLE traverseVariant #-}+traverseVariant f (Variant t a) = + Variant t <$> traverseVariant' @c @a f t a++-- | Traverse a variant. You need to specify the constraints required by the+-- modifying function.+traverseVariant_ :: forall c (a :: [Type]) m.+ ( TraverseVariant c a m+ , Monad m+ ) => (forall x. c x => x -> m ()) -> V a -> m ()+{-# INLINABLE traverseVariant_ #-}+traverseVariant_ f v = void (traverseVariant @c @a f' v)+ where+ f' :: forall x. c x => x -> m x+ f' x = f x >> return x++++class ReduceVariant c (b :: [Type]) where+ reduceVariant' :: (forall a. c a => a -> r) -> Word -> Any -> r++instance ReduceVariant c '[] where+ {-# INLINABLE reduceVariant' #-}+ reduceVariant' _ = undefined++instance+ ( ReduceVariant c xs+ , c x+ ) => ReduceVariant c (x ': xs)+ where+ {-# INLINABLE reduceVariant' #-}+ reduceVariant' f t v =+ case t of+ 0 -> f (unsafeCoerce v :: x)+ n -> reduceVariant' @c @xs f (n-1) v++-- | Reduce a variant to a single value by using a class function. You need to+-- specify the constraints required by the modifying function.+--+-- >>> let v = V "Yes" :: V [String,Bool,Char]+-- >>> reduceVariant @Show show v+-- "\"Yes\""+--+-- >>> let n = V (10 :: Int) :: V [Int,Word,Integer]+-- >>> reduceVariant @Integral fromIntegral n :: Int+-- 10+reduceVariant :: forall c (a :: [Type]) r.+ ( ReduceVariant c a+ ) => (forall x. c x => x -> r) -> V a -> r+{-# INLINABLE reduceVariant #-}+reduceVariant f (Variant t a) = reduceVariant' @c @a f t a++++-----------------------------------------------------------+-- Conversions between variants+-----------------------------------------------------------++-- | Extend a variant by appending other possible values+appendVariant :: forall (ys :: [Type]) (xs :: [Type]). V xs -> V (Concat xs ys)+{-# INLINABLE appendVariant #-}+appendVariant (Variant t a) = Variant t a++-- | Extend a variant by prepending other possible values+prependVariant :: forall (ys :: [Type]) (xs :: [Type]).+ ( KnownNat (Length ys)+ ) => V xs -> V (Concat ys xs)+{-# INLINABLE prependVariant #-}+prependVariant (Variant t a) = Variant (n+t) a+ where+ n = natValue' @(Length ys)++-- | xs is liftable in ys+type LiftVariant xs ys =+ ( LiftVariant' xs ys+ , xs :<< ys+ )++-- | xs is liftable in ys+class LiftVariant' xs ys where+ liftVariant' :: V xs -> V ys++instance LiftVariant' '[] ys where+ {-# INLINABLE liftVariant' #-}+ liftVariant' _ = undefined++instance forall xs ys x.+ ( LiftVariant' xs ys+ , KnownNat (IndexOf x ys)+ ) => LiftVariant' (x ': xs) ys+ where+ {-# INLINABLE liftVariant' #-}+ liftVariant' (Variant t a)+ | t == 0 = Variant (natValue' @(IndexOf x ys)) a+ | otherwise = liftVariant' @xs (Variant (t-1) a)+++-- | Lift a variant into another+--+-- Set values to the first matching type+liftVariant :: forall ys xs.+ ( LiftVariant xs ys+ ) => V xs -> V ys+{-# INLINABLE liftVariant #-}+liftVariant = liftVariant'++-- | Nub the type list+nubVariant :: (LiftVariant xs (Nub xs)) => V xs -> V (Nub xs)+{-# INLINABLE nubVariant #-}+nubVariant = liftVariant++-- | Product of two variants+productVariant :: forall xs ys.+ ( KnownNat (Length ys)+ ) => V xs -> V ys -> V (Product xs ys)+{-# INLINABLE productVariant #-}+productVariant (Variant n1 a1) (Variant n2 a2)+ = Variant (n1 * natValue @(Length ys) + n2) (unsafeCoerce (a1,a2))++type family FlattenVariant (xs :: [Type]) :: [Type] where+ FlattenVariant '[] = '[]+ FlattenVariant (V xs:ys) = Concat xs (FlattenVariant ys)+ FlattenVariant (y:ys) = y ': FlattenVariant ys++class Flattenable a rs where+ toFlattenVariant :: Word -> a -> rs++instance Flattenable (V '[]) rs where+ {-# INLINABLE toFlattenVariant #-}+ toFlattenVariant _ _ = undefined++instance forall xs ys rs.+ ( Flattenable (V ys) (V rs)+ , KnownNat (Length xs)+ ) => Flattenable (V (V xs ': ys)) (V rs)+ where+ {-# INLINABLE toFlattenVariant #-}+ toFlattenVariant i v = case popVariantHead v of+ Right (Variant n a) -> Variant (i+n) a+ Left vys -> toFlattenVariant (i+natValue @(Length xs)) vys++-- | Flatten variants in a variant+flattenVariant :: forall xs.+ ( Flattenable (V xs) (V (FlattenVariant xs))+ ) => V xs -> V (FlattenVariant xs)+{-# INLINABLE flattenVariant #-}+flattenVariant v = toFlattenVariant 0 v++type family ExtractM m f where+ ExtractM m '[] = '[]+ ExtractM m (m x ': xs) = x ': ExtractM m xs++class JoinVariant m xs where+ -- | Join on a variant+ --+ -- Transform a variant of applicatives as follow:+ -- f :: V [m a, m b, m c] -> m (V [a,b,c])+ -- f = joinVariant @m+ --+ joinVariant :: V xs -> m (V (ExtractM m xs))++instance JoinVariant m '[] where+ {-# INLINABLE joinVariant #-}+ joinVariant _ = undefined++instance forall m xs a.+ ( Functor m+ , ExtractM m (m a ': xs) ~ (a ': ExtractM m xs)+ , JoinVariant m xs+ ) => JoinVariant m (m a ': xs) where+ {-# INLINABLE joinVariant #-}+ joinVariant (Variant 0 a) = (Variant 0 . unsafeCoerce) <$> (unsafeCoerce a :: m a)+ joinVariant (Variant n a) = prependVariant @'[a] <$> joinVariant (Variant (n-1) a :: V xs)++-- | Join on a variant in an unsafe way.+--+-- Works with IO for example but not with Maybe.+--+joinVariantUnsafe :: forall m xs ys.+ ( Functor m+ , ys ~ ExtractM m xs+ ) => V xs -> m (V ys)+{-# INLINABLE joinVariantUnsafe #-}+joinVariantUnsafe (Variant t act) = Variant t <$> (unsafeCoerce act :: m Any)++++instance NFData (V '[]) where+ {-# INLINABLE rnf #-}+ rnf _ = ()++instance (NFData x, NFData (V xs)) => NFData (V (x ': xs)) where+ {-# INLINABLE rnf #-}+ rnf v = case popVariantHead v of+ Right x -> rnf x+ Left xs -> rnf xs+++-----------------------------------------------------------+-- Conversions to other data types+-----------------------------------------------------------++-- | Retrieve a single value+variantToValue :: V '[a] -> a+{-# INLINABLE variantToValue #-}+variantToValue (Variant _ a) = unsafeCoerce a++-- | Create a variant from a single value+variantFromValue :: a -> V '[a]+{-# INLINABLE variantFromValue #-}+variantFromValue a = Variant 0 (unsafeCoerce a)+++-- | Convert a variant of two values in a Either+variantToEither :: forall a b. V '[a,b] -> Either b a+{-# INLINABLE variantToEither #-}+variantToEither (Variant 0 a) = Right (unsafeCoerce a)+variantToEither (Variant _ a) = Left (unsafeCoerce a)++-- | Lift an Either into a Variant (reversed order by convention)+variantFromEither :: Either a b -> V '[b,a]+{-# INLINABLE variantFromEither #-}+variantFromEither (Left a) = toVariantAt @1 a+variantFromEither (Right b) = toVariantAt @0 b+++instance ContVariant xs => MultiCont (V xs) where+ type MultiContTypes (V xs) = xs+ toCont = variantToCont+ toContM = variantToContM++class ContVariant xs where+ -- | Convert a variant into a multi-continuation+ variantToCont :: V xs -> ContFlow xs r++ -- | Convert a variant into a multi-continuation+ variantToContM :: Monad m => m (V xs) -> ContFlow xs (m r)++ -- | Convert a multi-continuation into a Variant+ contToVariant :: ContFlow xs (V xs) -> V xs++ -- | Convert a multi-continuation into a Variant+ contToVariantM :: Monad m => ContFlow xs (m (V xs)) -> m (V xs)++instance ContVariant '[a] where+ {-# INLINABLE variantToCont #-}+ variantToCont (Variant _ a) = ContFlow $ \(MkSolo f) ->+ f (unsafeCoerce a)++ {-# INLINABLE variantToContM #-}+ variantToContM act = ContFlow $ \(MkSolo f) -> do+ Variant _ a <- act+ f (unsafeCoerce a)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ MkSolo (toVariantAt @0)++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ MkSolo (return . toVariantAt @0)++instance ContVariant '[a,b] where+ {-# INLINABLE variantToCont #-}+ variantToCont (Variant t a) = ContFlow $ \(f1,f2) ->+ case t of+ 0 -> f1 (unsafeCoerce a)+ _ -> f2 (unsafeCoerce a)++ {-# INLINABLE variantToContM #-}+ variantToContM act = ContFlow $ \(f1,f2) -> do+ Variant t a <- act+ case t of+ 0 -> f1 (unsafeCoerce a)+ _ -> f2 (unsafeCoerce a)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ )++instance ContVariant '[a,b,c] where+ {-# INLINABLE variantToCont #-}+ variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3) ->+ case t of+ 0 -> f1 (unsafeCoerce a)+ 1 -> f2 (unsafeCoerce a)+ _ -> f3 (unsafeCoerce a)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ )++instance ContVariant '[a,b,c,d] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ )++instance ContVariant '[a,b,c,d,e] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ )++instance ContVariant '[a,b,c,d,e,f] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ )++instance ContVariant '[a,b,c,d,e,f,g] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ , toVariantAt @6+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ , return . toVariantAt @6+ )++instance ContVariant '[a,b,c,d,e,f,g,h] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ , toVariantAt @6+ , toVariantAt @7+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ , return . toVariantAt @6+ , return . toVariantAt @7+ )++instance ContVariant '[a,b,c,d,e,f,g,h,i] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ , toVariantAt @6+ , toVariantAt @7+ , toVariantAt @8+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ , return . toVariantAt @6+ , return . toVariantAt @7+ , return . toVariantAt @8+ )++instance ContVariant '[a,b,c,d,e,f,g,h,i,j] where+ {-# INLINABLE 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ , toVariantAt @6+ , toVariantAt @7+ , toVariantAt @8+ , toVariantAt @9+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ , return . toVariantAt @6+ , return . toVariantAt @7+ , return . toVariantAt @8+ , return . toVariantAt @9+ )++instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k] where+ {-# INLINABLE variantToCont #-}+ variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11) ->+ case t of+ 0 -> f1 (unsafeCoerce a)+ 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)++ {-# INLINABLE 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ , toVariantAt @6+ , toVariantAt @7+ , toVariantAt @8+ , toVariantAt @9+ , toVariantAt @10+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ , return . toVariantAt @6+ , return . toVariantAt @7+ , return . toVariantAt @8+ , return . toVariantAt @9+ , return . toVariantAt @10+ )++instance ContVariant '[a,b,c,d,e,f,g,h,i,j,k,l] where+ {-# INLINABLE variantToCont #-}+ variantToCont (Variant t a) = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) ->+ case t of+ 0 -> f1 (unsafeCoerce a)+ 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)++ {-# INLINABLE variantToContM #-}+ variantToContM act = ContFlow $ \(f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12) -> do+ Variant t a <- act+ case t of+ 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)++ {-# INLINABLE contToVariant #-}+ contToVariant c = c >::>+ ( toVariantAt @0+ , toVariantAt @1+ , toVariantAt @2+ , toVariantAt @3+ , toVariantAt @4+ , toVariantAt @5+ , toVariantAt @6+ , toVariantAt @7+ , toVariantAt @8+ , toVariantAt @9+ , toVariantAt @10+ , toVariantAt @11+ )++ {-# INLINABLE contToVariantM #-}+ contToVariantM c = c >::>+ ( return . toVariantAt @0+ , return . toVariantAt @1+ , return . toVariantAt @2+ , return . toVariantAt @3+ , return . toVariantAt @4+ , return . toVariantAt @5+ , return . toVariantAt @6+ , return . toVariantAt @7+ , return . toVariantAt @8+ , return . toVariantAt @9+ , return . toVariantAt @10+ , return . toVariantAt @11+ )
+ src/lib/Data/Variant/ContFlow.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}++-- | Continuation based control-flow+module Data.Variant.ContFlow+ ( ContFlow (..)+ , ContTuple+ , (>:>)+ , (>-:>)+ , (>%:>)+ , (>::>)+ , (>:-:>)+ , (>:%:>)+ , ToMultiCont+ , MultiCont (..)+ )+where++import Data.Kind+import Data.Variant.Tuple++-- | A continuation based control-flow+newtype ContFlow (xs :: [Type]) r = ContFlow (ContTuple xs r -> r)++-- | Convert a list of types into the actual data type representing the+-- continuations.+type family ContTuple (xs :: [Type]) r where+ ContTuple xs r = Tuple (ToMultiCont xs r)++type family ToMultiCont xs r where+ ToMultiCont '[] r = '[]+ ToMultiCont (x ': xs) r = (x -> r) ': ToMultiCont xs r++-- | A multi-continuable type+class MultiCont a where+ type MultiContTypes a :: [Type]++ -- | Convert a data into a multi-continuation+ toCont :: a -> ContFlow (MultiContTypes a) r++ -- | Convert a data into a multi-continuation (monadic)+ toContM :: Monad m => m a -> ContFlow (MultiContTypes a) (m r)+++-- | Bind a multi-continuable type to a tuple of continuations+(>:>) :: MultiCont a => a -> ContTuple (MultiContTypes a) r -> r+{-# INLINABLE (>:>) #-}+(>:>) a !cs = toCont a >::> cs++infixl 0 >:>++-- | Bind a single-continuable type to a 1-tuple of continuations+(>-:>) :: (MultiCont a, MultiContTypes a ~ '[b]) => a -> (b -> r) -> r+{-# INLINABLE (>-:>) #-}+(>-:>) a c = toCont a >:-:> c++infixl 0 >-:>++-- | Bind a multi-continuable type to a tuple of continuations and+-- reorder fields if necessary+(>%:>) ::+ ( MultiCont a+ , ReorderTuple ts (ContTuple (MultiContTypes a) r)+ ) => a -> ts -> r+{-# INLINABLE (>%:>) #-}+(>%:>) a !cs = toCont a >:%:> cs++infixl 0 >%:>+++-- | Bind a flow to a tuple of continuations+(>::>) :: ContFlow xs r -> ContTuple xs r -> r+{-# INLINABLE (>::>) #-}+(>::>) (ContFlow f) !cs = f cs++infixl 0 >::>++-- | Bind a flow to a 1-tuple of continuations+(>:-:>) :: ContFlow '[a] r -> (a -> r) -> r+{-# INLINABLE (>:-:>) #-}+(>:-:>) (ContFlow f) c = f (MkSolo c)++infixl 0 >:-:>++-- | Bind a flow to a tuple of continuations and+-- reorder fields if necessary+(>:%:>) :: forall ts xs r.+ ( ReorderTuple ts (ContTuple xs r)+ ) => ContFlow xs r -> ts -> r+{-# INLINABLE (>:%:>) #-}+(>:%:>) (ContFlow f) !cs = f (tupleReorder cs)++infixl 0 >:%:>
+ src/lib/Data/Variant/EADT.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Extensible ADT+module Data.Variant.EADT+ ( EADT (..)+ , (:<:)+ , (:<<:)+ , pattern VF+ , appendEADT+ , liftEADT+ , popEADT+ , contToEADT+ , contToEADTM+ , EADTShow (..)+ , eadtShow+ -- * Reexport+ , module Data.Variant.Functor+ , module Data.Variant.VariantF+ )+where++import Data.Variant+import Data.Variant.VariantF+import Data.Variant.Types+import Data.Variant.ContFlow+import Data.Variant.Functor++import GHC.TypeLits++-- $setup+-- >>> :seti -XDataKinds+-- >>> :seti -XTypeApplications+-- >>> :seti -XTypeOperators+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeFamilies+-- >>> :seti -XPatternSynonyms+-- >>> :seti -XDeriveFunctor+-- >>>+-- >>> import Data.Functor.Classes+-- >>>+-- >>> data ConsF a e = ConsF a e deriving (Eq,Ord,Show,Functor)+-- >>> data NilF e = NilF deriving (Eq,Ord,Show,Functor)+-- >>>+-- >>> instance Eq a => Eq1 (ConsF a) where liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2+-- >>> instance Eq1 NilF where liftEq _ _ _ = True+-- >>>+-- >>> :{+-- >>> pattern Cons :: ConsF a :<: xs => a -> EADT xs -> EADT xs+-- >>> pattern Cons a l = VF (ConsF a l)+-- >>> pattern Nil :: NilF :<: xs => EADT xs+-- >>> pattern Nil = VF NilF+-- >>> type ListF a = VariantF '[NilF, ConsF a]+-- >>> type List a = EADT '[NilF, ConsF a]+-- >>> :}+--+-- >>>+-- >>> let a = Cons "Hello" (Cons "World" Nil) :: List String+-- >>> let b = Cons "Bonjour" (Cons "Monde" Nil) :: List String+-- >>> a == b+-- False+-- >>> a == a+-- True+++-- | An extensible ADT+newtype EADT fs+ = EADT (VariantF fs (EADT fs))++type instance Base (EADT fs) = VariantF fs++instance Functor (VariantF fs) => Recursive (EADT fs) where+ project (EADT a) = a++instance Functor (VariantF fs) => Corecursive (EADT fs) where+ embed = EADT++instance Eq1 (VariantF fs) => Eq (EADT fs) where+ EADT a == EADT b = eq1 a b++instance Ord1 (VariantF fs) => Ord (EADT fs) where+ compare (EADT a) (EADT b) = compare1 a b++instance Show1 (VariantF fs) => Show (EADT fs) where+ showsPrec d (EADT a) =+ showParen (d >= 11)+ $ showString "EADT "+ . showsPrec1 11 a++-- | Constructor `f` is in `xs`+type family f :<: xs where+ f :<: xs = EADTF' f (EADT xs) xs++-- | Forall `x` in `xs`, `x :<: ys`+type family (:<<:) xs ys :: Constraint where+ '[] :<<: ys = ()+ (x ': xs) :<<: ys = (x :<: ys, xs :<<: ys)++type EADTF' f e cs =+ ( Member f cs+ , Index (IndexOf (f e) (ApplyAll e cs)) (ApplyAll e cs) ~ f e+ , PopVariant (f e) (ApplyAll e cs)+ , KnownNat (IndexOf (f e) (ApplyAll e cs))+ , Remove (f e) (ApplyAll e cs) ~ ApplyAll e (Remove f cs)+ )++-- | Pattern-match in an extensible ADT+pattern VF :: forall e f cs.+ ( e ~ EADT cs -- allow easy use of TypeApplication to set the EADT type+ , f :<: cs -- constraint synonym ensuring `f` is in `cs`+ ) => f (EADT cs) -> EADT cs+pattern VF x = EADT (VariantF (VSilent x))+ -- `VSilent` matches a variant value without checking the membership: we+ -- already do it with :<:++-- | Append new "constructors" to the EADT+appendEADT :: forall ys xs zs.+ ( zs ~ Concat xs ys+ , ApplyAll (EADT zs) zs ~ Concat (ApplyAll (EADT zs) xs) (ApplyAll (EADT zs) ys)+ , Functor (VariantF xs)+ ) => EADT xs -> EADT zs+appendEADT (EADT v) = EADT (appendVariantF @ys (fmap (appendEADT @ys) v))++-- | Lift an EADT into another+liftEADT :: forall e as bs.+ ( e ~ EADT bs+ , LiftVariantF as bs e+ , Functor (VariantF as)+ ) => EADT as -> EADT bs+liftEADT = cata (EADT . liftVariantF)++-- | Pop an EADT value+popEADT :: forall f xs e.+ ( f :<: xs+ , e ~ EADT xs+ , f e :< ApplyAll e xs+ ) => EADT xs -> Either (VariantF (Remove f xs) (EADT xs)) (f (EADT xs))+popEADT (EADT v) = popVariantF v++-- | MultiCont instance+--+-- >>> let f x = toCont x >::> (const "[]", \(ConsF u us) -> u ++ ":" ++ f us)+-- >>> f a+-- "Hello:World:[]"+instance (Functor (VariantF xs), ContVariant (ApplyAll (EADT xs) xs)) => MultiCont (EADT xs) where+ type MultiContTypes (EADT xs) = ApplyAll (EADT xs) xs+ toCont (EADT v) = variantFToCont v+ toContM f = variantFToContM (project <$> f)++-- | Convert a multi-continuation into an EADT+contToEADT ::+ ( ContVariant (ApplyAll (EADT xs) xs)+ ) => ContFlow (ApplyAll (EADT xs) xs)+ (V (ApplyAll (EADT xs) xs))+ -> EADT xs+contToEADT c = EADT (contToVariantF c)++-- | Convert a multi-continuation into an EADT+contToEADTM ::+ ( ContVariant (ApplyAll (EADT xs) xs)+ , Monad f+ ) => ContFlow (ApplyAll (EADT xs) xs)+ (f (V (ApplyAll (EADT xs) xs)))+ -> f (EADT xs)+contToEADTM f = EADT <$> contToVariantFM f+++class EADTShow f where+ eadtShow' :: f String -> String++-- | Show an EADT+eadtShow :: forall xs. BottomUpF EADTShow xs => EADT xs -> String+eadtShow = bottomUp (toBottomUp @EADTShow eadtShow')
+ src/lib/Data/Variant/EADT/TH.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}++-- | Template-Haskell helpers for EADTs+module Data.Variant.EADT.TH+ ( eadtPattern+ , eadtInfixPattern+ , eadtPatternT+ , eadtInfixPatternT+ )+where++import Language.Haskell.TH+import Control.Monad+import Data.Variant.EADT++-- | Create a pattern synonym for an EADT constructor+--+-- E.g.+--+-- > data ConsF a e = ConsF a e deriving (Functor)+-- > $(eadtPattern 'ConsF "Cons")+-- >+-- > ====>+-- >+-- > pattern Cons :: ConsF a :<: xs => a -> EADT xs -> EADT xs+-- > pattern Cons a l = VF (ConsF a l)+--+eadtPattern+ :: Name -- ^ Actual constructor (e.g., ConsF)+ -> String -- ^ Name of the pattern (e.g., Cons)+ -> Q [Dec]+eadtPattern consName patStr = eadtPattern' consName patStr Nothing False++-- | Create an infix pattern synonym for an EADT constructor+--+-- E.g.+--+-- > data ConsF a e = ConsF a e deriving (Functor)+-- > $(eadtInfixPattern 'ConsF ":->")+-- >+-- > ====>+-- >+-- > pattern (:->) :: ConsF a :<: xs => a -> EADT xs -> EADT xs+-- > pattern a :-> l = VF (ConsF a l)+--+eadtInfixPattern+ :: Name -- ^ Actual constructor (e.g., ConsF)+ -> String -- ^ Name of the pattern (e.g., Cons)+ -> Q [Dec]+eadtInfixPattern consName patStr = eadtPattern' consName patStr Nothing True++-- | Create a pattern synonym for an EADT constructor that is part of a+-- specified EADT.+--+-- This can be useful to help the type inference because instead of using a+-- generic "EADT xs" type, the pattern uses the provided type.+--+-- E.g.+--+-- > data ConsF a e = ConsF a e deriving (Functor)+-- > data NilF e = NilF deriving (Functor)+-- >+-- > type List a = EADT '[ConsF a, NilF]+-- >+-- > $(eadtPatternT 'ConsF "ConsList" [t|forall a. List a|])+-- >+-- > ====>+-- >+-- > pattern ConsList ::+-- > ( List a ~ EADT xs+-- > , ConsF a :<: xs+-- > ) => a -> List a -> List a+-- > pattern ConsList a l = VF (ConsF a l)+--+-- Note that you have to quantify free variables explicitly with 'forall'+--+eadtPatternT+ :: Name -- ^ Actual constructor (e.g., ConsF)+ -> String -- ^ Name of the pattern (e.g., Cons)+ -> Q Type -- ^ Type of the EADT (e.g., [t|forall a. List a|])+ -> Q [Dec]+eadtPatternT consName patStr qtype =+ eadtPattern' consName patStr (Just qtype) False++-- | Like `eadtPatternT` but generating an infix pattern synonym+eadtInfixPatternT+ :: Name -- ^ Actual constructor (e.g., ConsF)+ -> String -- ^ Name of the pattern (e.g., Cons)+ -> Q Type -- ^ Type of the EADT (e.g., [t|forall a. List a|])+ -> Q [Dec]+eadtInfixPatternT consName patStr qtype =+ eadtPattern' consName patStr (Just qtype) True++-- | Create a pattern synonym for an EADT constructor+eadtPattern'+ :: Name -- ^ Actual constructor (e.g., ConsF)+ -> String -- ^ Name of the pattern (e.g., Cons)+ -> Maybe (Q Type) -- ^ EADT type+ -> Bool -- ^ Declare infix pattern+ -> Q [Dec]+eadtPattern' consName patStr mEadtTy isInfix = do+ let patName = mkName patStr++ typ <- reify consName >>= \case+ DataConI _ t _ -> return t+ _ -> fail $ show consName ++ " isn't a data constructor"++ case typ of+ ForallT tvs _ tys -> do+ -- make pattern+ let getConArity = \case+ AppT (AppT ArrowT _a) b -> 1 + getConArity b+#if MIN_VERSION_base(4,15,0)+ AppT (AppT (AppT MulArrowT _m) _a) b -> 1 + getConArity b+#endif+ _ -> 0++ conArity = getConArity tys+ conArgs <- replicateM conArity (newName "c")++ let vf = mkName "Data.Variant.EADT.VF"++ args <- if not isInfix+ then return (PrefixPatSyn conArgs)+ else case conArgs of+ [x,y] -> return (InfixPatSyn x y)+ xs -> fail $ "Infix pattern should have exactly two parameters (found " ++ show (length xs) ++ ")"++ let pat = PatSynD patName args ImplBidir+#if MIN_VERSION_base(4,16,0)+ -- handle new field for type-applications in patterns+ (ConP vf [] [ConP consName [] (fmap VarP conArgs)])+#else+ (ConP vf [ConP consName (fmap VarP conArgs)])+#endif++ let+ -- retrieve constructor type without the functor var+ -- e.g. ConsF a for ConsF a e+ getConTyp (AppT (AppT ArrowT _a) b) = getConTyp b+#if MIN_VERSION_base(4,15,0)+ getConTyp (AppT (AppT (AppT MulArrowT _m) _a) b) = getConTyp b+#endif+ getConTyp (AppT a _) = a -- remove last AppT (functor var)+ getConTyp _ = error "Invalid constructor type"++ conTyp = getConTyp tys++ -- [* -> *]+ tyToTyList = AppT ListT (AppT (AppT ArrowT StarT) StarT)++ -- retrieve functor var in "e"+#if MIN_VERSION_base(4,16,0)+ e = case last tvs of+ KindedTV nm _ _ -> nm+ PlainTV nm _ -> nm+#elif MIN_VERSION_base(4,15,0)+ KindedTV e _ StarT = last tvs+#else+ KindedTV e StarT = last tvs+#endif+++ -- make pattern type+ (newTvs,eadtTy,ctx) <- do+ xsName <- newName "xs"+ let+ xs = VarT xsName+#if MIN_VERSION_base(4,15,0)+ xsTy = KindedTV xsName SpecifiedSpec tyToTyList+#else+ xsTy = KindedTV xsName tyToTyList+#endif+ eadtXs <- [t| EADT $(return xs) |]++ prd <- [t| $(return conTyp) :<: $(return xs) |]+ prd2 <- [t| $(return (VarT e)) ~ $(return eadtXs) |]+ case mEadtTy of+ Nothing -> return ([xsTy],eadtXs,[prd,prd2])+ Just ty -> do+ ty' <- ty+ let (tvs',ty'',ctx') = case ty' of+ -- put freevars of the user specified type with the+ -- other ones+ ForallT tvs'' ctx'' t -> (tvs'',t,ctx'')+ _ -> ([],ty',[])+ prd3 <- [t| $(return ty'') ~ $(return eadtXs) |]+ return (xsTy:tvs',ty'',prd:prd2:prd3:ctx')++ let+ -- remove functor var; add new type var+ tvs' = tvs ++ newTvs++ -- replace functor variable with EADT type+ go (AppT (AppT ArrowT a) b)+ | VarT v <- a+ , v == e = AppT (AppT ArrowT eadtTy) (go b)+ | otherwise = AppT (AppT ArrowT a) (go b)+#if MIN_VERSION_base(4,15,0)+ go (AppT (AppT (AppT MulArrowT _m) a) b)+ | VarT v <- a+ -- Linear types don't support pattern synonyms (GHC#18806)+ -- Use normal arrows instead.+ , v == e = AppT (AppT ArrowT eadtTy) (go b)+ | otherwise = AppT (AppT ArrowT a) (go b)+#endif+ go _ = eadtTy+ t' = go tys+++ let sig = PatSynSigD patName (ForallT tvs' ctx t')++ return [sig,pat]++ _ -> fail $ show consName ++ "'s type doesn't have a free variable, it can't be a functor"
+ src/lib/Data/Variant/EGADT.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Data.Variant.EGADT where++import Unsafe.Coerce+import GHC.TypeLits+import Data.Kind+import Control.Monad++import Data.Variant+import Data.Variant.VariantF+import Data.Variant.Types+import Data.Variant.Functor++-- $setup+-- >>> :seti -XDataKinds+-- >>> :seti -XTypeApplications+-- >>> :seti -XTypeOperators+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeFamilies+-- >>> :seti -XPatternSynonyms+-- >>> :seti -XDeriveFunctor+-- >>> :seti -XGADTs+-- >>> :seti -XPolyKinds+-- >>> :seti -XPartialTypeSignatures+-- >>>+-- >>> :{+-- >>> data LamF (ast :: Type -> Type) t where+-- >>> LamF :: ( ast a -> ast b ) -> LamF ast ( a -> b )+-- >>> +-- >>> data AppF ast t where+-- >>> AppF :: ast ( a -> b ) -> ast a -> AppF ast b+-- >>>+-- >>> data VarF ast t where+-- >>> VarF :: String -> VarF ast Int+-- >>>+-- >>> type AST a = EGADT '[LamF,AppF,VarF] a+-- >>>+-- >>> :}+--+-- >>> let y = VF @(AST Int) (VarF "a")+-- >>> :t y+-- y :: EGADT [LamF, AppF, VarF] Int+--+-- >>> :{+-- >>> case y of+-- >>> VF (VarF x) -> print x+-- >>> _ -> putStrLn "Not a VarF"+-- >>> :}+-- "a"+--+-- >>> :{+-- >>> f :: AST Int -> AST Int+-- >>> f (VF (VarF x)) = VF (VarF "zz")+-- >>> f _ = error "Unhandled case"+-- >>> :}+--+-- >>> let z = VF (AppF (VF (LamF f)) (VF (VarF "a")))+-- >>> :t z+-- z :: EGADT [LamF, AppF, VarF] Int+--+++-- | An EADT with an additional type parameter+newtype EGADT fs t = EGADT (HVariantF fs (EGADT fs) t)++newtype HVariantF (fs :: [ (k -> Type) -> ( k -> Type) ]) (ast :: k -> Type) (t :: k)+ = HVariantF (VariantF (ApplyAll ast fs) t)++toHVariantAt+ :: forall i fs ast a+ . KnownNat i+ => (Index i fs) ast a -> VariantF (ApplyAll ast fs) a+{-# INLINABLE toHVariantAt #-}+toHVariantAt a = VariantF (Variant (natValue' @i) (unsafeCoerce a))++fromHVariantAt+ :: forall i fs ast a+ . KnownNat i+ => VariantF (ApplyAll ast fs) a -> Maybe ((Index i fs) ast a)+{-# INLINABLE fromHVariantAt #-}+fromHVariantAt (VariantF (Variant t a)) = do+ guard (t == natValue' @i)+ return (unsafeCoerce a)++type instance HBase (EGADT xs) = HVariantF xs++instance HFunctor (HVariantF xs) => HRecursive (EGADT xs) where+ hproject (EGADT a) = a++instance HFunctor (HVariantF xs) => HCorecursive (EGADT xs) where+ hembed = EGADT++type family f :<! fs :: Constraint where+ f :<! fs = ( MemberAtIndex (IndexOf f fs) f fs )++type family MemberAtIndex (i :: Nat) f fs :: Constraint where+ MemberAtIndex i f fs = ( KnownNat i, Index i fs ~ f )++type family (:<<!) xs ys :: Constraint where+ '[] :<<! ys = ()+ (x ': xs) :<<! ys = (x :<! ys, xs :<<! ys)++-- | Pattern-match in an extensible GADT+pattern VF :: forall e a f fs.+ ( e ~ EGADT fs a -- allow easy use of TypeApplication to set the EGADT type+ , f :<! fs+ ) => f (EGADT fs) a -> EGADT fs a+pattern VF x <- ( ( \ ( EGADT (HVariantF v) ) -> fromHVariantAt @(IndexOf f fs) @fs v ) -> Just x )+ where+ VF x = EGADT (HVariantF (toHVariantAt @(IndexOf f fs) @fs x))
+ src/lib/Data/Variant/Excepts.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.Variant.Excepts+ ( Excepts (..)+ , runE+ , runE_+ , liftE+ , appendE+ , prependE+ , failureE+ , successE+ , throwE+ , throwSomeE+ , catchE+ , catchEvalE+ , evalE+ , onE_+ , onE+ , finallyE+ , injectExcepts+ , withExcepts+ , withExcepts_+ , mapExcepts+ , variantToExcepts+ , veitherToExcepts+ , catchLiftBoth+ , catchLiftLeft+ , catchLiftRight+ , catchAllE+ , catchDieE+ , catchRemove+ , sequenceE+ , runBothE+ -- * Reexport+ , module Data.Variant.VEither+ )+where++import GHC.TypeLits+import Data.Variant.Types+import Data.Variant.VEither++import Control.Monad+import Control.Monad.Catch+import Control.Monad.Reader.Class+import Control.Monad.Trans.Class++#if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0)+import qualified Control.Monad.Fail+import Control.Monad.Fail ( MonadFail )+#endif++#if defined(ENABLE_UNLIFTIO)+import Control.Monad.IO.Unlift+import qualified Control.Exception as E+#endif++newtype Excepts es m a = Excepts (m (VEither es a))++deriving instance Show (m (VEither es a)) => Show (Excepts es m a)++-- | Run an Excepts+runE :: forall es a m.+ Excepts es m a -> m (VEither es a)+{-# INLINABLE runE #-}+runE (Excepts m) = m++-- | Run an Excepts, discard the result value+runE_ :: forall es a m.+ Functor m => Excepts es m a -> m ()+{-# INLINABLE runE_ #-}+runE_ m = void (runE m)++injectExcepts :: forall es a m.+ Monad m => Excepts es m a -> Excepts es m (VEither es a)+{-# INLINABLE injectExcepts #-}+injectExcepts (Excepts m) = lift m++withExcepts_ :: Monad m => (VEither es a -> m ()) -> Excepts es m a -> Excepts es m a+{-# INLINABLE withExcepts_ #-}+withExcepts_ f (Excepts m) = Excepts $ do+ v <- m+ f v+ return v++withExcepts :: Monad m => (VEither es a -> m b) -> Excepts es m a -> Excepts es m b+{-# INLINABLE withExcepts #-}+withExcepts f (Excepts m) = Excepts $ do+ v <- m+ VRight <$> f v++-- | Convert a flow without error into a value+evalE :: Monad m => Excepts '[] m a -> m a+{-# INLINABLE evalE #-}+evalE v = veitherToValue <$> runE v++mapExcepts :: (m (VEither es a) -> n (VEither es' b)) -> Excepts es m a -> Excepts es' n b+{-# INLINABLE mapExcepts #-}+mapExcepts f = Excepts . f . runE++-- | Lift a Excepts into another+liftE :: forall es' es a m.+ ( Monad m+ , VEitherLift es es'+ ) => Excepts es m a -> Excepts es' m a+{-# INLINABLE liftE #-}+liftE = mapExcepts (liftM veitherLift)++-- | Append errors to an Excepts+appendE :: forall ns es a m.+ ( Monad m+ ) => Excepts es m a -> Excepts (Concat es ns) m a+{-# INLINABLE appendE #-}+appendE = mapExcepts (liftM (veitherAppend @ns))++-- | Prepend errors to an Excepts+prependE :: forall ns es a m.+ ( Monad m+ , KnownNat (Length ns)+ ) => Excepts es m a -> Excepts (Concat ns es) m a+{-# INLINABLE prependE #-}+prependE = mapExcepts (liftM (veitherPrepend @ns))++instance Functor m => Functor (Excepts es m) where+ {-# INLINABLE fmap #-}+ fmap f = mapExcepts (fmap (fmap f))++instance Foldable m => Foldable (Excepts es m) where+ {-# INLINABLE foldMap #-}+ foldMap f (Excepts m) = foldMap (veitherCont (const mempty) f) m++instance Traversable m => Traversable (Excepts es m) where+ {-# INLINABLE traverse #-}+ traverse f (Excepts m) =+ Excepts <$> traverse (veitherCont (pure . VLeft) (fmap VRight . f)) m++instance (Functor m, Monad m) => Applicative (Excepts es m) where+ {-# INLINABLE pure #-}+ pure a = Excepts $ return (VRight a)++ {-# INLINABLE (<*>) #-}+ Excepts mf <*> Excepts ma = Excepts $ do+ f <- mf+ case f of+ VLeft e -> return (VLeft e)+ VRight k -> do+ a <- ma+ case a of+ VLeft e -> return (VLeft e)+ VRight x -> return (VRight (k x))++ {-# INLINABLE (*>) #-}+ m *> k = m >>= \_ -> k++instance (Monad m) => Monad (Excepts es m) where+ {-# INLINABLE (>>=) #-}+ m >>= k = Excepts $ do+ a <- runE m+ case a of+ VLeft es -> return (VLeft es)+ VRight x -> runE (k x)++#if MIN_VERSION_base(4,12,0)+instance (MonadFail m) => MonadFail (Excepts es m) where+#endif+ {-# INLINABLE fail #-}+ fail = Excepts . fail++instance MonadTrans (Excepts e) where+ {-# INLINABLE lift #-}+ lift = Excepts . liftM VRight++instance (MonadIO m) => MonadIO (Excepts es m) where+ {-# INLINABLE liftIO #-}+ liftIO = lift . liftIO+++-- | Throws exceptions into the base monad.+instance MonadThrow m => MonadThrow (Excepts e m) where+ {-# INLINABLE throwM #-}+ throwM = lift . throwM++-- | Catches exceptions from the base monad.+instance MonadCatch m => MonadCatch (Excepts e m) where+ catch (Excepts m) f = Excepts $ catch m (runE . f)++instance MonadMask m => MonadMask (Excepts e m) where+ mask f = Excepts $ mask $ \u -> runE $ f (q u)+ where+ q :: (m (VEither e a) -> m (VEither e a)) -> Excepts e m a -> Excepts e m a+ q u (Excepts b) = Excepts (u b)++ uninterruptibleMask f = Excepts $ uninterruptibleMask $ \u -> runE $ f (q u)+ where+ q :: (m (VEither e a) -> m (VEither e a)) -> Excepts e m a -> Excepts e m a+ q u (Excepts b) = Excepts (u b)++ generalBracket acquire release use = Excepts $ do+ (eb, ec) <- generalBracket+ (runE acquire)+ (\eresource exitCase -> case eresource of+ VLeft e -> return (VLeft e) -- nothing to release, acquire didn't succeed+ VRight resource -> case exitCase of+ ExitCaseSuccess (VRight b) -> runE (release resource (ExitCaseSuccess b))+ ExitCaseException e -> runE (release resource (ExitCaseException e))+ _ -> runE (release resource ExitCaseAbort))+ (veitherCont (return . VLeft) (runE . use))+ runE $ do+ -- The order in which we perform those two 'Excepts' effects determines+ -- which error will win if they are both erroring. We want the error from+ -- 'release' to win.+ c <- Excepts (return ec)+ b <- Excepts (return eb)+ return (b, c)++instance MonadReader r m => MonadReader r (Excepts e m) where+ ask = lift ask+ local = mapExcepts . local+ reader = lift . reader+++-- | Signal an exception value @e@.+throwE :: forall e es a m. (Monad m, e :< es) => e -> Excepts es m a+{-# INLINABLE throwE #-}+throwE = Excepts . pure . VLeft . V++-- | Throw some exception+throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a+{-# INLINABLE throwSomeE #-}+throwSomeE = Excepts . pure . VLeft . liftVariant++-- | Signal an exception value @e@.+failureE :: forall e a m. Monad m => e -> Excepts '[e] m a+{-# INLINABLE failureE #-}+failureE = throwE++-- | Signal a success+successE :: forall a m. Monad m => a -> Excepts '[] m a+{-# INLINABLE successE #-}+successE = pure++-- | Handle an exception. Lift both normal and exceptional flows into the result+-- flow+catchE :: forall e es' es'' es a m.+ ( Monad m+ , e :< es+ , LiftVariant (Remove e es) es'+ , LiftVariant es'' es'+ ) => (e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchE #-}+catchE = catchLiftBoth++-- | Handle an exception. Lift both normal and exceptional flows into the result+-- flow+catchLiftBoth :: forall e es' es'' es a m.+ ( Monad m+ , e :< es+ , LiftVariant (Remove e es) es'+ , LiftVariant es'' es'+ ) => (e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchLiftBoth #-}+catchLiftBoth h m = Excepts $ do+ a <- runE m+ case a of+ VRight r -> return (VRight r)+ VLeft ls -> case popVariant ls of+ Right l -> runE (liftE (h l))+ Left rs -> return (VLeft (liftVariant rs))++-- | Handle an exception. Assume it is in the first position+catchRemove :: forall e es a m.+ ( Monad m+ ) => (e -> Excepts es m a) -> Excepts (e ': es) m a -> Excepts es m a+{-# INLINABLE catchRemove #-}+catchRemove h m = Excepts $ do+ a <- runE m+ case a of+ VRight r -> return (VRight r)+ VLeft ls -> case popVariantHead ls of+ Right l -> runE (h l)+ Left rs -> return (VLeft rs)++-- | Handle an exception. Lift the remaining errors into the resulting flow+catchLiftLeft :: forall e es es' a m.+ ( Monad m+ , e :< es+ , LiftVariant (Remove e es) es'+ ) => (e -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchLiftLeft #-}+catchLiftLeft h m = Excepts $ do+ a <- runE m+ case a of+ VRight r -> return (VRight r)+ VLeft ls -> case popVariant ls of+ Right l -> runE (h l)+ Left rs -> return (VLeft (liftVariant rs))++-- | Handle an exception. Lift the handler into the resulting flow+catchLiftRight :: forall e es es' a m.+ ( Monad m+ , e :< es+ , LiftVariant es' (Remove e es)+ ) => (e -> Excepts es' m a) -> Excepts es m a -> Excepts (Remove e es) m a+{-# INLINABLE catchLiftRight #-}+catchLiftRight h m = Excepts $ do+ a <- runE m+ case a of+ VRight r -> return (VRight r)+ VLeft ls -> case popVariant ls of+ Right l -> runE (liftE (h l))+ Left rs -> return (VLeft rs)++-- | Do something in case of error+catchAllE :: Monad m => (V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a+{-# INLINABLE catchAllE #-}+catchAllE h m = Excepts $ do+ a <- runE m+ case a of+ VRight x -> return (VRight x)+ VLeft xs -> runE (h xs)++-- | Evaluate a Excepts. Use the provided function to handle error cases.+catchEvalE :: Monad m => (V es -> m a) -> Excepts es m a -> m a+{-# INLINABLE catchEvalE #-}+catchEvalE h m = do+ a <- runE m+ case a of+ VRight x -> return x+ VLeft xs -> h xs++-- | Catch and die in case of error+catchDieE :: (e :< es, Monad m) => (e -> m ()) -> Excepts es m a -> Excepts (Remove e es) m a+{-# INLINABLE catchDieE #-}+catchDieE h m = Excepts $ do+ a <- runE m+ case a of+ VRight r -> return (VRight r)+ VLeft ls -> case popVariant ls of+ Right l -> h l >> error "catchDieE"+ Left rs -> return (VLeft rs)++-- | Do something in case of error+onE_ :: Monad m => m () -> Excepts es m a -> Excepts es m a+{-# INLINABLE onE_ #-}+onE_ h m = Excepts $ do+ a <- runE m+ case a of+ VRight _ -> return a+ VLeft _ -> h >> return a++-- | Do something in case of error+onE :: Monad m => (V es -> m ()) -> Excepts es m a -> Excepts es m a+{-# INLINABLE onE #-}+onE h m = Excepts $ do+ a <- runE m+ case a of+ VRight _ -> return a+ VLeft es -> h es >> return a++-- | Finally for Excepts+finallyE :: Monad m => m () -> Excepts es m a -> Excepts es m a+{-# INLINABLE finallyE #-}+finallyE h m = Excepts $ do+ a <- runE m+ h+ return a++-- | Convert a Variant into a Excepts+variantToExcepts :: Monad m => V (a ': es) -> Excepts es m a+{-# INLINABLE variantToExcepts #-}+variantToExcepts v = Excepts (return (veitherFromVariant v))++-- | Convert a VEither into a Excepts+veitherToExcepts :: Monad m => VEither es a -> Excepts es m a+{-# INLINABLE veitherToExcepts #-}+veitherToExcepts v = Excepts (return v)++-- | Product of the execution of two Excepts+--+-- You can use a generic monad combinator such as+-- `Control.Concurrent.Async.concurrently` (in "async" package) to get+-- concurrent execution.+--+-- >> concurrentE = runBothE concurrently+runBothE ::+ ( KnownNat (Length (b:e2))+ , Monad m+ ) => (forall x y. m x -> m y -> m (x,y)) -> Excepts e1 m a -> Excepts e2 m b -> Excepts (Tail (Product (a:e1) (b:e2))) m (a,b)+runBothE exec f g = Excepts do+ (v1,v2) <- exec (runE f) (runE g)+ pure (veitherProduct v1 v2)++-- | Product of the sequential execution of two Excepts+--+-- The second one is run even if the first one failed!+sequenceE ::+ ( KnownNat (Length (b:e2))+ , Monad m+ ) => Excepts e1 m a -> Excepts e2 m b -> Excepts (Tail (Product (a:e1) (b:e2))) m (a,b)+sequenceE = runBothE exec+ where+ exec f g = do+ v1 <- f+ v2 <- g+ pure (v1,v2)++#if defined(ENABLE_UNLIFTIO)+instance forall es m . (MonadCatch m, MonadUnliftIO m, Exception (V es)) => MonadUnliftIO (Excepts es m) where+ withRunInIO exceptSToIO = Excepts $ fmap (either VLeft VRight) $ try $ do+ withRunInIO $ \runInIO ->+ exceptSToIO (runInIO . ((\case+ VLeft v -> liftIO $ E.throwIO $ toException v+ VRight a -> pure a) <=< runE))+#endif
+ src/lib/Data/Variant/Functor.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | Functor and recursion schemes+--+-- Simple API is intended to be easier to understand (e.g. they don't use+-- xxmorphism and xxxalgebra jargon but tree-traversal-like terms).+module Data.Variant.Functor+ ( -- * Simple API+ BottomUpT+ , bottomUp+ , BottomUpOrigT+ , bottomUpOrig+ , TopDownStopT+ , topDownStop+ -- * Recursion schemes+ , module Data.Functor.Classes+ , module Data.Functor.Foldable+ , Algebra+ , CoAlgebra+ , RAlgebra+ , RCoAlgebra+ -- * Higher-order recursion schemes+ , type (~>)+ , type NatM+ , HBase+ , HAlgebra+ , HAlgebraM+ , HGAlgebra+ , HGAlgebraM+ , HCoalgebra+ , HCoalgebraM+ , HGCoalgebra+ , HGCoalgebraM+ , HFunctor (..)+ , HFoldable (..)+ , HTraversable (..)+ , HRecursive (..)+ , HCorecursive (..)+ , hhylo+ , hcataM+ , hlambek+ , hpara+ , hparaM+ , hanaM+ , hcolambek+ , hapo+ , hapoM+ , hhyloM+ )+where++import Data.Functor.Foldable hiding (ListF(..))+import Data.Functor.Classes+import Data.Functor.Sum+import Data.Functor.Product+import Data.Kind+import Control.Monad++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative+#endif+++-------------------------------------------+-- Simple API+-------------------------------------------++type BottomUpT a f = f a -> a+type BottomUpOrigT t a f = f (t,a) -> a+type TopDownStopT a f = f a -> Either (f a) a++-- | Bottom-up traversal (catamorphism)+bottomUp :: (Recursive t) => (Base t a -> a) -> t -> a+bottomUp f t = cata f t++-- | Bottom-up traversal with original value (paramorphism)+bottomUpOrig :: (Recursive t) => (Base t (t,a) -> a) -> t -> a+bottomUpOrig f t = para f t++-- | Perform a top-down traversal+--+-- Right: stop the traversal ("right" value obtained)+-- Left: continue the traversal recursively on the new value+topDownStop :: (Recursive t, Corecursive t) => (Base t t -> Either (Base t t) t) -> t -> t+topDownStop f t = go t+ where+ go w = case f (project w) of+ Right x -> x -- stop here+ Left x -> embed (fmap go x) -- continue recursively+++-------------------------------------------+-- Recursion schemes+-------------------------------------------++type Algebra f a = f a -> a+type CoAlgebra f a = a -> f a+type RAlgebra f t a = f (t, a) -> a+type RCoAlgebra f t a = a -> f (Either t a)+++-------------------------------------------+-- Higher-order+-------------------------------------------+++type f ~> g = forall a. f a -> g a+type NatM m f g = forall a. f a -> m (g a)++type family HBase (h :: k -> Type) :: (k -> Type) -> (k -> Type)++type HAlgebra h f = h f ~> f+type HAlgebraM m h f = NatM m (h f) f+type HGAlgebra w h a = h (w a) ~> a+type HGAlgebraM w m h a = NatM m (h (w a)) a++type HCoalgebra h f = f ~> h f+type HCoalgebraM m h f = NatM m f (h f)+type HGCoalgebra m h a = a ~> h (m a)+type HGCoalgebraM n m h a = NatM m a (h (n a))++class HFunctor (h :: (k -> Type) -> (k -> Type)) where+ hfmap :: (f ~> g) -> h f ~> h g++class HFunctor h => HFoldable (h :: (k -> Type) -> (k -> Type)) where+ hfoldMap :: Monoid m => (forall b. f b -> m) -> h f a -> m++class HFoldable h => HTraversable (h :: (k -> Type) -> (k -> Type)) where+ htraverse :: Applicative e => NatM e f g -> NatM e (h f) (h g)++class HFunctor (HBase h) => HRecursive (h :: k -> Type) where+ hproject :: HCoalgebra (HBase h) h++ hcata :: HAlgebra (HBase h) f -> h ~> f+ hcata algebra = algebra . hfmap (hcata algebra) . hproject++class HFunctor (HBase h) => HCorecursive (h :: k -> Type) where+ hembed :: HAlgebra (HBase h) h++ hana :: HCoalgebra (HBase h) f -> f ~> h+ hana coalgebra = hembed . hfmap (hana coalgebra) . coalgebra++hhylo :: HFunctor f => HAlgebra f b -> HCoalgebra f a -> a ~> b+hhylo f g = f . hfmap (hhylo f g) . g++hcataM :: (Monad m, HTraversable (HBase h), HRecursive h) => HAlgebraM m (HBase h) f -> h a -> m (f a)+hcataM f = f <=< htraverse (hcataM f) . hproject++hlambek :: (HRecursive h, HCorecursive h) => HCoalgebra (HBase h) h+hlambek = hcata (hfmap hembed)++hpara :: (HFunctor (HBase h), HRecursive h) => HGAlgebra (Product h) (HBase h) a -> h ~> a+hpara phi = phi . hfmap (\a -> Pair a (hpara phi a)) . hproject++hparaM :: (HTraversable (HBase h), HRecursive h, Monad m) => HGAlgebraM (Product h) m (HBase h) a -> NatM m h a+hparaM phiM = phiM <=< htraverse (\a -> liftA2 Pair (pure a) (hparaM phiM a)) . hproject++hanaM :: (Monad m, HTraversable (HBase h), HCorecursive h) => HCoalgebraM m (HBase h) f -> f a -> m (h a)+hanaM f = fmap hembed . htraverse (hanaM f) <=< f++hcolambek :: HRecursive h => HCorecursive h => HAlgebra (HBase h) h+hcolambek = hana (hfmap hproject)++hapo :: HCorecursive h => HGCoalgebra (Sum h) (HBase h) a -> a ~> h+hapo psi = hembed . hfmap (coproduct id (hapo psi)) . psi+ where+ coproduct f _ (InL a) = f a+ coproduct _ g (InR a) = g a++hapoM :: (HCorecursive h, HTraversable (HBase h), Monad m) => HGCoalgebraM (Sum h) m (HBase h) a -> NatM m a h+hapoM psiM = fmap hembed . htraverse (coproduct pure (hapoM psiM)) <=< psiM+ where+ coproduct f _ (InL a) = f a+ coproduct _ g (InR a) = g a++hhyloM :: (HTraversable t, Monad m) => HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)+hhyloM f g = f <=< htraverse(hhyloM f g) <=< g
+ src/lib/Data/Variant/Syntax.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}++-- | Rebindable syntax for Variant+module Data.Variant.Syntax+ ( (>>=)+ , (>>)+ , return+ )+where++import Data.Variant+import Data.Variant.Types+import GHC.TypeLits++import Prelude hiding ((>>=),(>>),return)++(>>=) :: forall x xs ys. + ( KnownNat (Length ys)+ ) => V (x ': xs) -> (x -> V ys) -> V (Concat ys xs)+(>>=) = bindVariant++(>>) :: V xs -> V ys -> V (Concat ys xs)+(>>) = constBindVariant++return :: x -> V '[x]+return = variantFromValue
+ src/lib/Data/Variant/Tuple.hs view
@@ -0,0 +1,553 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}++#if MIN_VERSION_base(4,14,0)+{-# LANGUAGE StandaloneKindSignatures #-}+#endif++-- | Tuple helpers+module Data.Variant.Tuple+ ( uncurry3+ , uncurry4+ , uncurry5+ , uncurry6+ , uncurry7+ , take4+ , fromTuple4+ , module Data.Tuple+#if !MIN_VERSION_base(4,18,0)+ , pattern MkSolo+#endif+ , Solo (..)+ , Tuple+ , Tuple#+ , TypeReps+ , ExtractTuple (..)+ , TupleCon (..)+ , tupleHead+ , TupleTail (..)+ , TupleCons (..)+ , ReorderTuple (..)+ )+where++import GHC.Exts+import GHC.TypeNats+import Data.Tuple++import Data.Variant.Types++#if !MIN_VERSION_base(4,16,0)+data Solo a = Solo a+#endif++#if !MIN_VERSION_base(4,18,0)+{-# COMPLETE MkSolo #-}+pattern MkSolo :: a -> Solo a+pattern MkSolo a = Solo a+#endif++-- | Uncurry3+uncurry3 :: (a -> b -> c -> r) -> (a,b,c) -> r+{-# INLINABLE uncurry3 #-}+uncurry3 fn (a,b,c) = fn a b c++-- | Uncurry4+uncurry4 :: (a -> b -> c -> d -> r) -> (a,b,c,d) -> r+{-# INLINABLE uncurry4 #-}+uncurry4 fn (a,b,c,d) = fn a b c d++-- | Uncurry5+uncurry5 :: (a -> b -> c -> d -> e -> r) -> (a,b,c,d,e) -> r+{-# INLINABLE uncurry5 #-}+uncurry5 fn (a,b,c,d,e) = fn a b c d e++-- | Uncurry6+uncurry6 :: (a -> b -> c -> d -> e -> f -> r) -> (a,b,c,d,e,f) -> r+{-# INLINABLE uncurry6 #-}+uncurry6 fn (a,b,c,d,e,f) = fn a b c d e f++-- | Uncurry7+uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> r) -> (a,b,c,d,e,f,g) -> r+{-# INLINABLE uncurry7 #-}+uncurry7 fn (a,b,c,d,e,f,g) = fn a b c d e f g+++-- | Take specialised for quadruple+take4 :: [a] -> (a,a,a,a)+{-# INLINABLE 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]+{-# INLINABLE fromTuple4 #-}+fromTuple4 (a,b,c,d) = [a,b,c,d]++-- | Extract a tuple value statically+class ExtractTuple (n :: Nat) xs where+ -- | Extract a tuple value by type-level index+ tupleN :: Tuple xs -> Index n xs++instance ExtractTuple 0 '[a] where+ {-# INLINABLE tupleN #-}+ tupleN (MkSolo t) = t++instance ExtractTuple 0 '[e0,e1] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_) = t++instance ExtractTuple 1 '[e0,e1] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t) = t++instance ExtractTuple 0 '[e0,e1,e2] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_,_) = t++instance ExtractTuple 1 '[e0,e1,e2] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t,_) = t++instance ExtractTuple 2 '[e0,e1,e2] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,t) = t++instance ExtractTuple 0 '[e0,e1,e2,e3] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_,_,_) = t++instance ExtractTuple 1 '[e0,e1,e2,e3] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t,_,_) = t++instance ExtractTuple 2 '[e0,e1,e2,e3] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,t,_) = t++instance ExtractTuple 3 '[e0,e1,e2,e3] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,t) = t+++instance ExtractTuple 0 '[e0,e1,e2,e3,e4] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_,_,_,_) = t++instance ExtractTuple 1 '[e0,e1,e2,e3,e4] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t,_,_,_) = t++instance ExtractTuple 2 '[e0,e1,e2,e3,e4] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,t,_,_) = t++instance ExtractTuple 3 '[e0,e1,e2,e3,e4] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,t,_) = t++instance ExtractTuple 4 '[e0,e1,e2,e3,e4] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,t) = t+++instance ExtractTuple 0 '[e0,e1,e2,e3,e4,e5] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_,_,_,_,_) = t++instance ExtractTuple 1 '[e0,e1,e2,e3,e4,e5] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t,_,_,_,_) = t++instance ExtractTuple 2 '[e0,e1,e2,e3,e4,e5] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,t,_,_,_) = t++instance ExtractTuple 3 '[e0,e1,e2,e3,e4,e5] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,t,_,_) = t++instance ExtractTuple 4 '[e0,e1,e2,e3,e4,e5] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,t,_) = t++instance ExtractTuple 5 '[e0,e1,e2,e3,e4,e5] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,_,t) = t+++instance ExtractTuple 0 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_,_,_,_,_,_) = t++instance ExtractTuple 1 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t,_,_,_,_,_) = t++instance ExtractTuple 2 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,t,_,_,_,_) = t++instance ExtractTuple 3 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,t,_,_,_) = t++instance ExtractTuple 4 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,t,_,_) = t++instance ExtractTuple 5 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,_,t,_) = t++instance ExtractTuple 6 '[e0,e1,e2,e3,e4,e5,e6] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,_,_,t) = t+++instance ExtractTuple 0 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (t,_,_,_,_,_,_,_) = t++instance ExtractTuple 1 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,t,_,_,_,_,_,_) = t++instance ExtractTuple 2 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,t,_,_,_,_,_) = t++instance ExtractTuple 3 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,t,_,_,_,_) = t++instance ExtractTuple 4 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,t,_,_,_) = t++instance ExtractTuple 5 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,_,t,_,_) = t++instance ExtractTuple 6 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,_,_,t,_) = t++instance ExtractTuple 7 '[e0,e1,e2,e3,e4,e5,e6,e7] where+ {-# INLINABLE tupleN #-}+ tupleN (_,_,_,_,_,_,_,t) = t++-- | Get first element of the tuple+tupleHead :: forall xs. ExtractTuple 0 xs => Tuple xs -> Index 0 xs+tupleHead = tupleN @0++class TupleTail ts ts' | ts -> ts' where+ tupleTail :: ts -> ts'++instance TupleTail (a,b) (Solo b) where+ {-# INLINABLE tupleTail #-}+ tupleTail (_,b) = MkSolo b++instance TupleTail (a,b,c) (b,c) where+ {-# INLINABLE tupleTail #-}+ tupleTail (_,b,c) = (b,c)++instance TupleTail (a,b,c,d) (b,c,d) where+ {-# INLINABLE tupleTail #-}+ tupleTail (_,b,c,d) = (b,c,d)++instance TupleTail (a,b,c,d,e) (b,c,d,e) where+ {-# INLINABLE tupleTail #-}+ tupleTail (_,b,c,d,e) = (b,c,d,e)++instance TupleTail (a,b,c,d,e,f) (b,c,d,e,f) where+ {-# INLINABLE 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 (Solo b) (a,b) where+ {-# INLINABLE tupleCons #-}+ tupleCons a (MkSolo b) = (a,b)++instance TupleCons a (b,c) (a,b,c) where+ {-# INLINABLE tupleCons #-}+ tupleCons a (b,c) = (a,b,c)++instance TupleCons a (b,c,d) (a,b,c,d) where+ {-# INLINABLE tupleCons #-}+ tupleCons a (b,c,d) = (a,b,c,d)++instance TupleCons a (b,c,d,e) (a,b,c,d,e) where+ {-# INLINABLE 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+ {-# INLINABLE 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 (Solo a) (Solo a) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b) (a,b) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c) (a,b,c) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c,d) (a,b,c,d) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c,d,e) (a,b,c,d,e) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c,d,e,f) (a,b,c,d,e,f) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c,d,e,f,g) (a,b,c,d,e,f,g) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id++instance ReorderTuple (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i) where+ {-# INLINABLE 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+ {-# INLINABLE tupleReorder #-}+ tupleReorder = id+++instance ReorderTuple (a,b) (b,a) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder (a,b) = (b,a)++instance ReorderTuple (a,b,c) (a,c,b) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder (a,b,c) = (a,c,b)++instance ReorderTuple (a,b,c) (b,a,c) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder (a,b,c) = (b,a,c)++instance ReorderTuple (a,b,c) (b,c,a) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder (a,b,c) = (b,c,a)++instance ReorderTuple (a,b,c) (c,a,b) where+ {-# INLINABLE tupleReorder #-}+ tupleReorder (a,b,c) = (c,a,b)++instance ReorderTuple (a,b,c) (c,b,a) where+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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+ {-# INLINABLE 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)++type family TupleFun r xs where+ TupleFun r '[] = r+ TupleFun r (x:xs) = x -> (TupleFun r xs)++-- | Create a Tuple+class TupleCon xs where+ -- | Create a Tuple+ tupleCon :: TupleFun (Tuple xs) xs++instance TupleCon '[] where+ tupleCon = ()++instance TupleCon '[a] where+ tupleCon = MkSolo++instance TupleCon '[a,b] where+ tupleCon = (,)++instance TupleCon '[a,b,c] where+ tupleCon = (,,)++instance TupleCon '[a,b,c,d] where+ tupleCon = (,,,)++instance TupleCon '[a,b,c,d,e] where+ tupleCon = (,,,,)++instance TupleCon '[a,b,c,d,e,f] where+ tupleCon = (,,,,,)++-- | Boxed tuple+--+-- TODO: put this family into GHC+type family Tuple xs = t | t -> xs where+ Tuple '[] = ()+ Tuple '[a] = Solo a+ Tuple '[a,b] = (a,b)+ Tuple '[a,b,c] = (a,b,c)+ Tuple '[a,b,c,d] = (a,b,c,d)+ Tuple '[a,b,c,d,e] = (a,b,c,d,e)+ Tuple '[a,b,c,d,e,f] = (a,b,c,d,e,f)+ Tuple '[a,b,c,d,e,f,g] = (a,b,c,d,e,f,g)+ Tuple '[a,b,c,d,e,f,g,h] = (a,b,c,d,e,f,g,h)+ Tuple '[a,b,c,d,e,f,g,h,i] = (a,b,c,d,e,f,g,h,i)+ Tuple '[a,b,c,d,e,f,g,h,i,j] = (a,b,c,d,e,f,g,h,i,j)+ Tuple '[a,b,c,d,e,f,g,h,i,j,k] = (a,b,c,d,e,f,g,h,i,j,k)+ Tuple '[a,b,c,d,e,f,g,h,i,j,k,l] = (a,b,c,d,e,f,g,h,i,j,k,l)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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)+ Tuple '[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 TypeReps xs where+ TypeReps '[] = '[]+ TypeReps ((a::TYPE k) ': as) = k ': TypeReps as++-- | Unboxed tuple+--+-- TODO: put this family into GHC+#if MIN_VERSION_base(4,14,0)+type Tuple# :: forall xs -> TYPE ('TupleRep (TypeReps xs))+type family Tuple# xs = t | t -> xs where+#else+type family Tuple# xs = (t :: TYPE ('TupleRep (TypeReps xs))) | t -> xs where+#endif+ Tuple# '[] = (##)+ Tuple# '[a] = (# a #)+ Tuple# '[a,b] = (# a,b #)+ Tuple# '[a,b,c] = (# a,b,c #)+ Tuple# '[a,b,c,d] = (# a,b,c,d #)+ Tuple# '[a,b,c,d,e] = (# a,b,c,d,e #)+ Tuple# '[a,b,c,d,e,f] = (# a,b,c,d,e,f #)+ Tuple# '[a,b,c,d,e,f,g] = (# a,b,c,d,e,f,g #)+ Tuple# '[a,b,c,d,e,f,g,h] = (# a,b,c,d,e,f,g,h #)+ Tuple# '[a,b,c,d,e,f,g,h,i] = (# a,b,c,d,e,f,g,h,i #)
+ src/lib/Data/Variant/Types.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.Variant.Types+ ( natValue+ , natValue'+ , Index+ , Concat+ , Length+ , Product+ , Remove+ , Nub+ , Reverse+ , IndexOf+ , MaybeIndexOf+ , Member+ , InsertAt+ , ReplaceAt+ , IndexesOf+ , ReplaceN+ , ReplaceNS+ , Complement+ , RemoveAt+ , RemoveAt1+ , Tail+ , Constraint+ , ConstraintAll1+ )+where++import GHC.TypeLits+import Data.Kind+import Data.Proxy++-- | Get a Nat value+natValue :: forall (n :: Nat) a. (KnownNat n, Num a) => a+{-# INLINABLE natValue #-}+natValue = fromIntegral (natVal (Proxy :: Proxy n))++-- | Get a Nat value as a Word+natValue' :: forall (n :: Nat). KnownNat n => Word+{-# INLINABLE natValue' #-}+natValue' = natValue @n++-- | Indexed access into the list+type Index (n :: Nat) (l :: [k]) = Index' n l l++-- | Indexed access into the list+type family Index' (n :: Nat) (l :: [k]) (l2 :: [k]) :: k where+ Index' 0 (x ': _ ) _ = x+ Index' n (_ ': xs) l2 = Index' (n-1) xs l2+ Index' n '[] l2 = TypeError ( 'Text "Index "+ ':<>: 'ShowType n+ ':<>: 'Text " out of bounds for list:"+ ':$$: 'Text " "+ ':<>: 'ShowType l2 )++-- | Concat two type lists+type family Concat (xs :: [k]) (ys :: [k]) :: [k] where+ Concat '[] '[] = '[]+ Concat '[] ys = ys+ Concat (x ': xs) ys = x ': Concat xs ys++-- | Get list length+type family Length (xs :: [k]) :: Nat where+ Length xs = Length' 0 xs++type family Length' n (xs :: [k]) :: Nat where+ Length' n '[] = n+ Length' n (x ': xs) = Length' (n+1) xs+ +-- | Product of two lists+type family Product (xs :: [Type]) (ys :: [Type]) :: [Type] where+ Product '[] ys = '[]+ Product xy '[] = '[]+ Product (x:xs) ys = Concat (Product' x ys) (Product xs ys)++type family Product' (x :: Type) (ys :: [Type]) :: [Type] where+ Product' x '[] = '[]+ Product' x (y ': ys) = (x,y) ': Product' x ys++-- | Remove `a` in `l`+type family Remove (a :: k) (l :: [k]) :: [k] where+ Remove a '[] = '[]+ Remove a (a ': as) = Remove a as+ Remove a (b ': as) = b ': Remove a as+++-- | Keep only a single value of each type+type family Nub (l :: [k]) :: [k] where+ Nub xs = Reverse (Nub' xs '[])++type family Nub' (as :: [k]) (xs :: [k]) :: [k] where+ Nub' '[] xs = xs+ Nub' (x ': as) xs = Nub' (Remove x as) (x ': xs) ++-- | Reverse a list+type family Reverse (l :: [k]) :: [k] where+ Reverse l = Reverse' l '[]++type family Reverse' (l :: [k]) (l2 :: [k]) :: [k] where+ Reverse' '[] l = l+ Reverse' (x ': xs) l = Reverse' xs (x ': l)++-- | Get the first index of a type+type IndexOf (x :: k) (xs :: [k]) = IndexOf' (MaybeIndexOf x xs) x xs++-- | Get the first index of a type+type family IndexOf' (i :: Nat) (a :: k) (l :: [k]) :: Nat where+ IndexOf' 0 x l = TypeError ( 'ShowType x+ ':<>: 'Text " not found in list:"+ ':$$: 'Text " "+ ':<>: 'ShowType l )+ IndexOf' i _ _ = i - 1++-- | Get the first index (starting from 1) of a type or 0 if none+type family MaybeIndexOf (a :: k) (l :: [k]) where+ MaybeIndexOf x xs = MaybeIndexOf' 0 x xs++-- | Helper for MaybeIndexOf+type family MaybeIndexOf' (n :: Nat) (a :: k) (l :: [k]) where+ MaybeIndexOf' n x '[] = 0+ MaybeIndexOf' n x (x ': xs) = n + 1+ MaybeIndexOf' n x (y ': xs) = MaybeIndexOf' (n+1) x xs++-- | Constraint: x member of xs+type family Member x xs :: Constraint where+ Member x xs = MemberAtIndex (IndexOf x xs) x xs+ +type MemberAtIndex i x xs =+ ( x ~ Index i xs+ , KnownNat i+ )++-- | Constraint: all the xs are members of ys+type family Members xs ys :: Constraint where+ Members '[] ys = ()+ Members (x ': xs) ys = (Member x ys, Members xs ys)++-- | Insert a list at n+type family InsertAt (n :: Nat) (l :: [k]) (l2 :: [k]) :: [k] where+ InsertAt 0 xs ys = Concat ys xs+ InsertAt n (x ': xs) ys = x ': InsertAt (n-1) xs ys++-- | replace l[n] with l2 (folded)+type family ReplaceAt (n :: Nat) (l :: [k]) (l2 :: [k]) :: [k] where+ ReplaceAt 0 (x ': xs) ys = Concat ys xs+ ReplaceAt n (x ': xs) ys = x ': ReplaceAt (n-1) xs ys++-- | Get all the indexes of a type+type family IndexesOf (a :: k) (l :: [k]) :: [Nat] where+ IndexesOf x xs = IndexesOf' 0 x xs++-- | Get the first index of a type+type family IndexesOf' n (a :: k) (l :: [k]) :: [Nat] where+ IndexesOf' n x '[] = '[]+ IndexesOf' n x (x ': xs) = n ': IndexesOf' (n+1) x xs+ IndexesOf' n x (y ': xs) = IndexesOf' (n+1) x xs++-- | replace a type at offset n in l+type family ReplaceN (n :: Nat) (t :: k) (l :: [k]) :: [k] where+ ReplaceN 0 t (x ': xs) = (t ': xs)+ ReplaceN n t (x ': xs) = x ': ReplaceN (n-1) t xs++-- | replace types at offsets ns in l+type family ReplaceNS (ns :: [Nat]) (t :: k) (l :: [k]) :: [k] where+ ReplaceNS '[] t l = l+ ReplaceNS (i ': is) t l = ReplaceNS is t (ReplaceN i t l)++-- | Complement xs \ ys+type family Complement (xs :: [k]) (ys :: [k]) :: [k] where+ Complement xs '[] = xs+ Complement xs (y:ys) = Complement (Remove y xs) ys++-- | Remove a type at index+type family RemoveAt (n :: Nat) (l :: [k]) :: [k] 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 :: [k]) :: [k] where+ RemoveAt1 0 xs = xs+ RemoveAt1 1 (x ': xs) = xs+ RemoveAt1 n (x ': xs) = x ': RemoveAt1 (n-1) xs++-- | Tail of a list+type family Tail (xs :: [k]) :: [k] where+ Tail (x ': xs) = xs+++-- | Build a list of constraints+-- e.g., ConstraintAll1 Eq '[A,B,C] ==> (Eq A, Eq B, Eq C)+type family ConstraintAll1 (f :: k -> Constraint) (xs :: [k]) :: Constraint where+ ConstraintAll1 f '[] = ()+ ConstraintAll1 f (x ': xs) = (f x, ConstraintAll1 f xs)
+ src/lib/Data/Variant/VEither.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Variant biased towards one type+--+-- This allows definition of common type classes (Functor, etc.) that can't be+-- provided for Variant+module Data.Variant.VEither+ ( VEither+ , pattern VLeft+ , pattern VRight+ , veitherFromVariant+ , veitherToVariant+ , veitherToValue+ , veitherBimap+ , VEitherLift+ , veitherLift+ , veitherAppend+ , veitherPrepend+ , veitherCont+ , veitherToEither+ , veitherProduct+ , module Data.Variant+ )+where++import Data.Variant+import Data.Variant.Types++import Data.Coerce+import GHC.TypeLits++-- $setup+-- >>> :seti -XDataKinds+-- >>> :seti -XTypeApplications+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeFamilies+-- >>> import Data.Foldable+++-- | Variant biased towards one type+newtype VEither es a+ = VEither (V (a ': es))+++----------------------+-- Patterns+----------------------++-- | Left value+--+-- >>> VLeft (V "failed" :: V '[String,Int]) :: VEither '[String,Int] Bool+-- VLeft "failed"+--+pattern VLeft :: forall x xs. V xs -> VEither xs x+pattern VLeft xs <- ((popVariantHead . veitherToVariant) -> Left xs)+ where+ VLeft xs = VEither (toVariantTail xs)++-- | Right value+--+-- >>> VRight True :: VEither '[String,Int] Bool+-- VRight True+pattern VRight :: forall x xs. x -> VEither xs x+pattern VRight x <- ((popVariantHead . veitherToVariant) -> Right x)+ where+ VRight x = VEither (toVariantHead x)++{-# COMPLETE VLeft,VRight #-}++----------------------+-- Eq instance+----------------------++-- | Check VEithers for equality+--+-- >>> let a = VRight "Foo" :: VEither '[Int,Double] String+-- >>> let b = VRight "Foo" :: VEither '[Int,Double] String+-- >>> let c = VRight "Bar" :: VEither '[Int,Double] String+-- >>> let d = VLeft (V (1::Int) :: V '[Int, Double]) :: VEither '[Int,Double] String+-- >>> a == b+-- True+-- >>> a == c+-- False+-- >>> a == d+-- False+--+deriving newtype instance (Eq (V (a ': es))) => Eq (VEither es a)+++----------------------+-- Ord instance+----------------------++-- | Compare VEithers+--+-- >>> let a = VRight "Foo" :: VEither '[Int,Double] String+-- >>> let b = VRight "Bar" :: VEither '[Int,Double] String+-- >>> a < b+-- False+-- >>> a > b+-- True+--+deriving newtype instance (Ord (V (a ': es))) => Ord (VEither es a)+++----------------------+-- Show instance+----------------------++instance+ ( Show a+ , Show (V es)+ ) => Show (VEither es a) where+ showsPrec d v = showParen (d /= 0) $ case v of+ VLeft xs -> showString "VLeft "+ . showsPrec 10 xs+ VRight x -> showString "VRight "+ . showsPrec 10 x+++-- | Convert a Variant into a VEither+--+-- >>> let x = V "Test" :: V '[Int,String,Double]+-- >>> veitherFromVariant x+-- VLeft "Test"+--+veitherFromVariant :: V (a ': es) -> VEither es a+{-# INLINABLE veitherFromVariant #-}+veitherFromVariant = VEither++-- | Convert a VEither into a Variant+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> veitherToVariant x+-- True+--+veitherToVariant :: VEither es a -> V (a ': es)+{-# INLINABLE veitherToVariant #-}+veitherToVariant (VEither x) = x++-- | Convert a VEither into an Either+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> veitherToEither x+-- Right True+--+veitherToEither :: VEither es a -> Either (V es) a+{-# INLINABLE veitherToEither #-}+veitherToEither = \case+ VLeft xs -> Left xs+ VRight x -> Right x++-- | Extract from a VEither without left types+--+-- >>> let x = VRight True :: VEither '[] Bool+-- >>> veitherToValue x+-- True+veitherToValue :: forall a. VEither '[] a -> a+{-# INLINABLE veitherToValue #-}+veitherToValue = coerce (variantToValue @a)++-- | Bimap for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> veitherBimap id not x+-- VRight False+--+veitherBimap :: (V es -> V fs) -> (a -> b) -> VEither es a -> VEither fs b+{-# INLINABLE veitherBimap #-}+veitherBimap f g v = case v of+ VLeft xs -> VLeft (f xs)+ VRight x -> VRight (g x)+++type VEitherLift es es' =+ ( LiftVariant es es'+ )++-- | Lift a VEither into another+veitherLift :: forall es' es a.+ ( VEitherLift es es'+ ) => VEither es a -> VEither es' a+{-# INLINABLE veitherLift #-}+veitherLift = veitherBimap liftVariant id++-- | Prepend errors to VEither+veitherPrepend :: forall ns es a.+ ( KnownNat (Length ns)+ ) => VEither es a -> VEither (Concat ns es) a+{-# INLINABLE veitherPrepend #-}+veitherPrepend = veitherBimap (prependVariant @ns) id++-- | Append errors to VEither+veitherAppend :: forall ns es a.+ VEither es a -> VEither (Concat es ns) a+{-# INLINABLE veitherAppend #-}+veitherAppend = veitherBimap (appendVariant @ns) id++-- | VEither continuations+veitherCont :: (V es -> u) -> (a -> u) -> VEither es a -> u+{-# INLINABLE veitherCont #-}+veitherCont f g v = case v of+ VLeft xs -> f xs+ VRight x -> g x++-- | Product of two VEither+veitherProduct :: KnownNat (Length (b:e2)) => VEither e1 a -> VEither e2 b -> VEither (Tail (Product (a:e1) (b:e2))) (a,b)+veitherProduct (VEither x) (VEither y) = VEither (productVariant x y)++-- | Functor instance for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> fmap (\b -> if b then "Success" else "Failure") x+-- VRight "Success"+--+instance Functor (VEither es) where+ {-# INLINABLE fmap #-}+ fmap f (VEither v) = VEither (mapVariantAt @0 f v)++-- | Applicative instance for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> let y = VRight False :: VEither '[Int,Float] Bool+-- >>> (&&) <$> x <*> y+-- VRight False+-- >>> (||) <$> x <*> y+-- VRight True+--+instance Applicative (VEither es) where+ pure = VRight++ VRight f <*> VRight a = VRight (f a)+ VLeft v <*> _ = VLeft v+ _ <*> VLeft v = VLeft v++-- | Monad instance for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> let f v = VRight (not v) :: VEither '[Int,Float] Bool+-- >>> x >>= f+-- VRight False+--+instance Monad (VEither es) where+ VRight a >>= f = f a+ VLeft v >>= _ = VLeft v++-- | Foldable instance for VEither+--+-- >>> let x = VRight True :: VEither '[Int,Float] Bool+-- >>> let y = VLeft (V "failed" :: V '[String,Int]) :: VEither '[String,Int] Bool+-- >>> forM_ x print+-- True+-- >>> forM_ y print+--+instance Foldable (VEither es) where+ foldMap f (VRight a) = f a+ foldMap _ (VLeft _) = mempty++instance Traversable (VEither es) where+ traverse f (VRight a) = VRight <$> f a+ traverse _ (VLeft xs) = pure (VLeft xs)
+ src/lib/Data/Variant/VariantF.hs view
@@ -0,0 +1,422 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}++-- | VariantF functor+module Data.Variant.VariantF+ ( VariantF (..)+ , ApplyAll+ , pattern FV+ , appendVariantF+ , prependVariantF+ , toVariantFHead+ , toVariantFTail+ , popVariantFHead+ , variantFToValue+ , MapVariantF+ , mapVariantF+ , PopVariantF+ , popVariantF+ , LiftVariantF+ , liftVariantF+ , SplitVariantF+ , splitVariantF+ , variantFToCont+ , variantFToContM+ , contToVariantF+ , contToVariantFM+ -- * Algebras+ , BottomUpF+ , BottomUp (..)+ , BottomUpOrig (..)+ , BottomUpOrigF+ , TopDownStop (..)+ , TopDownStopF+ -- * Reexport+ , NoConstraint+ , module Data.Functor+ )+where++import Data.Variant+import Data.Variant.ContFlow+import Data.Variant.Types+import Data.Variant.Functor++import Data.Functor+import Data.Bifunctor+import Data.Kind+import GHC.TypeLits+import Control.DeepSeq++-- $setup+-- >>> :seti -XDataKinds+-- >>> :seti -XTypeApplications+-- >>> :seti -XTypeOperators+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeFamilies+-- >>> :seti -XPatternSynonyms+-- >>> :seti -XDeriveFunctor+-- >>> import Data.Functor.Classes+-- >>>+-- >>> data ConsF a e = ConsF a e deriving (Eq,Ord,Show,Functor)+-- >>> data NilF e = NilF deriving (Eq,Ord,Show,Functor)+-- >>> type ListF a = VariantF '[NilF,ConsF a]+-- >>>+-- >>> instance Eq a => Eq1 (ConsF a) where liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2+-- >>> instance Eq1 NilF where liftEq _ _ _ = True+-- >>>+-- >>> instance Ord a => Ord1 (ConsF a) where liftCompare cmp (ConsF a e1) (ConsF b e2) = compare a b <> cmp e1 e2+-- >>> instance Ord1 NilF where liftCompare _ _ _ = EQ+-- >>>+-- >>> instance Show a => Show1 (ConsF a) where liftShowsPrec shw _ p (ConsF a e) = showString "ConsF " . showsPrec 10 a . showString " " . shw 10 e+-- >>> instance Show1 NilF where liftShowsPrec _ _ _ _ = showString "NilF"+-- >>>+-- >>> liftEq (==) NilF (NilF :: NilF Int)+-- True+-- >>> liftEq (==) (ConsF 10 "Test") (ConsF 10 "Test" :: ConsF Int String)+-- True+-- >>> liftEq (==) (ConsF 10 "Test") (ConsF 8 "Test" :: ConsF Int String)+-- False+-- >>> liftEq (==) (ConsF 10 "Test") (ConsF 10 "XXX" :: ConsF Int String)+-- False++-- | Recursive Functor-like Variant+newtype VariantF (xs :: [t -> Type]) (e :: t)+ = VariantF (V (ApplyAll e xs))++-- | Apply its first argument to every element of the 2nd arg list+--+-- > ApplyAll e '[f,g,h] ==> '[f e, g e, h e]+--+type family ApplyAll (e :: t) (xs :: [t -> k]) :: [k] where+ ApplyAll e '[] = '[]+ ApplyAll e (f ': fs) = f e ': ApplyAll e fs++type instance Base (VariantF xs a) = VariantF xs++-- | Eq instance for VariantF+--+-- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String+-- >>> let a' = FV (ConsF 'a' "XXX") :: VariantF '[ConsF Char,NilF] String+-- >>> let b = FV (ConsF 'b' "Test") :: VariantF '[ConsF Char,NilF] String+-- >>> a == a+-- True+-- >>> a == a'+-- False+-- >>> a == b+-- False+--+-- >>> let c = FV (ConsF 'c' b) :: VariantF '[ConsF Char,NilF] (VariantF '[ConsF Char, NilF] String)+-- >>> c == c+-- True+--+-- >>> let n1 = FV (NilF :: NilF ()) :: VariantF '[ConsF Char,NilF] ()+-- >>> let n2 = FV (NilF :: NilF ()) :: VariantF '[ConsF Char,NilF] ()+-- >>> n1 == n2+-- True+--+instance+ ( Eq1 (VariantF xs)+ , ConstraintAll1 Eq1 xs+ , Eq e+ ) => Eq (VariantF xs e)+ where+ (==) = eq1++-- | Ord instance for VariantF+--+-- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String+-- >>> let a' = FV (ConsF 'a' "XXX") :: VariantF '[ConsF Char,NilF] String+-- >>> let b = FV (ConsF 'b' "Test") :: VariantF '[ConsF Char,NilF] String+-- >>> compare a a+-- EQ+-- >>> compare a a'+-- LT+-- >>> compare a b+-- LT+instance+ ( Ord1 (VariantF xs)+ , ConstraintAll1 Ord1 xs+ , ConstraintAll1 Eq1 xs+ , Ord e+ ) => Ord (VariantF xs e)+ where+ compare = compare1+++instance Eq1 (VariantF '[]) where+ liftEq = undefined++instance+ ( Eq1 f+ , Eq1 (VariantF fs)+ , ConstraintAll1 Eq1 fs+ ) => Eq1 (VariantF (f:fs)) where+ liftEq cmp x y = case (popVariantFHead x, popVariantFHead y) of+ (Right a, Right b) -> liftEq cmp a b+ (Left a, Left b) -> liftEq cmp a b+ _ -> False++instance Ord1 (VariantF '[]) where+ liftCompare = undefined++instance+ ( Ord1 f+ , Ord1 (VariantF fs)+ , ConstraintAll1 Eq1 fs+ , ConstraintAll1 Ord1 fs+ ) => Ord1 (VariantF (f:fs)) where+ liftCompare cmp x@(VariantF v1) y@(VariantF v2) =+ case (popVariantFHead x, popVariantFHead y) of+ (Right a, Right b) -> liftCompare cmp a b+ (Left a, Left b) -> liftCompare cmp a b+ _ -> compare (variantIndex v1) (variantIndex v2)+++instance Show1 (VariantF '[]) where+ liftShowsPrec = undefined++instance+ ( Show1 f+ , Show1 (VariantF fs)+ , ConstraintAll1 Show1 fs+ ) => Show1 (VariantF (f:fs)) where+ liftShowsPrec shw shwl p x = case popVariantFHead x of+ Right a -> liftShowsPrec shw shwl p a+ Left a -> liftShowsPrec shw shwl p a++-- | Show instance for VariantF+--+-- >>> let a = FV (ConsF 'a' "Test") :: VariantF '[ConsF Char,NilF] String+-- >>> let b = FV (NilF :: NilF String) :: VariantF '[ConsF Char,NilF] String+-- >>> print a+-- ConsF 'a' "Test"+-- >>> print b+-- NilF+instance+ ( Show1 (VariantF xs)+ , ConstraintAll1 Show1 xs+ , Show e+ ) => Show (VariantF xs e)+ where+ showsPrec = showsPrec1++instance Functor (VariantF '[]) where+ fmap _ = undefined++instance (Functor (VariantF fs), Functor f) => Functor (VariantF (f ': fs)) where+ fmap f (VariantF v) = case popVariantHead v of+ Right x -> toVariantFHead (fmap f x)+ Left xs -> toVariantFTail (fmap f (VariantF xs))++++-- | Pattern-match in a VariantF+--+-- >>> FV (NilF :: NilF String) :: VariantF '[ConsF Char,NilF] String+-- NilF+pattern FV :: forall c cs e. c :< (ApplyAll e cs) => c -> VariantF cs e+pattern FV x = VariantF (V x)++-- | Retrieve a single value+variantFToValue :: VariantF '[f] e -> f e+variantFToValue (VariantF v) = variantToValue v++appendVariantF :: forall (ys :: [Type -> Type]) (xs :: [Type -> Type]) e.+ ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys)+ ) => VariantF xs e -> VariantF (Concat xs ys) e+appendVariantF (VariantF v) = VariantF (appendVariant @(ApplyAll e ys) v)++prependVariantF :: forall (xs :: [Type -> Type]) (ys :: [Type -> Type]) e.+ ( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys)+ , KnownNat (Length (ApplyAll e xs))+ ) => VariantF ys e -> VariantF (Concat xs ys) e+prependVariantF (VariantF v) = VariantF (prependVariant @(ApplyAll e xs) v)+++-- | Set the first value+toVariantFHead :: forall x xs e. x e -> VariantF (x ': xs) e+{-# INLINABLE toVariantFHead #-}+toVariantFHead v = VariantF (toVariantHead @(x e) @(ApplyAll e xs) v)++-- | Set the tail+toVariantFTail :: forall x xs e. VariantF xs e -> VariantF (x ': xs) e+{-# INLINABLE toVariantFTail #-}+toVariantFTail (VariantF v) = VariantF (toVariantTail @(x e) @(ApplyAll e xs) v)++-- | Pop VariantF head+popVariantFHead :: forall x xs e. VariantF (x ': xs) e -> Either (VariantF xs e) (x e)+{-# INLINABLE popVariantFHead #-}+popVariantFHead (VariantF v) = case popVariantHead v of+ Right x -> Right x+ Left xs -> Left (VariantF xs)++type PopVariantF x xs e =+ ( x e :< ApplyAll e xs+ , Remove (x e) (ApplyAll e xs) ~ ApplyAll e (Remove x xs)+ )++-- | Pop VariantF+popVariantF :: forall x xs e.+ ( PopVariantF x xs e+ ) => VariantF xs e -> Either (VariantF (Remove x xs) e) (x e)+{-# INLINABLE popVariantF #-}+popVariantF (VariantF v) = case popVariant v of+ Right x -> Right x+ Left xs -> Left (VariantF xs)++type MapVariantF a b cs ds e =+ ( MapVariant (a e) (b e) (ApplyAll e cs)+ , ds ~ ReplaceNS (IndexesOf a cs) b cs+ , ApplyAll e ds ~ ReplaceNS (IndexesOf (a e) (ApplyAll e cs)) (b e) (ApplyAll e cs)+ )++-- | Map the matching types of a variant+mapVariantF :: forall a b cs ds e.+ ( MapVariantF a b cs ds e+ ) => (a e -> b e) -> VariantF cs e -> VariantF ds e+mapVariantF f (VariantF v) = VariantF (mapVariant @(a e) @(b e) @(ApplyAll e cs) f v)++-- | xs is liftable in ys+type LiftVariantF xs ys e =+ ( LiftVariant (ApplyAll e xs) (ApplyAll e ys)+ )++-- | Lift a VariantF into another+liftVariantF :: forall as bs e.+ ( LiftVariantF as bs e+ ) => VariantF as e -> VariantF bs e+liftVariantF (VariantF v) = VariantF (liftVariant' v)++type SplitVariantF as xs e =+ ( Complement (ApplyAll e xs) (ApplyAll e as) ~ ApplyAll e (Complement xs as)+ , SplitVariant (ApplyAll e as) (ApplyAll e (Complement xs as)) (ApplyAll e xs)+ )++-- | Split a VariantF in two+splitVariantF :: forall as xs e.+ ( SplitVariantF as xs e+ ) => VariantF xs e+ -> Either (VariantF (Complement xs as) e) (VariantF as e)+splitVariantF (VariantF v) = bimap VariantF VariantF (splitVariant v)++-- | Convert a VariantF into a multi-continuation+variantFToCont :: ContVariant (ApplyAll e xs)+ => VariantF xs e -> ContFlow (ApplyAll e xs) r+variantFToCont (VariantF v) = variantToCont v++-- | Convert a VariantF into a multi-continuation+variantFToContM ::+ ( ContVariant (ApplyAll e xs)+ , Monad m+ ) => m (VariantF xs e) -> ContFlow (ApplyAll e xs) (m r)+variantFToContM f = variantToContM (unvariantF <$> f)+ where+ unvariantF (VariantF v) = v++-- | Convert a multi-continuation into a VariantF+contToVariantF :: forall xs e.+ ( ContVariant (ApplyAll e xs)+ ) => ContFlow (ApplyAll e xs) (V (ApplyAll e xs)) -> VariantF xs e+contToVariantF c = VariantF (contToVariant c)++-- | Convert a multi-continuation into a VariantF+contToVariantFM :: forall xs e m.+ ( ContVariant (ApplyAll e xs)+ , Monad m+ ) => ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs))) -> m (VariantF xs e)+contToVariantFM f = VariantF <$> contToVariantM f++instance ContVariant (ApplyAll e xs) => MultiCont (VariantF xs e) where+ type MultiContTypes (VariantF xs e) = ApplyAll e xs+ toCont = variantFToCont+ toContM = variantFToContM++deriving newtype instance (NFData (V (ApplyAll e xs))) => NFData (VariantF xs e)++----------------------------------------+-- BottomUp+----------------------------------------++type family BottomUpF c fs :: Constraint where+ BottomUpF c fs = (Functor (VariantF fs), BottomUp c fs)++class BottomUp c fs where+ toBottomUp :: (forall f. c f => f a -> b) -> (VariantF fs a -> b)++instance BottomUp c '[] where+ {-# INLINABLE toBottomUp #-}+ toBottomUp _f = undefined++instance forall c fs f.+ ( BottomUp c fs+ , c f+ ) => BottomUp c (f ':fs) where+ {-# INLINABLE toBottomUp #-}+ toBottomUp f v = case popVariantFHead v of+ Right x -> f x+ Left xs -> toBottomUp @c f xs++----------------------------------------+-- BottomUpOrig+----------------------------------------++type family BottomUpOrigF c fs :: Constraint where+ BottomUpOrigF c fs = (Functor (VariantF fs), BottomUpOrig c fs)++class BottomUpOrig c fs where+ toBottomUpOrig :: (forall f. c f => f (t,a) -> b) -> (VariantF fs (t,a) -> b)++instance BottomUpOrig c '[] where+ {-# INLINABLE toBottomUpOrig #-}+ toBottomUpOrig _f = undefined++instance forall c fs f.+ ( BottomUpOrig c fs+ , c f+ ) => BottomUpOrig c (f ': fs) where+ {-# INLINABLE toBottomUpOrig #-}+ toBottomUpOrig f v = case popVariantFHead v of+ Right x -> f x+ Left xs -> toBottomUpOrig @c f xs+++----------------------------------------+-- TopDownStop+----------------------------------------++type family TopDownStopF c fs :: Constraint where+ TopDownStopF c fs = (Functor (VariantF fs), TopDownStop c fs)++class TopDownStop c fs where+ toTopDownStop :: (forall f. c f => TopDownStopT a f) -> TopDownStopT a (VariantF fs)++instance TopDownStop c '[] where+ {-# INLINABLE toTopDownStop #-}+ toTopDownStop _f = undefined++instance forall c fs f.+ ( TopDownStop c fs+ , Functor f+ , c f+ ) => TopDownStop c (f ':fs) where+ {-# INLINABLE toTopDownStop #-}+ toTopDownStop f v = case popVariantFHead v of+ Right x -> first toVariantFHead (f x)+ Left xs -> first (prependVariantF @'[f]) (toTopDownStop @c f xs)
+ src/tests/EADT.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeOperators #-}++module EADT+ ( testsEADT+ )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Data.Variant.Functor+import Data.Variant.EADT+import Data.Variant.EADT.TH+import Data.Kind++-------------------------------+-- List EADT+-------------------------------++data ConsF a l = ConsF a l deriving (Eq,Ord,Show,Functor)+data NilF l = NilF deriving (Eq,Ord,Show,Functor)++eadtPattern 'ConsF "Cons"+eadtPattern 'NilF "Nil"+eadtInfixPattern 'ConsF ":->"++type ListF a = VariantF '[NilF, ConsF a]+type List a = EADT '[NilF, ConsF a]++instance Eq a => Eq1 (ConsF a) where+ liftEq cmp (ConsF a e1) (ConsF b e2) = a == b && cmp e1 e2++instance Eq1 NilF where+ liftEq _ _ _ = True++instance Ord a => Ord1 (ConsF a) where+ liftCompare cmp (ConsF a e1) (ConsF b e2) = compare a b <> cmp e1 e2++instance Ord1 NilF where+ liftCompare _ _ _ = EQ++instance Show a => Show1 (ConsF a) where+ liftShowsPrec shw _ p (ConsF a e) =+ showParen (p >= 10) (showString "ConsF " . showsPrec 10 a . showString " " . shw 10 e)++instance Show1 NilF where+ liftShowsPrec _ _ _ _ = showString "NilF"++-- example values:+list0 :: List String+list0 = Cons "Hello" $ Cons "World" Nil++-------------------------------+-- Show AlgebraC+-------------------------------++class MyShow (f :: Type -> Type) where+ myShow :: f String -> String++instance MyShow NilF where+ myShow _ = "[]"++instance Show a => MyShow (ConsF a) where+ myShow (ConsF a b) = show a ++ " : " ++ b++showBottomUp :: Show a => BottomUpT String (ListF a)+showBottomUp = toBottomUp @MyShow myShow++-------------------------------+-- numbersTo anamorphism+-------------------------------++numbersTo :: CoAlgebra (ListF String) Int+numbersTo 0 = FV (NilF :: NilF Int)+numbersTo n = FV (ConsF (show n) (n-1))++-------------------------------+-- numbersToMin5 apomorphism+-------------------------------++numbersToMin5 :: RCoAlgebra (ListF String) (List String) Int+numbersToMin5 0 = FV (NilF :: NilF (Either (List String) Int))+numbersToMin5 n+ | n > 5 = FV (ConsF (show n) (Right (n-1) :: Either (List String) Int))+ | otherwise = FV (ConsF "min" (Left (Nil :: List String) :: Either (List String) Int))++-------------------------------+-- Tests+-------------------------------++testsEADT :: TestTree+testsEADT = testGroup "EADT" $+ [ testProperty "eadtPattern: match" $+ case list0 of+ Cons (x :: String) _ -> x == "Hello"+ _ -> False++ , testProperty "eadtInfixPattern: match" $+ case list0 of+ (x :: String) :-> _ -> x == "Hello"+ _ -> False++ , testProperty "catamorphism: constraint" $+ cata showBottomUp list0 == "\"Hello\" : \"World\" : []"++ , testProperty "anamorphism: numbersTo" $+ ana numbersTo 5 == Cons "5" (Cons "4" (Cons "3" (Cons "2" (Cons "1" Nil))))++ , testProperty "apomorphism: numbersToMin5" $+ apo numbersToMin5 8 == Cons "8" (Cons "7" (Cons "6" (Cons "min" Nil)))+ ]
+ src/tests/Main.hs view
@@ -0,0 +1,10 @@+import Test.Tasty++import Variant+import EADT++main :: IO ()+main = defaultMain $ testGroup "utils-variant"+ [ testsVariant+ , testsEADT+ ]
+ src/tests/Variant.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Variant+ ( testsVariant+ )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Data.Either++import Data.Variant+import Data.Variant.ContFlow++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 = V '[A,B,C]+type DEF = V '[D,E,F]++b :: ABC+b = toVariantAt @1 B++b2d :: B -> D+b2d = const D++c2d :: C -> D+c2d = const D++b2def :: B -> DEF+b2def = const (toVariant E)++c2def :: C -> DEF+c2def = const (toVariant E)+++testsVariant :: TestTree+testsVariant = testGroup "Variant" $+ [ testProperty "get by index (match)" $ fromVariantAt @1 b == Just B+ , testProperty "get by index (dont' match)" $ fromVariantAt @0 b == Nothing+ , testProperty "pattern V: set" $ (V A :: ABC) == (toVariant A :: ABC)+ , testProperty "pattern V: match" $ case (V A :: ABC) of+ V (x :: A) -> x == A+ V (_ :: B) -> False+ V (_ :: C) -> False+ _ -> undefined+ , testProperty "pattern V: match2" $ case (V B :: ABC) of+ V (_ :: A) -> False+ V (x :: B) -> x == B+ V (_ :: C) -> False+ _ -> undefined+ , testProperty "pattern V: type application" $ (V @Float 1.0 :: V '[Int,Float,String]) == toVariantAt @1 1.0+ , testProperty "get by type (match)" $ fromVariant (V B :: ABC) == Just B+ , testProperty "get by type (don't match)" $ fromVariant @C (V B :: ABC) == Nothing+ , testProperty "variant equality (match)" $ b == b+ , testProperty "variant equality (don't match)" $ b /= V C+ , testProperty "update by index (match)" $ mapVariantAt @1 (const D) b == toVariantAt @1 D+ , testProperty "update by index (don't match)" $ mapVariantAt @0 (const F) b == toVariantAt @1 B+ , testProperty "update by type (match)" $ mapVariantFirst b2d b == toVariantAt @1 D+ , testProperty "update by type (don't match)" $ mapVariantFirst c2d b == V B+ , testProperty "update/fold by index (match)" $ foldMapVariantAt @1 b2def b == V E+ , testProperty "update/fold by index (don't match)"$ foldMapVariantAt @2 c2def b == V B+ , testProperty "Convert single variant" $ variantToValue (V A :: V '[A]) == A+ , testProperty "Lift Either: Left" $ variantFromEither (Left A :: Either A B) == V A+ , testProperty "Lift Either: Right" $ variantFromEither (Right B :: Either A B) == V B+ , testProperty "To Either: Left" $ variantToEither (V B :: V '[A,B]) == Left B+ , testProperty "To Either: Right" $ variantToEither (V A :: V '[A,B]) == Right A+ , testProperty "popVariantHead (match)" $ popVariantHead (V A :: ABC) == Right A+ , testProperty "popVariantHead (don't match)" $ isLeft (popVariantHead b)+ , testProperty "popVariantAt (match)" $ popVariantAt @1 b == Right B+ , testProperty "popVariantAt (don't match)" $ isLeft (popVariantAt @2 b)++ , testProperty "popVariant (match)" $ popVariant @D (toVariantAt @4 D :: V '[A,B,C,B,D,E,D]) == Right D+ , testProperty "popVariant (match)" $ popVariant @D (toVariantAt @6 D :: V '[A,B,C,B,D,E,D]) == Right D+ , testProperty "popVariant (don't match)" $ popVariant @B (toVariantAt @4 D :: V '[A,B,C,B,D,E,D]) == Left (toVariantAt @2 D)++ , testProperty "prependVariant" $ fromVariantAt @4 (prependVariant @'[D,E,F] b) == Just B+ , testProperty "appendVariant" $ fromVariantAt @1 (appendVariant @'[D,E,F] b) == Just B++ , testProperty "alterVariant" $ alterVariant @Num (+1) (V @Float 1.0 :: V '[Int,Float]) == V @Float 2.0+ , testProperty "alterVariant" $ alterVariant @Num (+1) (V @Float 1.0 :: V '[Float,Int]) == V @Float 2.0++ , testProperty "traverseVariant" $ traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing)+ (V @Float 2.0 :: V '[Float,Int]) == Just (V @Float 2.0)+ , testProperty "traverseVariant" $ traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing)+ (V @Float 0.5 :: V '[Float,Int]) == Nothing+ , testProperty "liftVariant" $ fromVariant (liftVariant b :: V '[D,A,E,B,F,C]) == Just B+ , testProperty "splitVariant" $ case splitVariant @'[A,C,D] (V A :: V '[A,B,C,D,E,F]) of+ Right (x :: V '[A,C,D]) -> x == V A+ Left (_ :: V '[B,E,F]) -> True+ , testProperty "splitVariant2" $ case splitVariant @'[A,C,D] (V E :: V '[A,B,C,D,E,F]) of+ Right (_ :: V '[A,C,D]) -> True+ Left (y :: V '[B,E,F]) -> y == V E+ , testProperty "toCont" $ (toCont (V E :: V '[A,B,C,D,E,F]) >::>+ ( \(_ :: A) -> False+ , \(_ :: B) -> False+ , \(_ :: C) -> False+ , \(_ :: D) -> False+ , \(_ :: E) -> True+ , \(_ :: F) -> False+ ))++ ]++class (Ord a, Num a) => OrdNum a+instance (Ord a, Num a) => OrdNum a
+ variant.cabal view
@@ -0,0 +1,88 @@+cabal-version: 2.4+name: variant+version: 1.0+synopsis: Variant and EADT+license: BSD-3-Clause+license-file: LICENSE+author: Sylvain Henry+maintainer: sylvain@haskus.fr+homepage: https://www.haskus.org+copyright: Sylvain Henry 2024+category: System+build-type: Simple++description:+ Variant (extensible sum type) and EADT (extensible recursive sum type)+ datatypes.++source-repository head+ type: git+ location: git://github.com/haskus/variant.git++flag unliftio+ Description: Enable MonadUnliftIO instance+ Manual: True+ Default: True++library+ exposed-modules:+ Data.Variant+ Data.Variant.ContFlow+ Data.Variant.VEither+ Data.Variant.Excepts+ Data.Variant.Syntax+ Data.Variant.Tuple+ Data.Variant.Types+ Data.Variant.VariantF+ Data.Variant.Functor+ Data.Variant.EADT+ Data.Variant.EADT.TH+ Data.Variant.EGADT++ other-modules:++ build-depends: + base >= 4.9 && < 5.0+ , transformers+ , deepseq+ , exceptions >= 0.9+ , template-haskell+ , mtl >= 2.2+ , recursion-schemes++ if flag(unliftio)+ build-depends: unliftio-core >= 0.2+ cpp-options: -DENABLE_UNLIFTIO++ 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: -Wall -threaded+ default-language: Haskell2010+ other-modules:+ Variant+ , EADT++ build-depends:+ base >= 4.9 && < 5.0+ , tasty >= 0.11+ , tasty-quickcheck >= 0.8+ , variant++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: src/bench+ ghc-options: -Wall -threaded+ default-language: Haskell2010+ build-depends:+ base >= 4.9 && < 5.0+ , variant+ , criterion+ , QuickCheck+ , deepseq