haskus-utils-variant 2.4 → 2.5

raw patch · 7 files changed

+718/−52 lines, 7 filesdep +QuickCheckdep +criteriondep +deepseqdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, criterion, deepseq, doctest, exceptions

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• haskus-utils-variant.cabal +18/−2
• src/bench/Main.hs +142/−0
• src/lib/Haskus/Utils/EADT.hs +14/−5
• src/lib/Haskus/Utils/Variant.hs +292/−28
• src/lib/Haskus/Utils/Variant/Flow.hs +206/−5
• src/lib/Haskus/Utils/VariantF.hs +17/−11
• src/tests/Main.hs +29/−1

@@ -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

@@ -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+      ]++++

@@ -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 ::

@@ -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+-- <BLANKLINE>+-- ... 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 :<? xs    ) => 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   -----------------------------------------------------------

@@ -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))

@@ -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)

@@ -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    ]+