diff --git a/haskus-utils-variant.cabal b/haskus-utils-variant.cabal --- a/haskus-utils-variant.cabal +++ b/haskus-utils-variant.cabal @@ -1,5 +1,5 @@ name: haskus-utils-variant -version: 2.4 +version: 2.5 synopsis: Variant and EADT license: BSD3 license-file: LICENSE @@ -36,6 +36,8 @@ build-depends: base >= 4.9 && < 5.0 , transformers + , deepseq + , exceptions >= 0.9 , template-haskell , haskus-utils-types >= 1.3 , haskus-utils-data @@ -55,8 +57,22 @@ Variant , EADT - build-depends: + build-depends: base , haskus-utils-variant , tasty >= 0.11 , tasty-quickcheck >= 0.8 + , doctest >= 0.16 + +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 + , haskus-utils-variant + , criterion + , QuickCheck + , deepseq 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,142 @@ +{-# 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 Haskus.Utils.Variant +import Haskus.Utils.EADT +import Haskus.Utils.EADT.TH +import Haskus.Utils.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))) + +------------------------------------------ +-- EADT +------------------------------------------ + +data PlusF e = PlusF e e deriving (Generic,NFData) +data MinusF e = MinusF e e deriving (Generic,NFData) +newtype ValueF a e = ValueF a deriving newtype (NFData) + +eadtPattern 'PlusF "EPlus" +eadtPattern 'MinusF "EMinus" +eadtPattern 'ValueF "EValue" + +type EADTNode a = EADT '[ValueF a, PlusF, MinusF] + +nodeToEADTNode :: Node a -> EADTNode a +nodeToEADTNode !(NValue a) = EValue a +nodeToEADTNode !(NPlus a b) = EPlus (nodeToEADTNode a) (nodeToEADTNode b) +nodeToEADTNode !(NMinus a b) = EMinus (nodeToEADTNode a) (nodeToEADTNode b) + +evalEADTNode :: Num a => EADTNode a -> a +evalEADTNode (EValue v) = v +evalEADTNode (EPlus a b) = evalEADTNode a + evalEADTNode b +evalEADTNode (EMinus a b) = evalEADTNode a - evalEADTNode b +evalEADTNode _ = undefined + +evalEADTNodeSafe :: forall a. Num a => EADTNode a -> a +evalEADTNodeSafe v = eadtToCont v >::> + ( \(ValueF x) -> x + , \(PlusF a b) -> evalEADTNodeSafe a + evalEADTNodeSafe b + , \(MinusF a b) -> evalEADTNodeSafe a - evalEADTNodeSafe b + ) + + + + +main :: IO () +main = do + let + evalEnv n = do + !tree1 <- generate (resize n (arbitrary :: Gen (Node Int))) + let !tree2 = nodeToVariantNode tree1 + let !tree3 = nodeToEADTNode tree1 + return (n,tree1,tree2,tree3) + + evalTest ~(n,tree1,tree2,tree3) = 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 + , bench "EADT - Patterns" $ whnf evalEADTNode tree3 + , bench "EADT - Safe match" $ whnf evalEADTNodeSafe tree3 + ] + + + defaultMain + [ env (evalEnv 10) evalTest + ] + + + + diff --git a/src/lib/Haskus/Utils/EADT.hs b/src/lib/Haskus/Utils/EADT.hs --- a/src/lib/Haskus/Utils/EADT.hs +++ b/src/lib/Haskus/Utils/EADT.hs @@ -11,6 +11,9 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Extensible ADT module Haskus.Utils.EADT @@ -43,10 +46,16 @@ import Haskus.Utils.ContFlow import GHC.Exts (Constraint) +import Control.DeepSeq -- | An extensible ADT type EADT xs = Fix (VariantF xs) +-- TODO: GHC 8.6 +-- Replace EADT with a newtype isomorphic to Fix. +-- Use "DerivingVia" to derive instances from "Fix" +deriving newtype instance NFData (VariantF xs (EADT xs)) => NFData (EADT xs) + -- | Constructor `f` is in `xs` type family f :<: xs where f :<: xs = EADTF' f (EADT xs) xs @@ -105,13 +114,13 @@ ) => (forall f. c f => f (EADT xs) -> f (EADT xs)) -> EADT xs -> EADT xs alterEADT f (Fix v) = Fix (alterVariantF @c @(EADT xs) f v) -type AlgEADT c xs = AlgVariantF c (EADT xs) xs +type AlgEADT c r xs = AlgVariantF c (EADT xs) r xs -- | Apply an algebra to an EADT value -algEADT :: forall c xs. - ( AlgEADT c xs - ) => (forall f. c f => f (EADT xs) -> EADT xs) -> EADT xs -> EADT xs -algEADT f (Fix v) = algVariantF @c @(EADT xs) f v +algEADT :: forall c r xs. + ( AlgEADT c r xs + ) => (forall f. c f => f (EADT xs) -> r) -> EADT xs -> r +algEADT f (Fix v) = algVariantF @c @(EADT xs) @r f v -- | Convert an EADT into a multi-continuation eadtToCont :: diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs --- a/src/lib/Haskus/Utils/Variant.hs +++ b/src/lib/Haskus/Utils/Variant.hs @@ -31,6 +31,7 @@ , toVariantHead , toVariantTail , fromVariantAt + , fromVariantHead , popVariantAt , popVariantHead , mapVariantAt @@ -43,8 +44,6 @@ , mapVariantHeadTail -- * Operations by type , toVariant - , Member - , Remove , popVariant , popVariantMaybe , fromVariant @@ -52,37 +51,39 @@ , fromVariantFirst , mapVariantFirst , mapVariantFirstM - , ReplaceAll - , MapVariant , mapVariant , mapNubVariant , foldMapVariantFirst , foldMapVariantFirstM , foldMapVariant + , Member + , Remove + , ReplaceAll + , MapVariant -- * Generic operations with type classes - , NoConstraint - , AlterVariant , alterVariant - , TraverseVariant , traverseVariant , traverseVariant_ - , ReduceVariant , reduceVariant + , NoConstraint + , AlterVariant + , TraverseVariant + , ReduceVariant -- * Conversions between variants , appendVariant , prependVariant - , LiftVariant , liftVariant , nubVariant , productVariant - , Flattenable - , FlattenVariant , flattenVariant - , ExtractM , joinVariant , joinVariantUnsafe - , JoinVariant , splitVariant + , LiftVariant + , Flattenable + , FlattenVariant + , ExtractM + , JoinVariant , SplitVariant -- * Conversions to/from other data types , variantToValue @@ -95,11 +96,11 @@ , ContVariant (..) -- ** Internals , pattern VSilent - , LiftVariant' , liftVariant' , fromVariant' , popVariant' , toVariant' + , LiftVariant' , PopVariant ) where @@ -107,6 +108,7 @@ import Unsafe.Coerce import GHC.Exts (Any,Constraint) import Data.Typeable +import Control.DeepSeq import Haskus.Utils.Monad import Haskus.Utils.Types @@ -115,6 +117,13 @@ import Haskus.Utils.ContFlow import Haskus.Utils.Types.List +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts +-- >>> :set -XTypeFamilies + + -- | A variant contains a value whose type is at the given position in the type -- list data V (l :: [*]) = Variant {-# UNPACK #-} !Word Any @@ -180,32 +189,86 @@ (Right _, Left _) -> LT (Left _, Right _) -> GT -instance Show (V '[]) where - show _ = "V '[]" +class ShowVariantValue a where + showVariantValue :: a -> ShowS +instance ShowVariantValue (V '[]) where + {-# INLINE showVariantValue #-} + showVariantValue _ = showString "undefined" + instance - ( Show (V xs) + ( ShowVariantValue (V xs) , Show x , Typeable x - ) => Show (V (x ': xs)) + ) => ShowVariantValue (V (x ': xs)) where - show v = case popVariantHead v of - Right x -> let parens s - | ' ' `elem` s = "(" ++ s ++ ")" - | otherwise = s - -- naive parenthesing but it works - in "V @" ++ parens (show (typeOf x)) ++ " " ++ parens (show x) - Left xs -> show xs + {-# INLINE showVariantValue #-} + showVariantValue v = case popVariantHead v of + Right x -> showString "V @" + . showsPrec 10 (typeOf x) + . showChar ' ' + . showsPrec 11 x + Left xs -> showVariantValue xs +instance + ( Show (V xs) + , Typeable xs + , ShowTypeList (V xs) + , ShowVariantValue (V xs) + ) => Show (V xs) + where + showsPrec d v = showParen (d /= 0) $ + showVariantValue v + . showString " :: " + -- disabled until GHC fixes #14341 + -- . showsPrec 0 (typeOf v) + -- workaround: + . showString "V " + . showList__ (showTypeList v) + +-- | 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 + {-# INLINE showTypeList #-} + showTypeList _ = [] + +instance (Typeable x, ShowTypeList (V xs)) => ShowTypeList (V (x ': xs)) where + {-# INLINE showTypeList #-} + showTypeList _ = showsPrec 0 (typeOf (undefined :: x)) : showTypeList (undefined :: V xs) + ----------------------------------------------------------- -- Operations by index ----------------------------------------------------------- -- | 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 -- | Set the value with the given indexed type +-- +-- >>> toVariantAt @1 10 :: V '[Word,Int,Double] +-- V @Int 10 :: V '[Word, Int, Double] +-- toVariantAt :: forall (n :: Nat) (l :: [*]). ( KnownNat n ) => Index n l -> V l @@ -213,16 +276,35 @@ toVariantAt a = Variant (natValue' @n) (unsafeCoerce a) -- | Set the first value +-- +-- >>> toVariantHead 10 :: V '[Int,Float,Word] +-- V @Int 10 :: V '[Int, Float, Word] +-- 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 +-- >>> y +-- V @Int 10 :: V '[Double, Int, [Char], Float] +-- toVariantTail :: forall x xs. V xs -> V (x ': xs) {-# INLINABLE toVariantTail #-} toVariantTail (Variant t a) = Variant (t+1) a --- | Get the value if it has the indexed type +-- | 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 :: [*]). ( KnownNat n ) => V l -> Maybe (Index n l) @@ -231,8 +313,30 @@ 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 (V @Word 10 :: V '[Word, Float]) +-- >>> popVariantAt @1 x +-- Right 10 +-- >>> popVariantAt @2 x +-- Left (V @Word 10 :: V '[Int, Word]) +-- popVariantAt :: forall (n :: Nat) l. ( KnownNat n ) => V l -> Either (V (RemoveAt n l)) (Index n l) @@ -244,6 +348,15 @@ else Variant t a -- | Pop the head of a variant value +-- +-- >>> let x = V @Word 10 :: V '[Int,Word,Float] +-- >>> popVariantHead x +-- Left (V @Word 10 :: V '[Word, Float]) +-- +-- >>> 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 @@ -251,6 +364,14 @@ 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 +-- V @[Char] "TEST" :: V '[Int, [Char], Float] +-- +-- >>> mapVariantAt @0 (+1) x +-- V @[Char] "Test" :: V '[Int, [Char], Float] mapVariantAt :: forall (n :: Nat) a b l. ( KnownNat n , a ~ Index n l @@ -262,6 +383,30 @@ 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 (V @Word 42 :: V '[Int, Word, Float]) +-- +-- >>> let y = V @String "NotTest" :: V '[Int,String,Float] +-- >>> mapVariantAtM @1 f y +-- Nothing +-- +-- Example with `IO`: +-- +-- >>> mapVariantAtM @0 print x +-- V @[Char] "Test" :: V '[(), [Char], Float] +-- +-- >>> mapVariantAtM @1 print x +-- "Test" +-- V @() () :: V '[Int, (), Float] +-- +-- >>> mapVariantAtM @2 print x +-- V @[Char] "Test" :: V '[Int, [Char], ()] +-- mapVariantAtM :: forall (n :: Nat) a b l m . ( KnownNat n , Applicative m @@ -291,6 +436,14 @@ -- | 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 @@ -298,6 +451,14 @@ Left t -> ft t -- | Bimap Variant head and tail +-- +-- >>> let f = mapVariantHeadTail (+5) (appendVariant @'[Double,Char]) +-- >>> f (V @Int 10 :: V '[Int,Word,Float]) +-- V @Int 15 :: V '[Int, Word, Float, Double, Char] +-- +-- >>> f (V @Word 20 :: V '[Int,Word,Float]) +-- V @Word 20 :: V '[Int, Word, Float, Double, Char] +-- mapVariantHeadTail :: (x -> y) -> (V xs -> V ys) -> V (x ': xs) -> V (y ': ys) {-# INLINABLE mapVariantHeadTail #-} mapVariantHeadTail fh ft x = case popVariantHead x of @@ -418,7 +579,10 @@ -- | Pick the first matching type of a Variant -- --- fromVariantFirst @A (Variant 2 undefined :: V '[A,B,A]) == Nothing +-- >>> let x = toVariantAt @2 10 :: V '[Int,String,Int] +-- >>> fromVariantFirst @Int x +-- Nothing +-- fromVariantFirst :: forall a l. ( Member a l ) => V l -> Maybe a @@ -426,6 +590,18 @@ 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' is not a member of '[Int, String, Int] +-- ... +-- fromVariant :: forall a xs. ( a :< xs ) => V xs -> Maybe a @@ -445,6 +621,13 @@ -- | 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 @@ -453,7 +636,16 @@ Right a -> Just a Left _ -> Nothing --- | Update of the first matching variant value +-- | Update the first matching variant value +-- +-- >>> let x = toVariantAt @0 10 :: V '[Int,String,Int] +-- >>> mapVariantFirst @Int (+32) x +-- V @Int 42 :: V '[Int, [Char], Int] +-- +-- >>> let y = toVariantAt @2 10 :: V '[Int,String,Int] +-- >>> mapVariantFirst @Int (+32) y +-- V @Int 10 :: V '[Int, [Char], Int] +-- mapVariantFirst :: forall a b n l. ( Member a l , n ~ IndexOf a l @@ -462,6 +654,31 @@ 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 (V @[Char] "Yeah!" :: V '[[Char], Float, Int]) +-- +-- >>> mapVariantFirstM f (toVariantAt @2 42 :: V '[Int,Float,Int]) +-- Just (V @Int 42 :: V '[[Char], Float, Int]) +-- +-- >>> mapVariantFirstM f (toVariantAt @0 10 :: V '[Int,Float,Int]) +-- Nothing +-- +-- >>> mapVariantFirstM f (toVariantAt @2 10 :: V '[Int,Float,Int]) +-- Just (V @Int 10 :: V '[[Char], Float, Int]) +-- +-- Example with `IO`: +-- +-- >>> mapVariantFirstM @Int print (toVariantAt @0 42 :: V '[Int,Float,Int]) +-- 42 +-- V @() () :: V '[(), Float, Int] +-- +-- >>> mapVariantFirstM @Int print (toVariantAt @2 42 :: V '[Int,Float,Int]) +-- V @Int 42 :: V '[(), Float, Int] +-- mapVariantFirstM :: forall a b n l m. ( Member a l , n ~ IndexOf a l @@ -497,6 +714,14 @@ -- | Map the matching types of a variant +-- +-- >>> let add1 = mapVariant @Int (+1) +-- >>> add1 (toVariantAt @0 10 :: V '[Int,Float,Int,Double]) +-- V @Int 11 :: V '[Int, Float, Int, Double] +-- +-- >>> add1 (toVariantAt @2 10 :: V '[Int,Float,Int, Double]) +-- V @Int 11 :: V '[Int, Float, Int, Double] +-- mapVariant :: forall a b cs. ( MapVariant a b cs ) => (a -> b) -> V cs -> V (ReplaceAll a b cs) @@ -504,6 +729,14 @@ 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]) +-- V @Int 11 :: V '[Int, Float, Double] +-- +-- >>> add1 (toVariantAt @2 10 :: V '[Int,Float,Int, Double]) +-- V @Int 11 :: V '[Int, Float, Double] +-- mapNubVariant :: forall a b cs ds rs. ( MapVariant a b cs , ds ~ ReplaceNS (IndexesOf a cs) b cs @@ -515,6 +748,16 @@ -- | 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]) +-- V @Even (Even 10) :: V '[Float, Odd, Even, Double] +-- +-- >>> foldMapVariantAt @1 f (V @Float 0.5 :: V '[Float,Int,Double]) +-- V @Float 0.5 :: V '[Float, Odd, Even, Double] +-- foldMapVariantAt :: forall (n :: Nat) l l2 . ( KnownNat n , KnownNat (Length l2) @@ -577,6 +820,16 @@ -- | 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]) +-- V @Even (Even 10) :: V '[Float, Odd, Even, Double] +-- +-- >>> foldMapVariant @Int f (V @Float 0.5 :: V '[Float,Int,Double]) +-- V @Float 0.5 :: V '[Float, Odd, Even, Double] +-- foldMapVariant :: forall a cs ds i. ( i ~ IndexOf a cs , a :< cs @@ -848,6 +1101,17 @@ {-# INLINABLE joinVariantUnsafe #-} joinVariantUnsafe (Variant t act) = Variant t <$> (unsafeCoerce act :: m Any) + + +instance NFData (V '[]) where + {-# INLINE rnf #-} + rnf _ = () + +instance (NFData x, NFData (V xs)) => NFData (V (x ': xs)) where + {-# INLINE rnf #-} + rnf v = case popVariantHead v of + Right x -> rnf x + Left xs -> rnf xs ----------------------------------------------------------- diff --git a/src/lib/Haskus/Utils/Variant/Flow.hs b/src/lib/Haskus/Utils/Variant/Flow.hs --- a/src/lib/Haskus/Utils/Variant/Flow.hs +++ b/src/lib/Haskus/Utils/Variant/Flow.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} @@ -13,22 +14,36 @@ -- * FlowT , FlowT , runFlowT + , runFlowT_ + , evalFlowT + , evalCatchFlowT + , injectFlowT , mapFlowT , liftFlowT + , variantToFlowT , success + , failure , throwE , catchE + , catchLiftBoth + , catchLiftLeft + , catchLiftRight + , catchAllE + , catchDie + , catchRemove + , onFlowError_ + , onFlowError + , finallyFlow -- * Reexport , module Haskus.Utils.Variant ) where +import Haskus.Utils.Monad import Haskus.Utils.Variant import Data.Functor.Identity -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad +import Control.Monad.Catch ------------------------------------------------------------------------------ -- Flow @@ -50,6 +65,19 @@ {-# INLINE runFlowT #-} runFlowT (FlowT m) = m +runFlowT_ :: Functor m => FlowT es m a -> m () +{-# INLINE runFlowT_ #-} +runFlowT_ m = void (runFlowT m) + +injectFlowT :: Monad m => FlowT es m a -> FlowT es m (V (a ': es)) +{-# INLINE injectFlowT #-} +injectFlowT (FlowT m) = return =<< lift m + +-- | Convert a flow without error into a value +evalFlowT :: Monad m => FlowT '[] m a -> m a +{-# INLINE evalFlowT #-} +evalFlowT v = variantToValue <$> runFlowT v + mapFlowT :: (m (V (a ': es)) -> n (V (b ': es'))) -> FlowT es m a -> FlowT es' n b {-# INLINE mapFlowT #-} mapFlowT f m = FlowT $ f (runFlowT m) @@ -112,6 +140,47 @@ liftIO = lift . liftIO +-- | Throws exceptions into the base monad. +instance MonadThrow m => MonadThrow (FlowT e m) where + {-# INLINE throwM #-} + throwM = lift . throwM + +-- | Catches exceptions from the base monad. +instance MonadCatch m => MonadCatch (FlowT e m) where + catch (FlowT m) f = FlowT $ catch m (runFlowT . f) + +instance MonadMask m => MonadMask (FlowT e m) where + mask f = FlowT $ mask $ \u -> runFlowT $ f (q u) + where + q :: (m (V (a ': e)) -> m (V (a ': e))) -> FlowT e m a -> FlowT e m a + q u (FlowT b) = FlowT (u b) + + uninterruptibleMask f = FlowT $ uninterruptibleMask $ \u -> runFlowT $ f (q u) + where + q :: (m (V (a ': e)) -> m (V (a ': e))) -> FlowT e m a -> FlowT e m a + q u (FlowT b) = FlowT (u b) + + generalBracket acquire release use = FlowT $ do + (eb, ec) <- generalBracket + (runFlowT acquire) + (\eresource exitCase -> case popVariantHead eresource of + Left e -> return (toVariantTail e) -- nothing to release, acquire didn't succeed + Right resource -> case exitCase of + ExitCaseSuccess v + | Just b <- fromVariantAt @0 v -> runFlowT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runFlowT (release resource (ExitCaseException e)) + _ -> runFlowT (release resource ExitCaseAbort)) + (variantHeadTail (runFlowT . use) (return . toVariantTail)) + return $ runFlow $ do + -- The order in which we perform those two 'FlowT' effects determines + -- which error will win if they are both erroring. We want the error from + -- 'release' to win. + c <- FlowT (return ec) + b <- FlowT (return eb) + return (b, c) + + + -- | Success value success :: Monad m => a -> FlowT '[] m a success = pure @@ -121,7 +190,13 @@ {-# INLINE throwE #-} throwE = FlowT . return . toVariantTail . V --- | Handle an exception. +-- | Signal an exception value @e@. +failure :: Monad m => e -> FlowT '[e] m a +{-# INLINE failure #-} +failure = throwE + +-- | 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 @@ -130,10 +205,136 @@ ) => FlowT es m a -> (e -> FlowT es'' m a) -> FlowT es' m a {-# INLINE catchE #-} -m `catchE` h = FlowT $ do +m `catchE` h = m `catchLiftBoth` h + +-- | 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' + ) => + FlowT es m a -> (e -> FlowT es'' m a) -> FlowT es' m a +{-# INLINE catchLiftBoth #-} +m `catchLiftBoth` h = FlowT $ do a <- runFlowT m case popVariantHead a of Right r -> return (toVariantHead r) Left ls -> case popVariant ls of Right l -> runFlowT (liftFlowT (h l)) Left rs -> return (toVariantTail (liftVariant rs)) + +-- | Handle an exception. Assume it is in the first position +catchRemove :: forall e es a m. + ( Monad m + ) => + FlowT (e ': es) m a -> (e -> FlowT es m a) -> FlowT es m a +{-# INLINE catchRemove #-} +m `catchRemove` h = FlowT $ do + a <- runFlowT m + case popVariantHead a of + Right r -> return (toVariantHead r) + Left ls -> case popVariantHead ls of + Right l -> runFlowT (h l) + Left rs -> return (toVariantTail 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' + ) => + FlowT es m a -> (e -> FlowT es' m a) -> FlowT es' m a +{-# INLINE catchLiftLeft #-} +m `catchLiftLeft` h = FlowT $ do + a <- runFlowT m + case popVariantHead a of + Right r -> return (toVariantHead r) + Left ls -> case popVariant ls of + Right l -> runFlowT (h l) + Left rs -> return (toVariantTail (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) + ) => + FlowT es m a -> (e -> FlowT es' m a) -> FlowT (Remove e es) m a +{-# INLINE catchLiftRight #-} +m `catchLiftRight` h = FlowT $ do + a <- runFlowT m + case popVariantHead a of + Right r -> return (toVariantHead r) + Left ls -> case popVariant ls of + Right l -> runFlowT (liftFlowT (h l)) + Left rs -> return (toVariantTail rs) + +-- | Do something in case of error +catchAllE :: Monad m => FlowT es m a -> (V es -> FlowT es' m a) -> FlowT es' m a +{-# INLINE catchAllE #-} +m `catchAllE` h = FlowT $ do + a <- runFlowT m + case popVariantAt @0 a of + Right x -> return (toVariantHead x) + Left xs -> runFlowT (h xs) + +-- | Evaluate a FlowT. Use the provided function to handle error cases. +evalCatchFlowT :: Monad m => (V es -> m a) -> FlowT es m a -> m a +{-# INLINE evalCatchFlowT #-} +evalCatchFlowT h m = do + a <- runFlowT m + case popVariantAt @0 a of + Right x -> return x + Left xs -> h xs + +-- | Catch and die in case of error +catchDie :: (e :< es, Monad m) => FlowT es m a -> (e -> m ()) -> FlowT (Remove e es) m a +{-# INLINE catchDie #-} +m `catchDie` h = FlowT $ do + a <- runFlowT m + case popVariantHead a of + Right r -> return (toVariantHead r) + Left ls -> case popVariant ls of + Right l -> h l >> error "catchDie" + Left rs -> return (toVariantTail rs) + +-- | Do something in case of error +onFlowError_ :: Monad m => FlowT es m a -> m () -> FlowT es m a +{-# INLINE onFlowError_ #-} +m `onFlowError_` h = FlowT $ do + a <- runFlowT m + case fromVariantHead a of + Just _ -> return a + Nothing -> h >> return a + +-- | Do something in case of error +onFlowError :: Monad m => FlowT es m a -> (V es -> m ()) -> FlowT es m a +{-# INLINE onFlowError #-} +m `onFlowError` h = FlowT $ do + a <- runFlowT m + case popVariantHead a of + Right _ -> return a + Left es -> h es >> return a + +-- | Finally for FlowT +finallyFlow :: Monad m => FlowT es m a -> m () -> FlowT es m a +{-# INLINE finallyFlow #-} +m `finallyFlow` h = FlowT $ do + a <- runFlowT m + h + return a + +-- | Convert a Variant into a FlowT +variantToFlowT :: Monad m => V (a ': es) -> FlowT es m a +variantToFlowT v = FlowT (return v) + +instance MonadInIO m => MonadInIO (FlowT es m) where + {-# INLINE liftWith #-} + liftWith wth f = + FlowT $ liftWith wth (\a -> runFlowT (f a)) + + {-# INLINE liftWith2 #-} + liftWith2 wth f = + FlowT $ liftWith2 wth (\a b -> runFlowT (f a b)) diff --git a/src/lib/Haskus/Utils/VariantF.hs b/src/lib/Haskus/Utils/VariantF.hs --- a/src/lib/Haskus/Utils/VariantF.hs +++ b/src/lib/Haskus/Utils/VariantF.hs @@ -13,6 +13,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} -- | VariantF functor module Haskus.Utils.VariantF @@ -54,6 +57,7 @@ import Unsafe.Coerce import Data.Bifunctor import GHC.Exts (Any,Constraint) +import Control.DeepSeq -- | Recursive Functor-like Variant newtype VariantF (xs :: [* -> *]) e @@ -63,7 +67,7 @@ -- -- > ApplyAll e '[f,g,h] ==> '[f e, g e, h e] -- -type family ApplyAll e (xs :: [* -> *]) :: [*] where +type family ApplyAll e (xs :: [* -> k]) :: [k] where ApplyAll e '[] = '[] ApplyAll e (f ': fs) = f e ': ApplyAll e fs @@ -186,23 +190,23 @@ VariantF (Variant t (alterVariantF' @c @e @xs f t a)) -class AlgVariantF (c :: (* -> *) -> Constraint) e (xs :: [* -> *]) where - algVariantF' :: (forall (f :: * -> *). c f => f e -> e) -> Word -> Any -> e +class AlgVariantF (c :: (* -> *) -> Constraint) e r (xs :: [* -> *]) where + algVariantF' :: (forall (f :: * -> *). c f => f e -> r) -> Word -> Any -> r -instance AlgVariantF c e '[] where +instance AlgVariantF c e r '[] where {-# INLINE algVariantF' #-} algVariantF' _ = undefined instance - ( AlgVariantF c e xs + ( AlgVariantF c e r xs , c x - ) => AlgVariantF c e (x ': xs) + ) => AlgVariantF c e r (x ': xs) where {-# INLINE algVariantF' #-} algVariantF' f t v = case t of 0 -> f (unsafeCoerce v :: x e) - n -> algVariantF' @c @e @xs f (n-1) v + n -> algVariantF' @c @e @r @xs f (n-1) v -- | Apply an algebra to a VariantF. You need to specify the constraints -- required by the modifying function. @@ -212,11 +216,11 @@ -- > algVariantF @NoConstraint id v -- > algVariantF @Resizable (resize 4) v -- -algVariantF :: forall c e (xs :: [* -> *]). - ( AlgVariantF c e xs - ) => (forall (f :: * -> *). c f => f e -> e) -> VariantF xs e -> e +algVariantF :: forall c e r (xs :: [* -> *]). + ( AlgVariantF c e r xs + ) => (forall (f :: * -> *). c f => f e -> r) -> VariantF xs e -> r {-# INLINABLE algVariantF #-} -algVariantF f (VariantF (Variant t a)) = algVariantF' @c @e @xs f t a +algVariantF f (VariantF (Variant t a)) = algVariantF' @c @e @r @xs f t a type SplitVariantF as xs e = ( Complement (ApplyAll e xs) (ApplyAll e as) ~ ApplyAll e (Complement xs as) @@ -261,3 +265,5 @@ type MultiContTypes (VariantF xs e) = ApplyAll e xs toCont = variantFToCont toContM = variantFToContM + +deriving newtype instance (NFData (V (ApplyAll e xs))) => NFData (VariantF xs e) diff --git a/src/tests/Main.hs b/src/tests/Main.hs --- a/src/tests/Main.hs +++ b/src/tests/Main.hs @@ -1,10 +1,38 @@ +{-# LANGUAGE LambdaCase #-} import Test.Tasty +import Test.DocTest +import Control.Exception +import System.Exit + import Variant import EADT main :: IO () -main = defaultMain $ testGroup "utils-variant" +main = wrapTests + [ title "TASTY" $ defaultMain tastyTests + , title "DOCTEST" $ doctest ["src/lib/"] + ] + +title :: String -> IO () -> IO () +title s m = do + putStrLn "" + putStrLn (replicate 30 '=') + putStrLn s + putStrLn (replicate 30 '=') + m + +wrap :: IO () -> IO Bool +wrap m = (m >> return True) `catch` (\e -> return (e == ExitSuccess)) + +wrapTests :: [IO ()] -> IO () +wrapTests ts = (and <$> traverse wrap ts) >>= \case + True -> title "SUMMARY" exitSuccess + False -> title "SUMMARY" exitFailure + +tastyTests :: TestTree +tastyTests = testGroup "utils-variant" [ testsVariant , testsEADT ] +