version 2.32.3

10 files changed, 172 insertions, 65 deletions

diff --git a/haskus-utils-variant.cabal b/haskus-utils-variant.cabal
index 7c14ac1..eeaa3f8 100644
--- a/haskus-utils-variant.cabal
+++ b/haskus-utils-variant.cabal
@@ -1,52 +1,60 @@
-cabal-version: 1.20
-name: haskus-utils-variant
-version: 2.2
-license: BSD3
-license-file: LICENSE
-copyright: Sylvain Henry 2018
-maintainer: sylvain@haskus.fr
-author: Sylvain Henry
-homepage: http://www.haskus.org
-synopsis: Variant and EADT
+name:                haskus-utils-variant
+version:             2.3
+synopsis:            Variant and EADT
+license:             BSD3
+license-file:        LICENSE
+author:              Sylvain Henry
+maintainer:          sylvain@haskus.fr
+homepage:            http://www.haskus.org
+copyright:           Sylvain Henry 2018
+category:            System
+build-type:          Simple
+cabal-version:       1.20
+
 description:
-    Variant (extensible sum type) and EADT (extensible recursive sum type)
-    datatypes. Documentation can be found at https://docs.haskus.org
-category: System
-build-type: Simple
+   Variant (extensible sum type) and EADT (extensible recursive sum type)
+   datatypes. Documentation can be found at https://docs.haskus.org
 
 source-repository head
-    type: git
-    location: git://github.com/haskus/haskus-utils.git
+  type: git
+  location: git://github.com/haskus/haskus-utils.git
 
 library
-    exposed-modules:
-        Haskus.Utils.ContFlow
-        Haskus.Utils.Variant
-        Haskus.Utils.Variant.Flow
-        Haskus.Utils.Variant.Cont
-        Haskus.Utils.Variant.Syntax
-        Haskus.Utils.VariantF
-        Haskus.Utils.EADT
-        Haskus.Utils.EADT.TH
-    hs-source-dirs: src/lib
-    default-language: Haskell2010
-    ghc-options: -Wall
-    build-depends:
-        base >=4.9 && <5.0,
-        template-haskell >=2.13.0.0,
-        haskus-utils-types >=1.2,
-        haskus-utils-data >=1.1
+  exposed-modules:
+    Haskus.Utils.ContFlow
+    Haskus.Utils.Variant
+    Haskus.Utils.Variant.Flow
+    Haskus.Utils.Variant.Cont
+    Haskus.Utils.Variant.Syntax
+    Haskus.Utils.VariantF
+    Haskus.Utils.EADT
+    Haskus.Utils.EADT.TH
+
+  other-modules:
+
+  build-depends:       
+      base                      >= 4.9 && < 5.0
+   ,  template-haskell
+   ,  haskus-utils-types        >= 1.3
+   ,  haskus-utils-data
+
+  build-tools: 
+  ghc-options:          -Wall
+  default-language:     Haskell2010
+  hs-source-dirs:       src/lib
 
 test-suite tests
