diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,8 +0,0 @@ -0.9.0.0 - TBA -============= - - -0.8.0.0 - 2018-02-21 -==================== - -* Enhanced Variant API diff --git a/haskus-utils.cabal b/haskus-utils.cabal --- a/haskus-utils.cabal +++ b/haskus-utils.cabal @@ -1,19 +1,17 @@ -name: haskus-utils -version: 1.0 cabal-version: >=1.21 -build-type: Simple +name: haskus-utils +version: 1.1 license: BSD3 license-file: LICENSE copyright: Sylvain Henry 2018 maintainer: sylvain@haskus.fr -homepage: http://www.haskus.org/system +author: Sylvain Henry +homepage: http://docs.haskus.org/ synopsis: Haskus utility modules description: - Haskus utility modules. Reexport all other utility modules + Haskus utility modules. category: System -author: Sylvain Henry -extra-source-files: - CHANGES +build-type: Simple source-repository head type: git @@ -35,27 +33,14 @@ Haskus.Utils.STM.TTree Haskus.Utils.STM.Future Haskus.Utils.STM.TGraph - reexported-modules: Haskus.Utils.Types, - Haskus.Utils.Types.Generics, - Haskus.Utils.Types.List, - Haskus.Utils.Monad, - Haskus.Utils.HList, - Haskus.Utils.Functor, - Haskus.Utils.List, - Haskus.Utils.Map, - Haskus.Utils.Map.Strict, - Haskus.Utils.Maybe, - Haskus.Utils.Tuple, - Haskus.Utils.ContFlow, - Haskus.Utils.Variant, - Haskus.Utils.Variant.Flow, - Haskus.Utils.Variant.Cont, - Haskus.Utils.EADT + hs-source-dirs: src/lib + default-language: Haskell2010 + ghc-options: -Wall build-depends: base >=4.9 && <4.12, - haskus-utils-types ==1.0.*, - haskus-utils-data ==1.0.*, - haskus-utils-variant ==1.0.*, + haskus-utils-types ==1.1.*, + haskus-utils-data ==1.1.*, + haskus-utils-variant ==2.0.*, containers ==0.5.*, list-t >=0.4 && <1.1, stm ==2.4.*, @@ -67,23 +52,19 @@ file-embed >=0.0.10 && <0.1, extra >=1.4 && <1.7, recursion-schemes ==5.0.* - default-language: Haskell2010 - hs-source-dirs: src/lib - ghc-options: -Wall -test-suite tests +test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs - build-depends: - base >=4.11.1.0 && <4.12, - haskus-utils -any, - tasty >=0.11 && <1.2, - tasty-quickcheck >=0.8 && <0.11 - default-language: Haskell2010 hs-source-dirs: src/tests other-modules: Haskus.Tests.Utils Haskus.Tests.Utils.HArray - Haskus.Tests.Utils.Variant Haskus.Tests.Utils.Solver + default-language: Haskell2010 ghc-options: -Wall -threaded + build-depends: + base >=4.11.1.0 && <4.12, + haskus-utils -any, + tasty >=0.11 && <1.2, + tasty-quickcheck >=0.8 && <0.11 diff --git a/src/lib/Haskus/Utils/Parser.hs b/src/lib/Haskus/Utils/Parser.hs --- a/src/lib/Haskus/Utils/Parser.hs +++ b/src/lib/Haskus/Utils/Parser.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeOperators #-} -- | Tools to write parsers using Flows module Haskus.Utils.Parser @@ -54,7 +55,7 @@ ( x ~ Flow m xs , y ~ Flow m ys , z ~ Flow m zs - , Popable a xs + , a :< xs , Liftable ys zs , Liftable (Filter a xs) zs , zs ~ Union (Filter a xs) ys @@ -86,8 +87,8 @@ many :: ( zs ~ Filter ParseError xs , Monad m - , Popable ParseError xs - ) => Flow m xs -> Flow m '[[Variant zs]] + , ParseError :< xs + ) => Flow m xs -> Flow m '[[V zs]] many f = manyBounded Nothing Nothing f >%~^> \(_ :: ParseError) -> flowSingle [] @@ -96,8 +97,8 @@ manyAtMost :: ( zs ~ Filter ParseError xs , Monad m - , Popable ParseError xs - ) => Word -> Flow m xs -> Flow m '[[Variant zs]] + , ParseError :< xs + ) => Word -> Flow m xs -> Flow m '[[V zs]] manyAtMost max f = manyBounded Nothing (Just max) f >%~^> \(_ :: ParseError) -> flowSingle [] @@ -106,8 +107,8 @@ manyAtMost' :: ( zs ~ Filter ParseError xs , Monad m - , Popable ParseError xs - ) => Word -> Flow m xs -> m [Variant zs] + , ParseError :< xs + ) => Word -> Flow m xs -> m [V zs] manyAtMost' max f = variantToValue <$> manyAtMost max f -- | Apply the action zero or more times (up to max) until a ParseError result @@ -115,7 +116,7 @@ manyAtMost'' :: ( '[x] ~ Filter ParseError xs , Monad m - , Popable ParseError xs + , ParseError :< xs ) => Word -> Flow m xs -> m [x] manyAtMost'' max f = fmap variantToValue <$> manyAtMost' max f @@ -124,8 +125,8 @@ manyAtLeast :: ( zs ~ Filter ParseError xs , Monad m - , Popable ParseError xs - ) => Word -> Flow m xs -> Flow m '[[Variant zs],ParseError] + , ParseError :< xs + ) => Word -> Flow m xs -> Flow m '[[V zs],ParseError] manyAtLeast min = manyBounded (Just min) Nothing -- | Apply the first action zero or more times until the second succeeds. @@ -136,9 +137,9 @@ ( zs ~ Filter ParseError xs , zs' ~ Filter ParseError ys , Monad m - , MaybePopable ParseError xs - , Popable ParseError ys - ) => Flow m xs -> Flow m ys -> Flow m '[([Variant zs],Variant zs'),ParseError] + , ParseError : Flow m xs -> Flow m ys -> Flow m '[([V zs],V zs'),ParseError] manyTill f g = go [] where go xs = do @@ -159,9 +160,9 @@ manyTill' :: ( zs ~ Filter ParseError xs , Monad m - , MaybePopable ParseError xs - , Popable ParseError ys - ) => Flow m xs -> Flow m ys -> Flow m '[[Variant zs],ParseError] + , ParseError : Flow m xs -> Flow m ys -> Flow m '[[V zs],ParseError] manyTill' f g = manyTill f g >.-.> fst -- | Apply the given action at least 'min' times and at most 'max' time @@ -170,16 +171,16 @@ manyBounded :: forall zs xs m. ( zs ~ Filter ParseError xs , Monad m - , MaybePopable ParseError xs - ) => Maybe Word -> Maybe Word -> Flow m xs -> Flow m '[[Variant zs],ParseError] -manyBounded _ (Just 0) _ = flowSet ([] :: [Variant zs]) + , ParseError : Maybe Word -> Maybe Word -> Flow m xs -> Flow m '[[V zs],ParseError] +manyBounded _ (Just 0) _ = flowSet ([] :: [V zs]) manyBounded (Just 0) max f = manyBounded Nothing max f manyBounded min max f = do v <- f case popVariantMaybe v of Right (e :: ParseError) -> case min of Just n | n > 0 -> flowSet e - _ -> flowSet ([] :: [Variant zs]) + _ -> flowSet ([] :: [V zs]) Left x -> do let minus1 = fmap (\k -> k - 1) xs <- manyBounded (minus1 min) (minus1 max) f diff --git a/src/tests/Haskus/Tests/Utils.hs b/src/tests/Haskus/Tests/Utils.hs --- a/src/tests/Haskus/Tests/Utils.hs +++ b/src/tests/Haskus/Tests/Utils.hs @@ -3,14 +3,10 @@ import Test.Tasty import Haskus.Tests.Utils.HArray -import Haskus.Tests.Utils.Variant import Haskus.Tests.Utils.Solver testsUtils :: TestTree testsUtils = testGroup "Utils" [ testsHArray - , testsVariant , testsSolver ] - - diff --git a/src/tests/Haskus/Tests/Utils/Variant.hs b/src/tests/Haskus/Tests/Utils/Variant.hs deleted file mode 100644 --- a/src/tests/Haskus/Tests/Utils/Variant.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module Haskus.Tests.Utils.Variant - ( testsVariant - ) -where - -import Test.Tasty -import Test.Tasty.QuickCheck as QC -import Data.Either - -import Haskus.Utils.Variant - -data A = A deriving (Show,Eq) -data B = B deriving (Show,Eq) -data C = C deriving (Show,Eq) -data D = D deriving (Show,Eq) -data E = E deriving (Show,Eq) -data F = F deriving (Show,Eq) - -type ABC = Variant '[A,B,C] -type DEF = Variant '[D,E,F] - -b :: ABC -b = toVariantAt @1 B - -b2d :: B -> D -b2d = const D - -c2d :: C -> D -c2d = const D - -b2def :: B -> DEF -b2def = const (toVariant E) - -c2def :: C -> DEF -c2def = const (toVariant E) - - -testsVariant :: TestTree -testsVariant = testGroup "Variant" $ - [ testProperty "set/get by index (match)" - (fromVariantAt @1 b == Just B) - , testProperty "set/get by index (dont' match)" - (fromVariantAt @0 b == Nothing) - , testProperty "set/get by type (match)" - (fromVariant (toVariant B :: ABC) == Just B) - , testProperty "set/get by type (don't match)" - (fromVariant @C (toVariant B :: ABC) == Nothing) - - , testProperty "variant equality (match)" - (b == b) - , testProperty "variant equality (don't match)" - (b /= toVariant C) - - , testProperty "update by index (match)" - (updateVariantAt @1 (const D) b == toVariantAt @1 D) - , testProperty "update by index (don't match)" - (updateVariantAt @0 (const F) b == toVariantAt @1 B) - , testProperty "update by type (match)" - (updateVariantFirst b2d b == toVariantAt @1 D) - , testProperty "update by type (don't match)" - (updateVariantFirst c2d b == toVariant B) - , testProperty "update/fold by index (match)" - (foldMapVariantAt @1 b2def b == toVariant E) - , testProperty "update/fold by index (don't match)" - (foldMapVariantAt @2 c2def b == toVariant B) - - , testProperty "Convert into tuple" - (variantToTuple b == (Nothing, Just B, Nothing)) - , testProperty "Convert single variant" - (variantToValue (toVariant A :: Variant '[A]) == A) - - , testProperty "Lift Either: Left" - (variantFromEither (Left A :: Either A B) == toVariant A) - , testProperty "Lift Either: Right" - (variantFromEither (Right B :: Either A B) == toVariant B) - - , testProperty "To Either: Left" - (variantToEither (toVariant B :: Variant '[A,B]) == Left B) - , testProperty "To Either: Right" - (variantToEither (toVariant A :: Variant '[A,B]) == Right A) - - , testProperty "popVariantHead (match)" - (popVariantHead (toVariant A :: ABC) == Right A) - , testProperty "popVariantHead (don't match)" - (isLeft (popVariantHead b)) - - , testProperty "popVariantAt (match)" - (popVariantAt @1 b == Right B) - , testProperty "popVariantAt (don't match)" - (isLeft (popVariantAt @2 b)) - - , testProperty "popVariant (match)" - (popVariant @D (toVariantAt @4 D :: Variant '[A,B,C,B,D,E,D]) == Right D) - , testProperty "popVariant (match)" - (popVariant @D (toVariantAt @6 D :: Variant '[A,B,C,B,D,E,D]) == Right D) - , testProperty "popVariant (don't match)" - (popVariant @B (toVariantAt @4 D :: Variant '[A,B,C,B,D,E,D]) == Left (toVariantAt @2 D)) - - , testProperty "prependVariant" - (fromVariantAt @4 (prependVariant @'[D,E,F] b) == Just B) - , testProperty "appendVariant" - (fromVariantAt @1 (appendVariant @'[D,E,F] b) == Just B) - - , testProperty "alterVariant" - (alterVariant @Num (+1) (toVariant (1.0 :: Float) :: Variant '[Int,Float]) == toVariant (2.0 :: Float)) - , testProperty "alterVariant" - (alterVariant @Num (+1) (toVariant (1.0 :: Float) :: Variant '[Float,Int]) == toVariant (2.0 :: Float)) - - , testProperty "traverseVariant" - (traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing) - (toVariant (2.0 :: Float) :: Variant '[Float,Int]) == Just (toVariant (2.0 :: Float))) - , testProperty "traverseVariant" - (traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing) - (toVariant (0.5 :: Float) :: Variant '[Float,Int]) == Nothing) - - , testProperty "liftVariant" - (fromVariant (liftVariant b :: Variant '[D,A,E,B,F,C]) == Just B) - ] - -class (Ord a, Num a) => OrdNum a -instance (Ord a, Num a) => OrdNum a