diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2013-2017, Haskus organization +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of Sylvain Henry nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/bench/Main.hs b/src/bench/Main.hs new file mode 100644 --- /dev/null +++ b/src/bench/Main.hs @@ -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 + ] + + + + diff --git a/src/lib/Data/Variant.hs b/src/lib/Data/Variant.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant.hs @@ -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 + , (:<) + , (:<<) + , (:>> :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 : 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 : 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 : 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 : 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 + ) diff --git a/src/lib/Data/Variant/ContFlow.hs b/src/lib/Data/Variant/ContFlow.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/ContFlow.hs @@ -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 >:%:> diff --git a/src/lib/Data/Variant/EADT.hs b/src/lib/Data/Variant/EADT.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/EADT.hs @@ -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') diff --git a/src/lib/Data/Variant/EADT/TH.hs b/src/lib/Data/Variant/EADT/TH.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/EADT/TH.hs @@ -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" diff --git a/src/lib/Data/Variant/EGADT.hs b/src/lib/Data/Variant/EGADT.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/EGADT.hs @@ -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 : 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)) diff --git a/src/lib/Data/Variant/Excepts.hs b/src/lib/Data/Variant/Excepts.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/Excepts.hs @@ -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 diff --git a/src/lib/Data/Variant/Functor.hs b/src/lib/Data/Variant/Functor.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/Functor.hs @@ -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 diff --git a/src/lib/Data/Variant/Syntax.hs b/src/lib/Data/Variant/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/Syntax.hs @@ -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 diff --git a/src/lib/Data/Variant/Tuple.hs b/src/lib/Data/Variant/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/Tuple.hs @@ -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 #) diff --git a/src/lib/Data/Variant/Types.hs b/src/lib/Data/Variant/Types.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/Types.hs @@ -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) diff --git a/src/lib/Data/Variant/VEither.hs b/src/lib/Data/Variant/VEither.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/VEither.hs @@ -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) diff --git a/src/lib/Data/Variant/VariantF.hs b/src/lib/Data/Variant/VariantF.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Variant/VariantF.hs @@ -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) diff --git a/src/tests/EADT.hs b/src/tests/EADT.hs new file mode 100644 --- /dev/null +++ b/src/tests/EADT.hs @@ -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))) + ] diff --git a/src/tests/Main.hs b/src/tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/tests/Main.hs @@ -0,0 +1,10 @@ +import Test.Tasty + +import Variant +import EADT + +main :: IO () +main = defaultMain $ testGroup "utils-variant" + [ testsVariant + , testsEADT + ] diff --git a/src/tests/Variant.hs b/src/tests/Variant.hs new file mode 100644 --- /dev/null +++ b/src/tests/Variant.hs @@ -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 diff --git a/variant.cabal b/variant.cabal new file mode 100644 --- /dev/null +++ b/variant.cabal @@ -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