diff --git a/haskus-utils-variant.cabal b/haskus-utils-variant.cabal --- 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 --- a/src/lib/Haskus/Utils/EADT.hs +++ b/src/lib/Haskus/Utils/EADT.hs @@ -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 :: diff --git a/src/lib/Haskus/Utils/EADT/TH.hs b/src/lib/Haskus/Utils/EADT/TH.hs --- 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,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 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 @@ -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 : V ys diff --git a/src/lib/Haskus/Utils/Variant/Cont.hs b/src/lib/Haskus/Utils/Variant/Cont.hs --- a/src/lib/Haskus/Utils/Variant/Cont.hs +++ b/src/lib/Haskus/Utils/Variant/Cont.hs @@ -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 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 @@ -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 (..~^>) 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 @@ -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 diff --git a/src/tests/EADT.hs b/src/tests/EADT.hs new file mode 100644 --- /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 --- 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 --- a/src/tests/Variant.hs +++ b/src/tests/Variant.hs @@ -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