-    type: exitcode-stdio-1.0
-    main-is: Main.hs
-    hs-source-dirs: src/tests
-    other-modules:
-        Variant
-    default-language: Haskell2010
-    ghc-options: -Wall -threaded
-    build-depends:
-        base >=4.11.1.0,
-        haskus-utils-variant -any,
-        tasty >=0.11,
-        tasty-quickcheck >=0.8
+   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
+      ,  haskus-utils-variant
+      ,  tasty                   >= 0.11
+      ,  tasty-quickcheck        >= 0.8
diff --git a/src/lib/Haskus/Utils/EADT.hs b/src/lib/Haskus/Utils/EADT.hs
index be0a998..1618cf3 100644
--- a/src/lib/Haskus/Utils/EADT.hs
+++ b/src/lib/Haskus/Utils/EADT.hs
@@ -57,7 +57,7 @@ type family (:<<:) xs ys :: Constraint where
    (x ': xs) :<<: ys = (x :<: ys, xs :<<: ys)
 
 type EADTF' f e cs =
-   ( Member' f 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))
@@ -127,6 +127,12 @@ eadtToContM ::
      -> ContFlow (ApplyAll (Fix (VariantF xs)) xs) (m r)
 eadtToContM f = variantFToContM (unfix <$> f)
 
+-- Orphan instance...
+-- instance ContVariant (ApplyAll (EADT xs) xs) => MultiCont (EADT xs) where
+--    type MultiContTypes (EADT xs) = ApplyAll (EADT xs) xs
+--    toCont  = eadtToCont
+--    toContM = eadtToContM
+
 -- | Convert a multi-continuation into an EADT
 contToEADT ::
    ( ContVariant (ApplyAll (Fix (VariantF xs)) xs)
diff --git a/src/lib/Haskus/Utils/EADT/TH.hs b/src/lib/Haskus/Utils/EADT/TH.hs
index 9e8ad96..c2a78e5 100644
--- a/src/lib/Haskus/Utils/EADT/TH.hs
+++ b/src/lib/Haskus/Utils/EADT/TH.hs
@@ -6,7 +6,9 @@
 -- | Template-Haskell helpers for EADTs
 module Haskus.Utils.EADT.TH
    ( eadtPattern
+   , eadtInfixPattern
    , eadtPatternT
+   , eadtInfixPatternT
    )
 where
 
@@ -30,7 +32,25 @@ eadtPattern
    :: Name       -- ^ Actual constructor (e.g., ConsF)
    -> String     -- ^ Name of the pattern (e.g., Cons)
    -> Q [Dec]
-eadtPattern consName patStr = eadtPattern' consName patStr Nothing
+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.
@@ -63,16 +83,25 @@ eadtPatternT
    -> Q Type     -- ^ Type of the EADT (e.g., [t|forall a. List a|])
    -> Q [Dec]
 eadtPatternT consName patStr qtype =
-   eadtPattern' consName patStr (Just 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= do
+eadtPattern' consName patStr mEadtTy isInfix = do
    let patName = mkName patStr
 
    typ <- reify consName >>= \case
@@ -91,7 +120,13 @@ eadtPattern' consName patStr mEadtTy= do
 
          let vf     = mkName "Haskus.Utils.EADT.VF"
 
-         let pat    = PatSynD patName (PrefixPatSyn conArgs) ImplBidir
+         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
                          (ConP vf [ConP consName (fmap VarP conArgs)])
 
          let
diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs
index 6e47b52..54d3c6a 100644
--- a/src/lib/Haskus/Utils/Variant.hs
+++ b/src/lib/Haskus/Utils/Variant.hs
@@ -93,11 +93,11 @@ module Haskus.Utils.Variant
    , ContVariant (..)
    -- ** Internals
    , pattern VSilent
+   , LiftVariant'
    , liftVariant'
    , fromVariant'
    , popVariant'
    , toVariant'
-   , LiftVariant'
    , PopVariant
    )
 where
@@ -137,7 +137,7 @@ pattern V x <- (fromVariant -> Just x)
 --          VSilent (x :: Int)    -> ...
 --          VSilent (x :: String) -> ...
 pattern VSilent :: forall c cs.
-   ( Member' c cs
+   ( Member c cs
    , PopVariant c cs
    ) => c -> V cs
 pattern VSilent x <- (fromVariant' -> Just x)
@@ -296,7 +296,7 @@ _ `constBindVariant` v2 = appendVariant @xs v2
 --
 -- Use the first matching type index.
 toVariant :: forall a l.
-   ( Member a l
+   ( a :< l
    ) => a -> V l
 {-# INLINABLE toVariant #-}
 toVariant = toVariantAt @(IndexOf a l)
@@ -305,7 +305,7 @@ toVariant = toVariantAt @(IndexOf a l)
 --
 -- Use the first matching type index.
 toVariant' :: forall a l.
-   ( Member' a l
+   ( Member a l
    ) => a -> V l
 {-# INLINABLE toVariant' #-}
 toVariant' = toVariantAt @(IndexOf a l)
@@ -368,7 +368,8 @@ splitVariant = splitVariant' @as @(Complement xs as) @xs
 
 -- | A value of type "x" can be extracted from (V xs)
 type (:<) x xs =
-   ( Member x xs
+   ( CheckMember x xs
+   , Member x xs
    , x :<? xs
    )
 
@@ -720,10 +721,11 @@ prependVariant (Variant t a) = Variant (n+t) a
 
 -- | xs is liftable in ys
 type LiftVariant xs ys =
-   ( IsSubset xs ys ~ 'True
-   , LiftVariant' xs ys
+   ( LiftVariant' xs ys
+   , xs :<< ys
    )
 
+-- | xs is liftable in ys
 class LiftVariant' xs ys where
    liftVariant' :: V xs -> V ys
 
diff --git a/src/lib/Haskus/Utils/Variant/Cont.hs b/src/lib/Haskus/Utils/Variant/Cont.hs
index e40f7a7..bd54c05 100644
--- a/src/lib/Haskus/Utils/Variant/Cont.hs
+++ b/src/lib/Haskus/Utils/Variant/Cont.hs
@@ -35,7 +35,7 @@ import Haskus.Utils.ContFlow
 fret :: forall x r t n xs.
    ( ExtractTuple n t (x -> r)
    , xs ~ ContTupleToList t r
-   , Member x xs
+   , CheckMember x xs
    , n ~ IndexOf x xs
    , KnownNat n
    , CheckNub xs
@@ -47,7 +47,7 @@ fret = tupleN @n @t @(x -> r)
 freturn :: forall x r t n xs.
    ( ExtractTuple n t (x -> r)
    , xs ~ ContTupleToList t r
-   , Member x xs
+   , CheckMember x xs
    , n ~ IndexOf x xs
    , KnownNat n
    , CheckNub xs
diff --git a/src/lib/Haskus/Utils/Variant/Flow.hs b/src/lib/Haskus/Utils/Variant/Flow.hs
index 578b78f..252e938 100644
--- a/src/lib/Haskus/Utils/Variant/Flow.hs
+++ b/src/lib/Haskus/Utils/Variant/Flow.hs
@@ -215,7 +215,7 @@ flowSetN :: forall (n :: Nat) xs m.
 flowSetN = return . toVariantAt @n
 
 -- | Return in the first well-typed element
-flowSet :: (Member x xs, Monad m) => x -> Flow m xs
+flowSet :: (x :< xs, Monad m) => x -> Flow m xs
 {-# INLINABLE flowSet #-}
 flowSet = return . toVariant
 
@@ -866,7 +866,7 @@ infixl 0 >..~^^>
 -- | Extract the tail, connect the result
 (..~^>) ::
    ( Monad m
-   , Member a zs
+   , a :< zs
    ) => V (a ': l) -> (V l -> Flow m zs) -> Flow m zs
 {-# INLINABLE (..~^>) #-}
 (..~^>) v f = case popVariantHead v of
@@ -878,7 +878,7 @@ infixl 0 ..~^>
 -- | Extract the tail, connect the result
 (>..~^>) ::
    ( Monad m
-   , Member a zs
+   , a :< zs
    ) => Flow m (a ': l) -> (V l -> Flow m zs) -> Flow m zs
 {-# INLINABLE (>..~^>) #-}
 (>..~^>) = liftm (..~^>)
diff --git a/src/lib/Haskus/Utils/VariantF.hs b/src/lib/Haskus/Utils/VariantF.hs
index 0a7587e..e6db5f3 100644
--- a/src/lib/Haskus/Utils/VariantF.hs
+++ b/src/lib/Haskus/Utils/VariantF.hs
@@ -138,8 +138,7 @@ mapVariantF f (VariantF v) = VariantF (mapVariant @(a e) @(b e) @(ApplyAll e cs)
 
 -- | xs is liftable in ys
 type LiftVariantF xs ys e =
-   ( IsSubset xs ys ~ 'True
-   , LiftVariant (ApplyAll e xs) (ApplyAll e ys)
+   ( LiftVariant (ApplyAll e xs) (ApplyAll e ys)
    )
 
 -- | Lift a VariantF into another
@@ -260,5 +259,5 @@ 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
+   toCont  = variantFToCont
    toContM = variantFToContM
diff --git a/src/tests/EADT.hs b/src/tests/EADT.hs
new file mode 100644
index 0000000..696c56d
--- /dev/null
+++ b/src/tests/EADT.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module EADT
+   ( testsEADT
+   )
+where
+
+import Test.Tasty
+import Test.Tasty.QuickCheck as QC
+
+import Haskus.Utils.EADT
+import Haskus.Utils.EADT.TH
+
+data ConsF a l = ConsF a l deriving (Functor)
+data NilF    l = NilF      deriving (Functor)
+
+eadtPattern 'ConsF "Cons"
+eadtPattern 'NilF  "Nil"
+eadtInfixPattern 'ConsF ":->"
+
+type List a = EADT '[ConsF a, NilF]
+
+list0 :: List String
+list0 = Cons "Hello" $ Cons "World" Nil
+
+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
+
+   ]
diff --git a/src/tests/Main.hs b/src/tests/Main.hs
index 72aa005..9f384a3 100644
--- a/src/tests/Main.hs
+++ b/src/tests/Main.hs
@@ -1,8 +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
index 494cb0e..cf3c903 100644
--- a/src/tests/Variant.hs
+++ b/src/tests/Variant.hs
@@ -17,6 +17,7 @@ import Test.Tasty.QuickCheck as QC
 import Data.Either
 
 import Haskus.Utils.Variant
+import Haskus.Utils.ContFlow
 
 data A = A deriving (Show,Eq)
 data B = B deriving (Show,Eq)
@@ -102,6 +103,15 @@ testsVariant = testGroup "Variant" $
    , 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