haskus-utils-variant 2.2 → 2.3
raw patch · 10 files changed
+172/−65 lines, 10 filesdep ~basedep ~haskus-utils-datadep ~haskus-utils-typesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, haskus-utils-data, haskus-utils-types, template-haskell
API changes (from Hackage documentation)
+ Haskus.Utils.EADT.TH: eadtInfixPattern :: Name -> String -> Q [Dec]
+ Haskus.Utils.EADT.TH: eadtInfixPatternT :: Name -> String -> Q Type -> Q [Dec]
- Haskus.Utils.Variant: toVariant :: forall a l. Member a l => a -> V l
+ Haskus.Utils.Variant: toVariant :: forall a l. a :< l => a -> V l
- Haskus.Utils.Variant: toVariant' :: forall a l. Member' a l => a -> V l
+ Haskus.Utils.Variant: toVariant' :: forall a l. Member a l => a -> V l
- Haskus.Utils.Variant: type LiftVariant xs ys = (IsSubset xs ys ~ 'True, LiftVariant' xs ys)
+ Haskus.Utils.Variant: type LiftVariant xs ys = (LiftVariant' xs ys, xs :<< ys)
- Haskus.Utils.Variant: type Member (x :: k) (xs :: [k]) = (IsMember x xs ~ True, x ~ Index IndexOf x xs xs, KnownNat IndexOf x xs)
+ Haskus.Utils.Variant: type Member (x :: k) (xs :: [k]) = (x ~ Index IndexOf x xs xs, KnownNat IndexOf x xs)
- Haskus.Utils.Variant.Cont: fret :: forall x r t n xs. (ExtractTuple n t (x -> r), xs ~ ContTupleToList t r, Member x xs, n ~ IndexOf x xs, KnownNat n, CheckNub xs) => t -> x -> r
+ Haskus.Utils.Variant.Cont: fret :: forall x r t n xs. (ExtractTuple n t (x -> r), xs ~ ContTupleToList t r, CheckMember x xs, n ~ IndexOf x xs, KnownNat n, CheckNub xs) => t -> x -> r
- Haskus.Utils.Variant.Cont: freturn :: forall x r t n xs. (ExtractTuple n t (x -> r), xs ~ ContTupleToList t r, Member x xs, n ~ IndexOf x xs, KnownNat n, CheckNub xs, ?__cs :: t) => x -> r
+ Haskus.Utils.Variant.Cont: freturn :: forall x r t n xs. (ExtractTuple n t (x -> r), xs ~ ContTupleToList t r, CheckMember x xs, n ~ IndexOf x xs, KnownNat n, CheckNub xs, ?__cs :: t) => x -> r
- Haskus.Utils.Variant.Flow: (..~^>) :: (Monad m, Member a zs) => V (a : l) -> (V l -> Flow m zs) -> Flow m zs
+ Haskus.Utils.Variant.Flow: (..~^>) :: (Monad m, a :< zs) => V (a : l) -> (V l -> Flow m zs) -> Flow m zs
- Haskus.Utils.Variant.Flow: (>..~^>) :: (Monad m, Member a zs) => Flow m (a : l) -> (V l -> Flow m zs) -> Flow m zs
+ Haskus.Utils.Variant.Flow: (>..~^>) :: (Monad m, a :< zs) => Flow m (a : l) -> (V l -> Flow m zs) -> Flow m zs
- Haskus.Utils.Variant.Flow: flowSet :: (Member x xs, Monad m) => x -> Flow m xs
+ Haskus.Utils.Variant.Flow: flowSet :: (x :< xs, Monad m) => x -> Flow m xs
- Haskus.Utils.Variant.Flow: type LiftVariant xs ys = (IsSubset xs ys ~ 'True, LiftVariant' xs ys)
+ Haskus.Utils.Variant.Flow: type LiftVariant xs ys = (LiftVariant' xs ys, xs :<< ys)
- Haskus.Utils.VariantF: type LiftVariantF xs ys e = (IsSubset xs ys ~ 'True, LiftVariant (ApplyAll e xs) (ApplyAll e ys))
+ Haskus.Utils.VariantF: type LiftVariantF xs ys e = (LiftVariant (ApplyAll e xs) (ApplyAll e ys))
Files
- haskus-utils-variant.cabal +53/−45
- src/lib/Haskus/Utils/EADT.hs +7/−1
- src/lib/Haskus/Utils/EADT/TH.hs +39/−4
- src/lib/Haskus/Utils/Variant.hs +9/−7
- src/lib/Haskus/Utils/Variant/Cont.hs +2/−2
- src/lib/Haskus/Utils/Variant/Flow.hs +3/−3
- src/lib/Haskus/Utils/VariantF.hs +2/−3
- src/tests/EADT.hs +45/−0
- src/tests/Main.hs +2/−0
- src/tests/Variant.hs +10/−0
haskus-utils-variant.cabal view
@@ -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
src/lib/Haskus/Utils/EADT.hs view
@@ -57,7 +57,7 @@ (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))@@ -126,6 +126,12 @@ ) => m (Fix (VariantF xs)) -> 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 ::
src/lib/Haskus/Utils/EADT/TH.hs view
@@ -6,7 +6,9 @@ -- | Template-Haskell helpers for EADTs module Haskus.Utils.EADT.TH ( eadtPattern+ , eadtInfixPattern , eadtPatternT+ , eadtInfixPatternT ) where @@ -30,8 +32,26 @@ :: 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 @@ -> 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 @@ 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
src/lib/Haskus/Utils/Variant.hs view
@@ -93,11 +93,11 @@ , ContVariant (..) -- ** Internals , pattern VSilent+ , LiftVariant' , liftVariant' , fromVariant' , popVariant' , toVariant'- , LiftVariant' , PopVariant ) where@@ -137,7 +137,7 @@ -- 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 @@ -- -- 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 @@ -- -- 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 @@ -- | 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 @@ -- | 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
src/lib/Haskus/Utils/Variant/Cont.hs view
@@ -35,7 +35,7 @@ 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 @@ 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
src/lib/Haskus/Utils/Variant/Flow.hs view
@@ -215,7 +215,7 @@ 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 @@ -- | 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 @@ -- | 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 (..~^>)
src/lib/Haskus/Utils/VariantF.hs view
@@ -138,8 +138,7 @@ -- | 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 @@ instance ContVariant (ApplyAll e xs) => MultiCont (VariantF xs e) where type MultiContTypes (VariantF xs e) = ApplyAll e xs- toCont = variantFToCont+ toCont = variantFToCont toContM = variantFToContM
+ src/tests/EADT.hs view
@@ -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++ ]
src/tests/Main.hs view
@@ -1,8 +1,10 @@ import Test.Tasty import Variant+import EADT main :: IO () main = defaultMain $ testGroup "utils-variant" [ testsVariant+ , testsEADT ]
src/tests/Variant.hs view
@@ -17,6 +17,7 @@ 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 @@ , 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