summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvainHenry <>2018-11-08 19:46:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-11-08 19:46:00 (GMT)
commit7b190fb64b76166e60e832ca6b16f3245fedd992 (patch)
tree1d9ba059285571ce9aad24f21a3b5dd06b68e70e
parent1531104c362e427b082978f2bbf88534273857e8 (diff)
version 2.32.3
-rw-r--r--haskus-utils-variant.cabal98
-rw-r--r--src/lib/Haskus/Utils/EADT.hs8
-rw-r--r--src/lib/Haskus/Utils/EADT/TH.hs43
-rw-r--r--src/lib/Haskus/Utils/Variant.hs16
-rw-r--r--src/lib/Haskus/Utils/Variant/Cont.hs4
-rw-r--r--src/lib/Haskus/Utils/Variant/Flow.hs6
-rw-r--r--src/lib/Haskus/Utils/VariantF.hs5
-rw-r--r--src/tests/EADT.hs45
-rw-r--r--src/tests/Main.hs2
-rw-r--r--src/tests/Variant.hs10
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