From c093363836b0796c6242f83a583d1e80a907b0ea Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 20 Nov 2021 14:44:51 +0300 Subject: [PATCH 01/20] [ #206 ] Deriving FromField/ToField instances Works only for the following representations: * Single nullary constructor By default encodes constructor name * Sum with nullary or unary constructors Encoding is similar to 'UntaggedValue' encoding from 'aeson' --- src/Data/Csv.hs | 4 +- src/Data/Csv/Conversion.hs | 85 ++++++++++++++++++++++++++++++++++++++ tests/UnitTests.hs | 68 ++++++++++++++++++++++++++++++ 3 files changed, 156 insertions(+), 1 deletion(-) diff --git a/src/Data/Csv.hs b/src/Data/Csv.hs index 4bf9b27..ce51ed9 100644 --- a/src/Data/Csv.hs +++ b/src/Data/Csv.hs @@ -100,13 +100,15 @@ module Data.Csv , FromField(..) , ToField(..) - -- ** 'Generic' record conversion + -- ** 'Generic' type conversion -- $genericconversion , genericParseRecord , genericToRecord , genericParseNamedRecord , genericToNamedRecord , genericHeaderOrder + , genericParseField + , genericToField -- *** 'Generic' type conversion options , Options diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index adaad2c..d111b8b 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -44,6 +44,8 @@ module Data.Csv.Conversion , genericParseNamedRecord , genericToNamedRecord , genericHeaderOrder + , genericParseField + , genericToField -- *** Generic type conversion options , Options @@ -760,6 +762,12 @@ parseBoth (k, v) = (,) <$> parseField k <*> parseField v class FromField a where parseField :: Field -> Parser a + default parseField :: (Generic a, GFromField (Rep a)) => Field -> Parser a + parseField = genericParseField defaultOptions + +genericParseField :: (Generic a, GFromField (Rep a)) => Options -> Field -> Parser a +genericParseField opts = fmap to . gParseField opts + -- | A type that can be converted to a single CSV field. -- -- Example type and instance: @@ -775,6 +783,12 @@ class FromField a where class ToField a where toField :: a -> Field + default toField :: (Generic a, GToField (Rep a)) => a -> Field + toField = genericToField defaultOptions + +genericToField :: (Generic a, GToField (Rep a)) => Options -> a -> Field +genericToField opts = gToField opts . from + -- | 'Nothing' if the 'Field' is 'B.empty', 'Just' otherwise. instance FromField a => FromField (Maybe a) where parseField s @@ -1370,6 +1384,77 @@ instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B where name = T.encodeUtf8 (T.pack (fieldLabelModifier opts (selName m))) +class GFromField (f :: k -> *) where + gParseField :: Options -> Field -> Parser (f p) + +-- Type with single nullary constructor +instance (Constructor c) => GFromField (D1 meta (C1 c U1)) where + gParseField opts = fmap M1 . gParseField' opts + +-- Sum type with nullary or unary constructors +instance (Datatype t, GFromField' c1, GFromField' c2) => GFromField (D1 t (c1 :+: c2)) where + gParseField opts field = fmap M1 $ + (L1 <$> gParseField' opts field) + <|> (R1 <$> gParseField' opts field) + <|> fail errMsg + where + errMsg = + "Can't parse " <> datatypeName (Proxy :: Proxy t d f) <> " from " <> show field + +class GToField (f :: k -> *) where + gToField :: Options -> f p -> Field + +-- Type with single nullary constructor +instance (Constructor c) => GToField (D1 meta (C1 c U1)) where + gToField opts = gToField' opts . unM1 + +-- Sum type with nullary or unary constructors +instance (GToField' c1, GToField' c2) => GToField (D1 t (c1 :+: c2)) where + gToField opts (M1 (L1 val)) = gToField' opts val + gToField opts (M1 (R1 val)) = gToField' opts val + +-- Helper classes for FromField/ToField + +class GFromField' (f :: k -> *) where + gParseField' :: Options -> Field -> Parser (f p) + +-- Nullary constructor +instance (Constructor c) => GFromField' (C1 c U1) where + gParseField' opts field = do + if field == expected then pure val else fail $ "Expected " <> show expected + where + expected = encodeConstructor opts val + val :: C1 c U1 p + val = M1 U1 + +-- Unary constructor +instance (FromField a) => GFromField' (C1 c (S1 meta (K1 i a))) where + gParseField' _ = fmap (M1 . M1 . K1) . parseField + +-- Sum +instance (GFromField' c1, GFromField' c2) => GFromField' (c1 :+: c2) where + gParseField' opts field = + fmap L1 (gParseField' opts field) <|> fmap R1 (gParseField' opts field) + +class GToField' (f :: k -> *) where + gToField' :: Options -> f p -> Field + +-- Nullary constructor +instance (Constructor c) => GToField' (C1 c U1) where + gToField' = encodeConstructor + +-- Unary constructor +instance (ToField a) => GToField' (C1 c (S1 meta (K1 i a))) where + gToField' _ = toField . unK1 . unM1 . unM1 + +-- Sum +instance (GToField' c1, GToField' c2) => GToField' (c1 :+: c2) where + gToField' opts (L1 val) = gToField' opts val + gToField' opts (R1 val) = gToField' opts val + +encodeConstructor :: (Constructor c) => Options -> C1 c f p -> B.ByteString +encodeConstructor opts = T.encodeUtf8 . T.pack . fieldLabelModifier opts . conName + -- We statically fail on sum types and product types without selectors -- (field names). diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 4e625e0..c62f1c2 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -14,8 +14,10 @@ import Control.Applicative (Const) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Char (toLower) import qualified Data.HashMap.Strict as HM import Data.Int +import qualified Data.List as L import Data.Scientific (Scientific) import qualified Data.Text as T import qualified Data.Text.Lazy as LT @@ -448,6 +450,71 @@ instance DefaultOrdered SampleType where instance Arbitrary SampleType where arbitrary = SampleType <$> arbitrary <*> arbitrary <*> arbitrary +------------------------------------------------------------------------ +-- Generic ToField/FromField tests + +data Foo = Foo + deriving (Eq, Generic, Show) + +instance FromField Foo +instance ToField Foo + +-- -- Should not compile +-- +-- -- Newtype +-- newtype Foo1 = Foo1 Int deriving (Eq, Generic, Show) +-- instance FromField Foo1 +-- instance ToField Foo1 +-- newtype FooRec1 = FooRec1 { unFooRec1 :: Int } deriving (Eq, Generic, Show) +-- instance FromField FooRec1 +-- instance ToField FooRec1 +-- newtype FooRecF1 a = FooRecF1 { unFooRecF1 :: a } deriving (Eq, Generic, Show) +-- instance (FromField a) => FromField (FooRecF1 a) +-- instance (ToField a) => ToField (FooRecF1 a) +-- -- Product +-- data Foo2 = Foo2 Char Int deriving (Eq, Generic, Show) +-- instance FromField Foo2 +-- instance ToField Foo2 + +data Bar = BarN1 | BarU Int | BarN2 + deriving (Eq, Generic, Show) + +instance FromField Bar +instance ToField Bar +instance Arbitrary Bar where + arbitrary = frequency [(1, pure BarN1), (3, BarU <$> arbitrary), (1, pure BarN2)] + +data BazEnum = BazOne | BazTwo | BazThree + deriving (Bounded, Enum, Eq, Generic, Show) + +instance FromField BazEnum where + parseField = genericParseField bazOptions +instance ToField BazEnum where + toField = genericToField bazOptions +instance Arbitrary BazEnum where + arbitrary = elements [minBound..maxBound] + +bazOptions :: Options +bazOptions = defaultOptions { fieldLabelModifier = go } + where go = maybe (error "No prefix Baz") (map toLower) . L.stripPrefix "Baz" + +genericFieldTests :: [TF.Test] +genericFieldTests = + [ testGroup "nullary constructor" + [ testCase "encoding" $ toField Foo @?= "Foo" + , testCase "decoding" $ runParser (parseField "Foo") @?= Right Foo ] + , testCase "decoding failure" $ runParser (parseField "foo") + @?= (Left "Expected \"Foo\"" :: Either String Foo) + , testProperty "sum type roundtrip" (roundtripProp :: Bar -> Bool) + , testGroup "constructor modifier" + [ testCase "encoding" $ toField BazOne @?= "one" + , testCase "decoding" $ runParser (parseField "two") @?= Right BazTwo + , testProperty "roundtrip" (roundtripProp :: BazEnum -> Bool) ] + ] + where + roundtripProp :: (Eq a, FromField a, ToField a) => a -> Bool + roundtripProp x = runParser (parseField $ toField x) == Right x + ------------------------------------------------------------------------ -- Test harness @@ -458,6 +525,7 @@ allTests = [ testGroup "positional" positionalTests , testGroup "custom-options" customOptionsTests , testGroup "instances" instanceTests , testGroup "generic-conversions" genericConversionTests + , testGroup "generic-field-conversions" genericFieldTests ] main :: IO () From 6be39c062e4df80f93c11af4773506e995be04cf Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sun, 21 Nov 2021 09:37:32 +0300 Subject: [PATCH 02/20] Drop redundant kinds and make old GHC versions happy --- src/Data/Csv/Conversion.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index d111b8b..b994e66 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -1384,7 +1384,7 @@ instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B where name = T.encodeUtf8 (T.pack (fieldLabelModifier opts (selName m))) -class GFromField (f :: k -> *) where +class GFromField f where gParseField :: Options -> Field -> Parser (f p) -- Type with single nullary constructor @@ -1401,7 +1401,7 @@ instance (Datatype t, GFromField' c1, GFromField' c2) => GFromField (D1 t (c1 :+ errMsg = "Can't parse " <> datatypeName (Proxy :: Proxy t d f) <> " from " <> show field -class GToField (f :: k -> *) where +class GToField f where gToField :: Options -> f p -> Field -- Type with single nullary constructor @@ -1415,7 +1415,7 @@ instance (GToField' c1, GToField' c2) => GToField (D1 t (c1 :+: c2)) where -- Helper classes for FromField/ToField -class GFromField' (f :: k -> *) where +class GFromField' f where gParseField' :: Options -> Field -> Parser (f p) -- Nullary constructor @@ -1436,7 +1436,7 @@ instance (GFromField' c1, GFromField' c2) => GFromField' (c1 :+: c2) where gParseField' opts field = fmap L1 (gParseField' opts field) <|> fmap R1 (gParseField' opts field) -class GToField' (f :: k -> *) where +class GToField' f where gToField' :: Options -> f p -> Field -- Nullary constructor From 711f21dc46b555ffe2f018a3d6bd6c71909e7804 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sun, 10 Jul 2022 20:19:52 +0300 Subject: [PATCH 03/20] Add pure to imports --- tests/UnitTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index c62f1c2..08b43f2 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -10,7 +10,7 @@ module Main ( main ) where -import Control.Applicative (Const) +import Control.Applicative (Const, pure) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 From 95d89c69a235d88dda8dd64858daaa47603bf53e Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Tue, 12 Jul 2022 14:16:12 +0200 Subject: [PATCH 04/20] Add pure only to the conditional imports --- tests/UnitTests.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 08b43f2..21aaf7e 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -10,7 +10,7 @@ module Main ( main ) where -import Control.Applicative (Const, pure) +import Control.Applicative (Const) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 @@ -37,7 +37,7 @@ import Data.Csv hiding (record) import qualified Data.Csv.Streaming as S #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>), (<*>), pure) #endif ------------------------------------------------------------------------ From 94e53b9627704792c1bd55936751a25837b2e2f5 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Tue, 12 Jul 2022 14:16:45 +0200 Subject: [PATCH 05/20] Test performance of the field parser for union types --- tests/UnitTests.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 21aaf7e..c6b5df9 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP, DataKinds, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 801 {-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-} @@ -515,6 +517,79 @@ genericFieldTests = roundtripProp :: (Eq a, FromField a, ToField a) => a -> Bool roundtripProp x = runParser (parseField $ toField x) == Right x +------------------------------------------------------------------------ +-- Union type performance + +type I0 = Either Int Int +type I1 = Either I0 I0 +type I2 = Either I1 I1 +type I3 = Either I2 I2 +type I4 = Either I3 I3 +type I5 = Either I4 I4 +type I6 = Either I5 I5 +type I7 = Either I6 I6 +type I8 = Either I7 I7 +type I9 = Either I8 I8 +type I10 = Either I9 I9 + +instance FromField I0 +instance FromField I1 +instance FromField I2 +instance FromField I3 +instance FromField I4 +instance FromField I5 +instance FromField I6 +instance FromField I7 +instance FromField I8 +instance FromField I9 +instance FromField I10 + +type U0 = Either Int T.Text +type U1 = Either I0 U0 +type U2 = Either I1 U1 +type U3 = Either I2 U2 +type U4 = Either I3 U3 +type U5 = Either I4 U4 +type U6 = Either I5 U5 +type U7 = Either I6 U6 +type U8 = Either I7 U7 +type U9 = Either I8 U8 +type U10 = Either I9 U9 + +instance FromField U0 +instance FromField U1 +instance FromField U2 +instance FromField U3 +instance FromField U4 +instance FromField U5 +instance FromField U6 +instance FromField U7 +instance FromField U8 +instance FromField U9 +instance FromField U10 + +unionTypePerformance :: [TF.Test] +unionTypePerformance = + [ testGroup "nested union" + [ testCase "decoding" $ runParser (parseField "Inside nested Either" :: Parser U10) @?= Right v10 + ] + ] + where + v10 :: U10 + v10 = + Right $ + Right $ + Right $ + Right $ + Right $ + Right $ + Right $ + Right $ + Right $ + Right $ + Right $ "Inside nested Either" + + ------------------------------------------------------------------------ -- Test harness @@ -526,6 +601,7 @@ allTests = [ testGroup "positional" positionalTests , testGroup "instances" instanceTests , testGroup "generic-conversions" genericConversionTests , testGroup "generic-field-conversions" genericFieldTests + , testGroup "union-type-performance" unionTypePerformance ] main :: IO () From 639201f4b9191460760c8af4e4312fc40da27685 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Thu, 3 Nov 2022 12:16:17 +0300 Subject: [PATCH 06/20] Revert "Test performance of the field parser for union types" This reverts commit 94e53b9627704792c1bd55936751a25837b2e2f5. --- tests/UnitTests.hs | 76 ---------------------------------------------- 1 file changed, 76 deletions(-) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index c6b5df9..21aaf7e 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP, DataKinds, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 801 {-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-} @@ -517,79 +515,6 @@ genericFieldTests = roundtripProp :: (Eq a, FromField a, ToField a) => a -> Bool roundtripProp x = runParser (parseField $ toField x) == Right x ------------------------------------------------------------------------- --- Union type performance - -type I0 = Either Int Int -type I1 = Either I0 I0 -type I2 = Either I1 I1 -type I3 = Either I2 I2 -type I4 = Either I3 I3 -type I5 = Either I4 I4 -type I6 = Either I5 I5 -type I7 = Either I6 I6 -type I8 = Either I7 I7 -type I9 = Either I8 I8 -type I10 = Either I9 I9 - -instance FromField I0 -instance FromField I1 -instance FromField I2 -instance FromField I3 -instance FromField I4 -instance FromField I5 -instance FromField I6 -instance FromField I7 -instance FromField I8 -instance FromField I9 -instance FromField I10 - -type U0 = Either Int T.Text -type U1 = Either I0 U0 -type U2 = Either I1 U1 -type U3 = Either I2 U2 -type U4 = Either I3 U3 -type U5 = Either I4 U4 -type U6 = Either I5 U5 -type U7 = Either I6 U6 -type U8 = Either I7 U7 -type U9 = Either I8 U8 -type U10 = Either I9 U9 - -instance FromField U0 -instance FromField U1 -instance FromField U2 -instance FromField U3 -instance FromField U4 -instance FromField U5 -instance FromField U6 -instance FromField U7 -instance FromField U8 -instance FromField U9 -instance FromField U10 - -unionTypePerformance :: [TF.Test] -unionTypePerformance = - [ testGroup "nested union" - [ testCase "decoding" $ runParser (parseField "Inside nested Either" :: Parser U10) @?= Right v10 - ] - ] - where - v10 :: U10 - v10 = - Right $ - Right $ - Right $ - Right $ - Right $ - Right $ - Right $ - Right $ - Right $ - Right $ - Right $ "Inside nested Either" - - ------------------------------------------------------------------------ -- Test harness @@ -601,7 +526,6 @@ allTests = [ testGroup "positional" positionalTests , testGroup "instances" instanceTests , testGroup "generic-conversions" genericConversionTests , testGroup "generic-field-conversions" genericFieldTests - , testGroup "union-type-performance" unionTypePerformance ] main :: IO () From 38a8597a8917c9843603e0af1a8ea6bea4030464 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 3 Sep 2022 13:42:39 +0300 Subject: [PATCH 07/20] Nix integration --- .gitignore | 1 + cabal.project | 6 ++++-- default.nix | 28 ++++++++++++++++++++++++++++ shell.nix | 33 +++++++++++++++++++++++++++++++++ 4 files changed, 66 insertions(+), 2 deletions(-) create mode 100644 default.nix create mode 100644 shell.nix diff --git a/.gitignore b/.gitignore index 8df0ac6..13df445 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,7 @@ .hpc/ dist/ dist-newstyle/ +newdist/ cabal.sandbox.config .ghc.environment.* .stack-work diff --git a/cabal.project b/cabal.project index 080ab8c..7af7f5d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,7 @@ -- http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html -packages: . --- packages: examples/ +packages: + ./ + benchmarks/ + examples/ -- tests: True diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..55a30cd --- /dev/null +++ b/default.nix @@ -0,0 +1,28 @@ +{ ghc +, doCheck ? true +, configureFlags ? [ ] +}: +let + haskellNixSrc = builtins.fetchTarball "https://github.com/input-output-hk/haskell.nix/archive/b3df33abbcb736437cb06d5f53a10f6bb271bc51.tar.gz"; + + haskellNix = import haskellNixSrc { }; + + pkgs = import haskellNix.sources.nixpkgs-unstable haskellNix.nixpkgsArgs; + +in { + inherit pkgs; + + project = pkgs.haskell-nix.cabalProject { + src = pkgs.haskell-nix.haskellLib.cleanGit { + name = "cassava"; + src = ./.; + }; + name = "cassava"; + compiler-nix-name = ghc; + index-state = "2022-09-03T00:00:00Z"; + modules = [ + { inherit doCheck configureFlags; } + ]; + }; + +} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..b3c669f --- /dev/null +++ b/shell.nix @@ -0,0 +1,33 @@ +{ doCheck ? true +, ghc ? "ghc902" +, withHoogle ? true +, configureFlags ? [ ] +}: +let + result = import ./default.nix { + inherit configureFlags doCheck ghc; + }; + + inherit (result) pkgs project; + hsPkgs = pkgs.haskell.packages.${ghc}; + +in project.shellFor { + + inherit withHoogle; + + exactDeps = true; + + # We have to add 'criterion' explicitly as it depends on 'cassava' itself, + # so it will be dropped from included dependencies and benchmarks build fails. + # https://github.com/input-output-hk/haskell.nix/blob/b3df33abbcb736437cb06d5f53a10f6bb271bc51/builder/shell-for.nix#L31-L49) + additional = ps: [ps.criterion.components.library]; + + buildInputs = [ + hsPkgs.cabal-install + hsPkgs.haskell-language-server + ]; + + LANG = "en_US.utf8"; + LC_ALL = "en_US.utf8"; + LOCALE_ARCHIVE = "${pkgs.glibcLocales}/lib/locale/locale-archive"; +} From 65d0cf113579bcf18cf433ca7e354429fe36142d Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 13 Aug 2022 14:21:25 +0300 Subject: [PATCH 08/20] Add benchmark --- benchmarks/Benchmarks.hs | 2 + benchmarks/Generic/Prefix.hs | 8 ++ benchmarks/Generic/U16.hs | 86 +++++++++++++++++++++ benchmarks/Generic/U2.hs | 49 ++++++++++++ benchmarks/Generic/U32.hs | 130 ++++++++++++++++++++++++++++++++ benchmarks/Generic/U4.hs | 53 +++++++++++++ benchmarks/Generic/U8.hs | 64 ++++++++++++++++ benchmarks/GenericFieldBench.hs | 112 +++++++++++++++++++++++++++ benchmarks/cassava-iut.cabal | 15 +++- 9 files changed, 518 insertions(+), 1 deletion(-) create mode 100644 benchmarks/Generic/Prefix.hs create mode 100644 benchmarks/Generic/U16.hs create mode 100644 benchmarks/Generic/U2.hs create mode 100644 benchmarks/Generic/U32.hs create mode 100644 benchmarks/Generic/U4.hs create mode 100644 benchmarks/Generic/U8.hs create mode 100644 benchmarks/GenericFieldBench.hs diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs index 89a5e51..58de68e 100644 --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -20,6 +20,7 @@ import qualified Data.Vector as V import Data.Csv import qualified Data.Csv.Streaming as Streaming +import GenericFieldBench #if !MIN_VERSION_bytestring(0,10,0) instance NFData (B.ByteString) where @@ -135,6 +136,7 @@ main = do , bgroup "comparison" [ bench "lazy-csv" $ nf LazyCsv.parseCSV csvData ] + , genericFieldBench ] where decodePresidents :: BL.ByteString -> Either String (Vector President) diff --git a/benchmarks/Generic/Prefix.hs b/benchmarks/Generic/Prefix.hs new file mode 100644 index 0000000..ecb455f --- /dev/null +++ b/benchmarks/Generic/Prefix.hs @@ -0,0 +1,8 @@ +module Generic.Prefix where + +import qualified Data.List as List +import Data.Maybe + + +dropPrefix :: String -> String -> String +dropPrefix pfx = fromMaybe (error "invalid prefix") . List.stripPrefix pfx diff --git a/benchmarks/Generic/U16.hs b/benchmarks/Generic/U16.hs new file mode 100644 index 0000000..fca048b --- /dev/null +++ b/benchmarks/Generic/U16.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Generic.U16 + ( U16 + , U16Generic + , U16GenericStripPrefix + ) where + +import Control.DeepSeq +import Data.Csv +import Data.Typeable +import Generic.Prefix +import GHC.Generics (Generic) + + +data U16 + = U16ManualXXXXXX01 | U16ManualXXXXXX02 | U16ManualXXXXXX03 | U16ManualXXXXXX04 + | U16ManualXXXXXX05 | U16ManualXXXXXX06 | U16ManualXXXXXX07 | U16ManualXXXXXX08 + | U16ManualXXXXXX09 | U16ManualXXXXXX10 | U16ManualXXXXXX11 | U16ManualXXXXXX12 + | U16ManualXXXXXX13 | U16ManualXXXXXX14 | U16ManualXXXXXX15 | U16ManualXXXXXX16 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U16 where + parseField s = case s of + "XXXXXX01" -> pure U16ManualXXXXXX01 + "XXXXXX02" -> pure U16ManualXXXXXX02 + "XXXXXX03" -> pure U16ManualXXXXXX03 + "XXXXXX04" -> pure U16ManualXXXXXX04 + "XXXXXX05" -> pure U16ManualXXXXXX05 + "XXXXXX06" -> pure U16ManualXXXXXX06 + "XXXXXX07" -> pure U16ManualXXXXXX07 + "XXXXXX08" -> pure U16ManualXXXXXX08 + "XXXXXX09" -> pure U16ManualXXXXXX09 + "XXXXXX10" -> pure U16ManualXXXXXX10 + "XXXXXX11" -> pure U16ManualXXXXXX11 + "XXXXXX12" -> pure U16ManualXXXXXX12 + "XXXXXX13" -> pure U16ManualXXXXXX13 + "XXXXXX14" -> pure U16ManualXXXXXX14 + "XXXXXX15" -> pure U16ManualXXXXXX15 + "XXXXXX16" -> pure U16ManualXXXXXX16 + _ -> fail "No parse" + +instance ToField U16 where + toField x = case x of + U16ManualXXXXXX01 -> "XXXXXX01" + U16ManualXXXXXX02 -> "XXXXXX02" + U16ManualXXXXXX03 -> "XXXXXX03" + U16ManualXXXXXX04 -> "XXXXXX04" + U16ManualXXXXXX05 -> "XXXXXX05" + U16ManualXXXXXX06 -> "XXXXXX06" + U16ManualXXXXXX07 -> "XXXXXX07" + U16ManualXXXXXX08 -> "XXXXXX08" + U16ManualXXXXXX09 -> "XXXXXX09" + U16ManualXXXXXX10 -> "XXXXXX10" + U16ManualXXXXXX11 -> "XXXXXX11" + U16ManualXXXXXX12 -> "XXXXXX12" + U16ManualXXXXXX13 -> "XXXXXX13" + U16ManualXXXXXX14 -> "XXXXXX14" + U16ManualXXXXXX15 -> "XXXXXX15" + U16ManualXXXXXX16 -> "XXXXXX16" + +data U16Generic + = XXXXXX01 | XXXXXX02 | XXXXXX03 | XXXXXX04 + | XXXXXX05 | XXXXXX06 | XXXXXX07 | XXXXXX08 + | XXXXXX09 | XXXXXX10 | XXXXXX11 | XXXXXX12 + | XXXXXX13 | XXXXXX14 | XXXXXX15 | XXXXXX16 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U16Generic + +instance ToField U16Generic + +data U16GenericStripPrefix + = U16XXXXXX01 | U16XXXXXX02 | U16XXXXXX03 | U16XXXXXX04 + | U16XXXXXX05 | U16XXXXXX06 | U16XXXXXX07 | U16XXXXXX08 + | U16XXXXXX09 | U16XXXXXX10 | U16XXXXXX11 | U16XXXXXX12 + | U16XXXXXX13 | U16XXXXXX14 | U16XXXXXX15 | U16XXXXXX16 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U16GenericStripPrefix where + parseField = genericParseField defaultOptions{fieldLabelModifier = dropPrefix "U16"} + +instance ToField U16GenericStripPrefix where + toField = genericToField defaultOptions{fieldLabelModifier = dropPrefix "U16"} diff --git a/benchmarks/Generic/U2.hs b/benchmarks/Generic/U2.hs new file mode 100644 index 0000000..1a76428 --- /dev/null +++ b/benchmarks/Generic/U2.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Generic.U2 + ( U2 + , U2Generic + , U2GenericStripPrefix + ) where + +import Control.DeepSeq +import Data.Csv +import Data.Typeable +import Generic.Prefix +import GHC.Generics (Generic) + + +data U2 + = U2ManualXXXXXX01 | U2ManualXXXXXX02 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U2 where + parseField s = case s of + "XXXXXX01" -> pure U2ManualXXXXXX01 + "XXXXXX02" -> pure U2ManualXXXXXX02 + _ -> fail "No parse" + +instance ToField U2 where + toField x = case x of + U2ManualXXXXXX01 -> "XXXXXX01" + U2ManualXXXXXX02 -> "XXXXXX02" + +data U2Generic + = XXXXXX01 | XXXXXX02 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U2Generic + +instance ToField U2Generic + +data U2GenericStripPrefix + = U2XXXXXX01 | U2XXXXXX02 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U2GenericStripPrefix where + parseField = genericParseField defaultOptions{fieldLabelModifier = dropPrefix "U2"} + +instance ToField U2GenericStripPrefix where + toField = genericToField defaultOptions{fieldLabelModifier = dropPrefix "U2"} diff --git a/benchmarks/Generic/U32.hs b/benchmarks/Generic/U32.hs new file mode 100644 index 0000000..6d65114 --- /dev/null +++ b/benchmarks/Generic/U32.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Generic.U32 + ( U32 + , U32Generic + , U32GenericStripPrefix + ) where + +import Control.DeepSeq +import Data.Csv +import Data.Typeable +import Generic.Prefix +import GHC.Generics (Generic) + + +data U32 + = U32ManualXXXXXX01 | U32ManualXXXXXX02 | U32ManualXXXXXX03 | U32ManualXXXXXX04 + | U32ManualXXXXXX05 | U32ManualXXXXXX06 | U32ManualXXXXXX07 | U32ManualXXXXXX08 + | U32ManualXXXXXX09 | U32ManualXXXXXX10 | U32ManualXXXXXX11 | U32ManualXXXXXX12 + | U32ManualXXXXXX13 | U32ManualXXXXXX14 | U32ManualXXXXXX15 | U32ManualXXXXXX16 + | U32ManualXXXXXX17 | U32ManualXXXXXX18 | U32ManualXXXXXX19 | U32ManualXXXXXX20 + | U32ManualXXXXXX21 | U32ManualXXXXXX22 | U32ManualXXXXXX23 | U32ManualXXXXXX24 + | U32ManualXXXXXX25 | U32ManualXXXXXX26 | U32ManualXXXXXX27 | U32ManualXXXXXX28 + | U32ManualXXXXXX29 | U32ManualXXXXXX30 | U32ManualXXXXXX31 | U32ManualXXXXXX32 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U32 where + parseField s = case s of + "XXXXXX01" -> pure U32ManualXXXXXX01 + "XXXXXX02" -> pure U32ManualXXXXXX02 + "XXXXXX03" -> pure U32ManualXXXXXX03 + "XXXXXX04" -> pure U32ManualXXXXXX04 + "XXXXXX05" -> pure U32ManualXXXXXX05 + "XXXXXX06" -> pure U32ManualXXXXXX06 + "XXXXXX07" -> pure U32ManualXXXXXX07 + "XXXXXX08" -> pure U32ManualXXXXXX08 + "XXXXXX09" -> pure U32ManualXXXXXX09 + "XXXXXX10" -> pure U32ManualXXXXXX10 + "XXXXXX11" -> pure U32ManualXXXXXX11 + "XXXXXX12" -> pure U32ManualXXXXXX12 + "XXXXXX13" -> pure U32ManualXXXXXX13 + "XXXXXX14" -> pure U32ManualXXXXXX14 + "XXXXXX15" -> pure U32ManualXXXXXX15 + "XXXXXX16" -> pure U32ManualXXXXXX16 + "XXXXXX17" -> pure U32ManualXXXXXX17 + "XXXXXX18" -> pure U32ManualXXXXXX18 + "XXXXXX19" -> pure U32ManualXXXXXX19 + "XXXXXX20" -> pure U32ManualXXXXXX20 + "XXXXXX21" -> pure U32ManualXXXXXX21 + "XXXXXX22" -> pure U32ManualXXXXXX22 + "XXXXXX23" -> pure U32ManualXXXXXX23 + "XXXXXX24" -> pure U32ManualXXXXXX24 + "XXXXXX25" -> pure U32ManualXXXXXX25 + "XXXXXX26" -> pure U32ManualXXXXXX26 + "XXXXXX27" -> pure U32ManualXXXXXX27 + "XXXXXX28" -> pure U32ManualXXXXXX28 + "XXXXXX29" -> pure U32ManualXXXXXX29 + "XXXXXX30" -> pure U32ManualXXXXXX30 + "XXXXXX31" -> pure U32ManualXXXXXX31 + "XXXXXX32" -> pure U32ManualXXXXXX32 + _ -> fail "No parse" + +instance ToField U32 where + toField x = case x of + U32ManualXXXXXX01 -> "XXXXXX01" + U32ManualXXXXXX02 -> "XXXXXX02" + U32ManualXXXXXX03 -> "XXXXXX03" + U32ManualXXXXXX04 -> "XXXXXX04" + U32ManualXXXXXX05 -> "XXXXXX05" + U32ManualXXXXXX06 -> "XXXXXX06" + U32ManualXXXXXX07 -> "XXXXXX07" + U32ManualXXXXXX08 -> "XXXXXX08" + U32ManualXXXXXX09 -> "XXXXXX09" + U32ManualXXXXXX10 -> "XXXXXX10" + U32ManualXXXXXX11 -> "XXXXXX11" + U32ManualXXXXXX12 -> "XXXXXX12" + U32ManualXXXXXX13 -> "XXXXXX13" + U32ManualXXXXXX14 -> "XXXXXX14" + U32ManualXXXXXX15 -> "XXXXXX15" + U32ManualXXXXXX16 -> "XXXXXX16" + U32ManualXXXXXX17 -> "XXXXXX17" + U32ManualXXXXXX18 -> "XXXXXX18" + U32ManualXXXXXX19 -> "XXXXXX19" + U32ManualXXXXXX20 -> "XXXXXX20" + U32ManualXXXXXX21 -> "XXXXXX21" + U32ManualXXXXXX22 -> "XXXXXX22" + U32ManualXXXXXX23 -> "XXXXXX23" + U32ManualXXXXXX24 -> "XXXXXX24" + U32ManualXXXXXX25 -> "XXXXXX25" + U32ManualXXXXXX26 -> "XXXXXX26" + U32ManualXXXXXX27 -> "XXXXXX27" + U32ManualXXXXXX28 -> "XXXXXX28" + U32ManualXXXXXX29 -> "XXXXXX29" + U32ManualXXXXXX30 -> "XXXXXX30" + U32ManualXXXXXX31 -> "XXXXXX31" + U32ManualXXXXXX32 -> "XXXXXX32" + +data U32Generic + = XXXXXX01 | XXXXXX02 | XXXXXX03 | XXXXXX04 + | XXXXXX05 | XXXXXX06 | XXXXXX07 | XXXXXX08 + | XXXXXX09 | XXXXXX10 | XXXXXX11 | XXXXXX12 + | XXXXXX13 | XXXXXX14 | XXXXXX15 | XXXXXX16 + | XXXXXX17 | XXXXXX18 | XXXXXX19 | XXXXXX20 + | XXXXXX21 | XXXXXX22 | XXXXXX23 | XXXXXX24 + | XXXXXX25 | XXXXXX26 | XXXXXX27 | XXXXXX28 + | XXXXXX29 | XXXXXX30 | XXXXXX31 | XXXXXX32 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U32Generic + +instance ToField U32Generic + +data U32GenericStripPrefix + = U32XXXXXX01 | U32XXXXXX02 | U32XXXXXX03 | U32XXXXXX04 + | U32XXXXXX05 | U32XXXXXX06 | U32XXXXXX07 | U32XXXXXX08 + | U32XXXXXX09 | U32XXXXXX10 | U32XXXXXX11 | U32XXXXXX12 + | U32XXXXXX13 | U32XXXXXX14 | U32XXXXXX15 | U32XXXXXX16 + | U32XXXXXX17 | U32XXXXXX18 | U32XXXXXX19 | U32XXXXXX20 + | U32XXXXXX21 | U32XXXXXX22 | U32XXXXXX23 | U32XXXXXX24 + | U32XXXXXX25 | U32XXXXXX26 | U32XXXXXX27 | U32XXXXXX28 + | U32XXXXXX29 | U32XXXXXX30 | U32XXXXXX31 | U32XXXXXX32 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U32GenericStripPrefix where + parseField = genericParseField defaultOptions{fieldLabelModifier = dropPrefix "U32"} + +instance ToField U32GenericStripPrefix where + toField = genericToField defaultOptions{fieldLabelModifier = dropPrefix "U32"} diff --git a/benchmarks/Generic/U4.hs b/benchmarks/Generic/U4.hs new file mode 100644 index 0000000..b12b991 --- /dev/null +++ b/benchmarks/Generic/U4.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Generic.U4 + ( U4 + , U4Generic + , U4GenericStripPrefix + ) where + +import Control.DeepSeq +import Data.Csv +import Data.Typeable +import Generic.Prefix +import GHC.Generics (Generic) + + +data U4 + = U4ManualXXXXXX01 | U4ManualXXXXXX02 | U4ManualXXXXXX03 | U4ManualXXXXXX04 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U4 where + parseField s = case s of + "XXXXXX01" -> pure U4ManualXXXXXX01 + "XXXXXX02" -> pure U4ManualXXXXXX02 + "XXXXXX03" -> pure U4ManualXXXXXX03 + "XXXXXX04" -> pure U4ManualXXXXXX04 + _ -> fail "No parse" + +instance ToField U4 where + toField x = case x of + U4ManualXXXXXX01 -> "XXXXXX01" + U4ManualXXXXXX02 -> "XXXXXX02" + U4ManualXXXXXX03 -> "XXXXXX03" + U4ManualXXXXXX04 -> "XXXXXX04" + +data U4Generic + = XXXXXX01 | XXXXXX02 | XXXXXX03 | XXXXXX04 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U4Generic + +instance ToField U4Generic + +data U4GenericStripPrefix + = U4XXXXXX01 | U4XXXXXX02 | U4XXXXXX03 | U4XXXXXX04 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U4GenericStripPrefix where + parseField = genericParseField defaultOptions{fieldLabelModifier = dropPrefix "U4"} + +instance ToField U4GenericStripPrefix where + toField = genericToField defaultOptions{fieldLabelModifier = dropPrefix "U4"} diff --git a/benchmarks/Generic/U8.hs b/benchmarks/Generic/U8.hs new file mode 100644 index 0000000..ce2db6a --- /dev/null +++ b/benchmarks/Generic/U8.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Generic.U8 + ( U8 + , U8Generic + , U8GenericStripPrefix + ) where + +import Control.DeepSeq +import Data.Csv +import Data.Typeable +import Generic.Prefix +import GHC.Generics (Generic) + + +data U8 + = U8ManualXXXXXX01 | U8ManualXXXXXX02 | U8ManualXXXXXX03 | U8ManualXXXXXX04 + | U8ManualXXXXXX05 | U8ManualXXXXXX06 | U8ManualXXXXXX07 | U8ManualXXXXXX08 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U8 where + parseField s = case s of + "XXXXXX01" -> pure U8ManualXXXXXX01 + "XXXXXX02" -> pure U8ManualXXXXXX02 + "XXXXXX03" -> pure U8ManualXXXXXX03 + "XXXXXX04" -> pure U8ManualXXXXXX04 + "XXXXXX05" -> pure U8ManualXXXXXX05 + "XXXXXX06" -> pure U8ManualXXXXXX06 + "XXXXXX07" -> pure U8ManualXXXXXX07 + "XXXXXX08" -> pure U8ManualXXXXXX08 + _ -> fail "No parse" + +instance ToField U8 where + toField x = case x of + U8ManualXXXXXX01 -> "XXXXXX01" + U8ManualXXXXXX02 -> "XXXXXX02" + U8ManualXXXXXX03 -> "XXXXXX03" + U8ManualXXXXXX04 -> "XXXXXX04" + U8ManualXXXXXX05 -> "XXXXXX05" + U8ManualXXXXXX06 -> "XXXXXX06" + U8ManualXXXXXX07 -> "XXXXXX07" + U8ManualXXXXXX08 -> "XXXXXX08" + +data U8Generic + = XXXXXX01 | XXXXXX02 | XXXXXX03 | XXXXXX04 + | XXXXXX05 | XXXXXX06 | XXXXXX07 | XXXXXX08 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U8Generic + +instance ToField U8Generic + +data U8GenericStripPrefix + = U8XXXXXX01 | U8XXXXXX02 | U8XXXXXX03 | U8XXXXXX04 + | U8XXXXXX05 | U8XXXXXX06 | U8XXXXXX07 | U8XXXXXX08 + deriving (Bounded, Enum, Generic, NFData, Show, Typeable) + +instance FromField U8GenericStripPrefix where + parseField = genericParseField defaultOptions{fieldLabelModifier = dropPrefix "U8"} + +instance ToField U8GenericStripPrefix where + toField = genericToField defaultOptions{fieldLabelModifier = dropPrefix "U8"} diff --git a/benchmarks/GenericFieldBench.hs b/benchmarks/GenericFieldBench.hs new file mode 100644 index 0000000..49f7749 --- /dev/null +++ b/benchmarks/GenericFieldBench.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeApplications #-} + +module GenericFieldBench + ( genericFieldBench + ) where + +import Control.DeepSeq +import Criterion +import Data.Csv +import Data.Proxy +import Data.Typeable +import Generic.U2 +import Generic.U4 +import Generic.U8 +import Generic.U16 +import Generic.U32 + + +genericFieldBench :: Benchmark +genericFieldBench = bgroup "genericField" + [ bgroup "parseField: ok" + [ mkParseSuccessBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix) + , mkParseSuccessBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix) + , mkParseSuccessBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix) + , mkParseSuccessBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix) + , mkParseSuccessBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix) + ] + , bgroup "parseField: fail" + [ mkParseFailBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix) + , mkParseFailBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix) + , mkParseFailBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix) + , mkParseFailBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix) + , mkParseFailBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix) + ] + , bgroup "toField" + [ mkToFieldBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix) + , mkToFieldBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix) + , mkToFieldBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix) + , mkToFieldBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix) + , mkToFieldBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix) + ] + ] + +type IsBench a = (Bounded a, Enum a, FromField a, ToField a, NFData a) + +mkParseSuccessBench + :: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix) + => Proxy a + -> Proxy generic + -> Proxy genericWithPrefix + -> Benchmark +mkParseSuccessBench px pxGen pxGenPfx = bgroup (show $ typeRep px) + [ mkB "manual" px + , mkB "generic" pxGen + , mkB "generic with prefix" pxGenPfx + ] + where + {- + NB: this all is about sum representations. + Manual instance tries to parse constructors from left to right, + so parsing the string matching the first constructor is the best case, + while parsing the last matcher is the worst case. + Generic representation is, however, not that flat (one can check that by + exploring 'Rep' of U32) and is more like a balanced binary tree with root + being somewhere around U32_16 constructor (rough estimation). + To level this discrepency and compare parsing efficiency more accurately + we parse the whole range @[minBound..maxBound]@ of possible values for a type. + This corresponds to the situation where data values are uniformly distributed. + -} + mkB + :: (Bounded a, Enum a, FromField a, ToField a, NFData a) + => String -> Proxy a -> Benchmark + mkB name p = env (pure $ map toField $ genEnum p) $ bench name . nf (go p) + go :: (FromField a) => Proxy a -> [Field] -> [a] + go p = map $ ((\(Right x) -> x `asProxyTypeOf` p) . parse) + +mkParseFailBench + :: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix) + => Proxy a + -> Proxy generic + -> Proxy genericWithPrefix + -> Benchmark +mkParseFailBench px pxg pxgp = bgroup (show $ typeRep px) + [ bench "manual" $ whnf (\s -> parse s `asProxyEither` px) mempty + , bench "generic" $ whnf (\s -> parse s `asProxyEither` pxg) mempty + , bench "generic with prefix" $ whnf (\s -> parse s `asProxyEither` pxgp) mempty + ] + +asProxyEither :: Either String a -> Proxy a -> Either String a +asProxyEither = const + +mkToFieldBench + :: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix) + => Proxy a + -> Proxy generic + -> Proxy genericWithPrefix + -> Benchmark +mkToFieldBench px pxg pxgp = bgroup (show $ typeRep px) + [ mkB "manual" px + , mkB "generic" pxg + , mkB "generic with prefix" pxgp + ] + where + mkB :: (Bounded a, Enum a, ToField a) => String -> Proxy a -> Benchmark + mkB name = bench name . nf (map toField) . genEnum + +parse :: (FromField a) => Field -> Either String a +parse = runParser . parseField + +genEnum :: (Bounded a, Enum a) => Proxy a -> [a] +genEnum _ = [minBound..maxBound] diff --git a/benchmarks/cassava-iut.cabal b/benchmarks/cassava-iut.cabal index 2f82936..71c467c 100644 --- a/benchmarks/cassava-iut.cabal +++ b/benchmarks/cassava-iut.cabal @@ -62,6 +62,7 @@ Library containers >= 0.4.2 && < 0.7, deepseq >= 1.1 && < 1.5, hashable < 1.5, + scientific, text < 2.1, unordered-containers < 0.3, vector >= 0.8 && < 0.14, @@ -90,7 +91,7 @@ Library ghc-options: -Wall -O2 - hs-source-dirs: ../ + hs-source-dirs: ../src ---------------------------------------------------------------------------- @@ -99,6 +100,12 @@ Benchmark benchmark-iut Type: exitcode-stdio-1.0 Main-is: Benchmarks.hs + other-modules: GenericFieldBench + Generic.U2 + Generic.U4 + Generic.U8 + Generic.U16 + Generic.U32 -- dependencies with version constraints inherited via lib:cassava-iut build-depends: base @@ -120,6 +127,12 @@ Benchmark benchmark-ref Type: exitcode-stdio-1.0 Main-is: Benchmarks.hs + other-modules: GenericFieldBench + Generic.U2 + Generic.U4 + Generic.U8 + Generic.U16 + Generic.U32 -- dependencies with version constraints inherited via lib:cassava-iut build-depends: base From 31a50401f662760b0b3d8086513ba12a2451f4d7 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 13 Aug 2022 15:27:17 +0300 Subject: [PATCH 09/20] INLINE: from 10x slower to 3x slower --- src/Data/Csv/Conversion.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index b994e66..bc71f36 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -764,9 +764,11 @@ class FromField a where default parseField :: (Generic a, GFromField (Rep a)) => Field -> Parser a parseField = genericParseField defaultOptions + {-# INLINE parseField #-} genericParseField :: (Generic a, GFromField (Rep a)) => Options -> Field -> Parser a genericParseField opts = fmap to . gParseField opts +{-# INLINE genericParseField #-} -- | A type that can be converted to a single CSV field. -- @@ -785,9 +787,11 @@ class ToField a where default toField :: (Generic a, GToField (Rep a)) => a -> Field toField = genericToField defaultOptions + {-# INLINE toField #-} genericToField :: (Generic a, GToField (Rep a)) => Options -> a -> Field genericToField opts = gToField opts . from +{-# INLINE genericToField #-} -- | 'Nothing' if the 'Field' is 'B.empty', 'Just' otherwise. instance FromField a => FromField (Maybe a) where @@ -1390,6 +1394,7 @@ class GFromField f where -- Type with single nullary constructor instance (Constructor c) => GFromField (D1 meta (C1 c U1)) where gParseField opts = fmap M1 . gParseField' opts + {-# INLINE gParseField #-} -- Sum type with nullary or unary constructors instance (Datatype t, GFromField' c1, GFromField' c2) => GFromField (D1 t (c1 :+: c2)) where @@ -1400,6 +1405,7 @@ instance (Datatype t, GFromField' c1, GFromField' c2) => GFromField (D1 t (c1 :+ where errMsg = "Can't parse " <> datatypeName (Proxy :: Proxy t d f) <> " from " <> show field + {-# INLINE gParseField #-} class GToField f where gToField :: Options -> f p -> Field @@ -1407,11 +1413,13 @@ class GToField f where -- Type with single nullary constructor instance (Constructor c) => GToField (D1 meta (C1 c U1)) where gToField opts = gToField' opts . unM1 + {-# INLINE gToField #-} -- Sum type with nullary or unary constructors instance (GToField' c1, GToField' c2) => GToField (D1 t (c1 :+: c2)) where gToField opts (M1 (L1 val)) = gToField' opts val gToField opts (M1 (R1 val)) = gToField' opts val + {-# INLINE gToField #-} -- Helper classes for FromField/ToField @@ -1426,15 +1434,18 @@ instance (Constructor c) => GFromField' (C1 c U1) where expected = encodeConstructor opts val val :: C1 c U1 p val = M1 U1 + {-# INLINE gParseField' #-} -- Unary constructor instance (FromField a) => GFromField' (C1 c (S1 meta (K1 i a))) where gParseField' _ = fmap (M1 . M1 . K1) . parseField + {-# INLINE gParseField' #-} -- Sum instance (GFromField' c1, GFromField' c2) => GFromField' (c1 :+: c2) where gParseField' opts field = fmap L1 (gParseField' opts field) <|> fmap R1 (gParseField' opts field) + {-# INLINE gParseField' #-} class GToField' f where gToField' :: Options -> f p -> Field @@ -1442,18 +1453,22 @@ class GToField' f where -- Nullary constructor instance (Constructor c) => GToField' (C1 c U1) where gToField' = encodeConstructor + {-# INLINE gToField' #-} -- Unary constructor instance (ToField a) => GToField' (C1 c (S1 meta (K1 i a))) where gToField' _ = toField . unK1 . unM1 . unM1 + {-# INLINE gToField' #-} -- Sum instance (GToField' c1, GToField' c2) => GToField' (c1 :+: c2) where gToField' opts (L1 val) = gToField' opts val gToField' opts (R1 val) = gToField' opts val + {-# INLINE gToField' #-} encodeConstructor :: (Constructor c) => Options -> C1 c f p -> B.ByteString encodeConstructor opts = T.encodeUtf8 . T.pack . fieldLabelModifier opts . conName +{-# INLINE encodeConstructor #-} -- We statically fail on sum types and product types without selectors -- (field names). From 7bef6296000ac46c1965d67207e65dd491a61340 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 13 Aug 2022 16:43:46 +0300 Subject: [PATCH 10/20] Get rid of helper class --- src/Data/Csv/Conversion.hs | 105 ++++++++++++++----------------------- 1 file changed, 38 insertions(+), 67 deletions(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index bc71f36..e33575e 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -9,6 +9,7 @@ OverloadedStrings, Rank2Types, ScopedTypeVariables, + TypeFamilies, TypeOperators, UndecidableInstances #-} @@ -762,12 +763,17 @@ parseBoth (k, v) = (,) <$> parseField k <*> parseField v class FromField a where parseField :: Field -> Parser a - default parseField :: (Generic a, GFromField (Rep a)) => Field -> Parser a + default parseField + :: (Generic a, GFromField rep, Rep a ~ D1 meta rep, Datatype meta) + => Field -> Parser a parseField = genericParseField defaultOptions {-# INLINE parseField #-} -genericParseField :: (Generic a, GFromField (Rep a)) => Options -> Field -> Parser a -genericParseField opts = fmap to . gParseField opts +genericParseField + :: forall a rep meta. (Generic a, GFromField rep, Rep a ~ D1 meta rep, Datatype meta) + => Options -> Field -> Parser a +genericParseField opts field = fmap (to . M1) (gParseField opts field) + <|> fail ("Can't parseField for " <> datatypeName (Proxy :: Proxy meta d f)) {-# INLINE genericParseField #-} -- | A type that can be converted to a single CSV field. @@ -785,12 +791,12 @@ genericParseField opts = fmap to . gParseField opts class ToField a where toField :: a -> Field - default toField :: (Generic a, GToField (Rep a)) => a -> Field + default toField :: (Generic a, GToField rep, Rep a ~ D1 meta rep) => a -> Field toField = genericToField defaultOptions {-# INLINE toField #-} -genericToField :: (Generic a, GToField (Rep a)) => Options -> a -> Field -genericToField opts = gToField opts . from +genericToField :: (Generic a, GToField rep, Rep a ~ D1 meta rep) => Options -> a -> Field +genericToField opts = gToField opts . unM1 . from {-# INLINE genericToField #-} -- | 'Nothing' if the 'Field' is 'B.empty', 'Just' otherwise. @@ -1392,79 +1398,44 @@ class GFromField f where gParseField :: Options -> Field -> Parser (f p) -- Type with single nullary constructor -instance (Constructor c) => GFromField (D1 meta (C1 c U1)) where - gParseField opts = fmap M1 . gParseField' opts +instance (Constructor c) => GFromField (C1 c U1) where + gParseField opts field = do + if field == expected then pure val else mempty + where + expected = encodeConstructor opts val + val :: C1 c U1 p + val = M1 U1 {-# INLINE gParseField #-} --- Sum type with nullary or unary constructors -instance (Datatype t, GFromField' c1, GFromField' c2) => GFromField (D1 t (c1 :+: c2)) where - gParseField opts field = fmap M1 $ - (L1 <$> gParseField' opts field) - <|> (R1 <$> gParseField' opts field) - <|> fail errMsg - where - errMsg = - "Can't parse " <> datatypeName (Proxy :: Proxy t d f) <> " from " <> show field +-- Type with single unary constructor +instance (FromField a) => GFromField (C1 c (S1 meta (K1 i a))) where + gParseField _ = fmap (M1 . M1 . K1) . parseField + {-# INLINE gParseField #-} + +-- Sum type +instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where + gParseField opts field = + fmap L1 (gParseField opts field) <|> fmap R1 (gParseField opts field) {-# INLINE gParseField #-} class GToField f where gToField :: Options -> f p -> Field -- Type with single nullary constructor -instance (Constructor c) => GToField (D1 meta (C1 c U1)) where - gToField opts = gToField' opts . unM1 +instance (Constructor c) => GToField (C1 c U1) where + gToField = encodeConstructor {-# INLINE gToField #-} --- Sum type with nullary or unary constructors -instance (GToField' c1, GToField' c2) => GToField (D1 t (c1 :+: c2)) where - gToField opts (M1 (L1 val)) = gToField' opts val - gToField opts (M1 (R1 val)) = gToField' opts val +--- Type with single unary constructor +instance (ToField a) => GToField (C1 c (S1 meta (K1 i a))) where + gToField _ = toField . unK1 . unM1 . unM1 {-# INLINE gToField #-} --- Helper classes for FromField/ToField - -class GFromField' f where - gParseField' :: Options -> Field -> Parser (f p) - --- Nullary constructor -instance (Constructor c) => GFromField' (C1 c U1) where - gParseField' opts field = do - if field == expected then pure val else fail $ "Expected " <> show expected - where - expected = encodeConstructor opts val - val :: C1 c U1 p - val = M1 U1 - {-# INLINE gParseField' #-} - --- Unary constructor -instance (FromField a) => GFromField' (C1 c (S1 meta (K1 i a))) where - gParseField' _ = fmap (M1 . M1 . K1) . parseField - {-# INLINE gParseField' #-} - --- Sum -instance (GFromField' c1, GFromField' c2) => GFromField' (c1 :+: c2) where - gParseField' opts field = - fmap L1 (gParseField' opts field) <|> fmap R1 (gParseField' opts field) - {-# INLINE gParseField' #-} - -class GToField' f where - gToField' :: Options -> f p -> Field - --- Nullary constructor -instance (Constructor c) => GToField' (C1 c U1) where - gToField' = encodeConstructor - {-# INLINE gToField' #-} - --- Unary constructor -instance (ToField a) => GToField' (C1 c (S1 meta (K1 i a))) where - gToField' _ = toField . unK1 . unM1 . unM1 - {-# INLINE gToField' #-} - --- Sum -instance (GToField' c1, GToField' c2) => GToField' (c1 :+: c2) where - gToField' opts (L1 val) = gToField' opts val - gToField' opts (R1 val) = gToField' opts val - {-# INLINE gToField' #-} +-- Sum type +instance (GToField c1, GToField c2) => GToField (c1 :+: c2) where + gToField opts (L1 val) = gToField opts val + gToField opts (R1 val) = gToField opts val + {-# INLINE gToField #-} encodeConstructor :: (Constructor c) => Options -> C1 c f p -> B.ByteString encodeConstructor opts = T.encodeUtf8 . T.pack . fieldLabelModifier opts . conName From d6c02e292dc961bfec23b074560d66d3cf5b9aa9 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 13 Aug 2022 18:54:17 +0300 Subject: [PATCH 11/20] Manual: 2x slower --- src/Data/Csv/Conversion.hs | 22 ++++++++++++++-------- tests/UnitTests.hs | 2 +- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index e33575e..023b3f0 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -772,8 +772,9 @@ class FromField a where genericParseField :: forall a rep meta. (Generic a, GFromField rep, Rep a ~ D1 meta rep, Datatype meta) => Options -> Field -> Parser a -genericParseField opts field = fmap (to . M1) (gParseField opts field) - <|> fail ("Can't parseField for " <> datatypeName (Proxy :: Proxy meta d f)) +genericParseField opts field = fmap (to . M1) (gParseField opts onFail field) + where + onFail _ = fail $ "Can't parseField of type " <> datatypeName (Proxy :: Proxy meta d f) {-# INLINE genericParseField #-} -- | A type that can be converted to a single CSV field. @@ -1395,12 +1396,12 @@ instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B name = T.encodeUtf8 (T.pack (fieldLabelModifier opts (selName m))) class GFromField f where - gParseField :: Options -> Field -> Parser (f p) + gParseField :: Options -> (Field -> Parser (f p)) -> Field -> Parser (f p) -- Type with single nullary constructor instance (Constructor c) => GFromField (C1 c U1) where - gParseField opts field = do - if field == expected then pure val else mempty + gParseField opts onFail field = do + if field == expected then pure val else onFail field where expected = encodeConstructor opts val val :: C1 c U1 p @@ -1409,13 +1410,18 @@ instance (Constructor c) => GFromField (C1 c U1) where -- Type with single unary constructor instance (FromField a) => GFromField (C1 c (S1 meta (K1 i a))) where - gParseField _ = fmap (M1 . M1 . K1) . parseField + gParseField _ onFail field = + fmap (M1 . M1 . K1) (parseField field) <|> onFail field {-# INLINE gParseField #-} -- Sum type instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where - gParseField opts field = - fmap L1 (gParseField opts field) <|> fmap R1 (gParseField opts field) + gParseField opts onFail field = + case runParser $ gParseField opts mempty field of + Left _ -> case runParser $ gParseField opts mempty field of + Left _ -> onFail field + Right res -> pure $ R1 res + Right res -> pure $ L1 res {-# INLINE gParseField #-} class GToField f where diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 21aaf7e..4db8f28 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -504,7 +504,7 @@ genericFieldTests = [ testCase "encoding" $ toField Foo @?= "Foo" , testCase "decoding" $ runParser (parseField "Foo") @?= Right Foo ] , testCase "decoding failure" $ runParser (parseField "foo") - @?= (Left "Expected \"Foo\"" :: Either String Foo) + @?= (Left "Can't parseField of type Foo" :: Either String Foo) , testProperty "sum type roundtrip" (roundtripProp :: Bar -> Bool) , testGroup "constructor modifier" [ testCase "encoding" $ toField BazOne @?= "one" From b5575b0c3507ca81b119e7d30dd31890789817a9 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Mon, 31 Oct 2022 10:05:36 +0300 Subject: [PATCH 12/20] Rewrite: almost equal performance --- src/Data/Csv/Conversion.hs | 27 ++++++++++++++------------- tests/UnitTests.hs | 2 +- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index 023b3f0..632b9a8 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -772,9 +772,11 @@ class FromField a where genericParseField :: forall a rep meta. (Generic a, GFromField rep, Rep a ~ D1 meta rep, Datatype meta) => Options -> Field -> Parser a -genericParseField opts field = fmap (to . M1) (gParseField opts onFail field) +genericParseField opts field = Parser $ \onFailure onSuccess -> + unParser (gParseField opts field) (\_ -> onFailure err) (onSuccess . to . M1) where - onFail _ = fail $ "Can't parseField of type " <> datatypeName (Proxy :: Proxy meta d f) + err = "Can't parseField of type " <> datatypeName (Proxy :: Proxy meta d f) + <> " from " <> show field {-# INLINE genericParseField #-} -- | A type that can be converted to a single CSV field. @@ -1396,12 +1398,14 @@ instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B name = T.encodeUtf8 (T.pack (fieldLabelModifier opts (selName m))) class GFromField f where - gParseField :: Options -> (Field -> Parser (f p)) -> Field -> Parser (f p) + gParseField :: Options -> Field -> Parser (f p) -- Type with single nullary constructor instance (Constructor c) => GFromField (C1 c U1) where - gParseField opts onFail field = do - if field == expected then pure val else onFail field + gParseField opts field = Parser $ \onFailure onSuccess -> + if field == expected + then onSuccess val + else onFailure $ "Can't parse " <> show expected <> " from " <> show field where expected = encodeConstructor opts val val :: C1 c U1 p @@ -1410,18 +1414,15 @@ instance (Constructor c) => GFromField (C1 c U1) where -- Type with single unary constructor instance (FromField a) => GFromField (C1 c (S1 meta (K1 i a))) where - gParseField _ onFail field = - fmap (M1 . M1 . K1) (parseField field) <|> onFail field + gParseField _opts = fmap (M1 . M1 . K1) . parseField {-# INLINE gParseField #-} -- Sum type instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where - gParseField opts onFail field = - case runParser $ gParseField opts mempty field of - Left _ -> case runParser $ gParseField opts mempty field of - Left _ -> onFail field - Right res -> pure $ R1 res - Right res -> pure $ L1 res + gParseField opts field = Parser $ \onFailure onSuccess -> + unParser (gParseField opts field) + (\_ -> unParser (gParseField opts field) onFailure $ onSuccess . R1) + (onSuccess . L1) {-# INLINE gParseField #-} class GToField f where diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 4db8f28..b82495f 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -504,7 +504,7 @@ genericFieldTests = [ testCase "encoding" $ toField Foo @?= "Foo" , testCase "decoding" $ runParser (parseField "Foo") @?= Right Foo ] , testCase "decoding failure" $ runParser (parseField "foo") - @?= (Left "Can't parseField of type Foo" :: Either String Foo) + @?= (Left "Can't parseField of type Foo from \"foo\"" :: Either String Foo) , testProperty "sum type roundtrip" (roundtripProp :: Bar -> Bool) , testGroup "constructor modifier" [ testCase "encoding" $ toField BazOne @?= "one" From 82504fc1b520b7c61ecbd338e2ad7a55f146940c Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Wed, 16 Nov 2022 13:57:27 +0300 Subject: [PATCH 13/20] Add tests for Either --- benchmarks/Generic/Either.hs | 73 +++++++++ benchmarks/GenericFieldBench.hs | 269 ++++++++++++++++++++++---------- benchmarks/cassava-iut.cabal | 4 + 3 files changed, 267 insertions(+), 79 deletions(-) create mode 100644 benchmarks/Generic/Either.hs diff --git a/benchmarks/Generic/Either.hs b/benchmarks/Generic/Either.hs new file mode 100644 index 0000000..db91728 --- /dev/null +++ b/benchmarks/Generic/Either.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Generic.Either + ( EitherManual(..) + , ManualEither0 + , ManualEither1 + , ManualEither2 + , ManualEither3 + , EitherGeneric(..) + , GenericEither0 + , GenericEither1 + , GenericEither2 + , GenericEither3 + ) where + +import Control.DeepSeq +import Data.Csv +import Data.Proxy +import Data.Typeable +import GHC.Generics (Generic) + + +data EitherManual a b = LManual a | RManual b + deriving (Generic, NFData, Show, Typeable) + +instance (FromField a, FromField b, Typeable a, Typeable b) => FromField (EitherManual a b) where + parseField field = case runParser (parseField field) of + Left _ -> case runParser (parseField field) of + Left _ -> fail $ "Can't parse field of type " + <> show (typeRep $ Proxy @(EitherManual a b)) <> " from " <> show field + Right ok -> pure $ RManual ok + Right ok -> pure $ LManual ok + +instance (ToField a, ToField b) => ToField (EitherManual a b) where + toField (LManual x) = toField x + toField (RManual x) = toField x + +data EitherGeneric a b = LGeneric a | RGeneric b + deriving (Generic, NFData, Show, Typeable) + +instance (FromField a, FromField b) => FromField (EitherGeneric a b) +instance (ToField a, ToField b) => ToField (EitherGeneric a b) + +type Either0 f = f Int Char +type Either1 f = f (Either0 f) (Either0 f) +type Either2 f = f (Either1 f) (Either1 f) +type Either3 f = f (Either2 f) (Either2 f) +type Either4 f = f (Either3 f) (Either3 f) +type Either5 f = f (Either4 f) (Either4 f) +type Either6 f = f (Either5 f) (Either5 f) +type Either7 f = f (Either6 f) (Either6 f) +type Either8 f = f (Either7 f) (Either7 f) +type Either9 f = f (Either8 f) (Either8 f) +type Either10 f = f (Either9 f) (Either9 f) +type Either11 f = f (Either10 f) (Either10 f) +type Either12 f = f (Either11 f) (Either11 f) +type Either13 f = f (Either12 f) (Either12 f) +type Either14 f = f (Either13 f) (Either13 f) +type Either15 f = f (Either14 f) (Either14 f) +type Either16 f = f (Either15 f) (Either15 f) + +type ManualEither0 = Either0 EitherManual +type ManualEither1 = Either1 EitherManual +type ManualEither2 = Either2 EitherManual +type ManualEither3 = Either3 EitherManual + +type GenericEither0 = Either0 EitherGeneric +type GenericEither1 = Either1 EitherGeneric +type GenericEither2 = Either2 EitherGeneric +type GenericEither3 = Either3 EitherGeneric diff --git a/benchmarks/GenericFieldBench.hs b/benchmarks/GenericFieldBench.hs index 49f7749..6af43da 100644 --- a/benchmarks/GenericFieldBench.hs +++ b/benchmarks/GenericFieldBench.hs @@ -10,6 +10,7 @@ import Criterion import Data.Csv import Data.Proxy import Data.Typeable +import Generic.Either import Generic.U2 import Generic.U4 import Generic.U8 @@ -19,94 +20,204 @@ import Generic.U32 genericFieldBench :: Benchmark genericFieldBench = bgroup "genericField" - [ bgroup "parseField: ok" - [ mkParseSuccessBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix) - , mkParseSuccessBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix) - , mkParseSuccessBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix) - , mkParseSuccessBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix) - , mkParseSuccessBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix) + [ bgroup "parseField:ok" + [ mkParseSuccessBench (genRange @U2) + , mkParseSuccessBench (genRange @U2Generic) + , mkParseSuccessBench (genRange @U2GenericStripPrefix) + , mkParseSuccessBench (genRange @U4) + , mkParseSuccessBench (genRange @U4Generic) + , mkParseSuccessBench (genRange @U4GenericStripPrefix) + , mkParseSuccessBench (genRange @U8) + , mkParseSuccessBench (genRange @U8Generic) + , mkParseSuccessBench (genRange @U8GenericStripPrefix) + , mkParseSuccessBench (genRange @U16) + , mkParseSuccessBench (genRange @U16Generic) + , mkParseSuccessBench (genRange @U16GenericStripPrefix) + , mkParseSuccessBench (genRange @U32) + , mkParseSuccessBench (genRange @U32Generic) + , mkParseSuccessBench (genRange @U32GenericStripPrefix) + , mkParseSuccessBench manualEither0 + , mkParseSuccessBench genericEither0 + , mkParseSuccessBench manualEither1 + , mkParseSuccessBench genericEither1 + , mkParseSuccessBench manualEither2 + , mkParseSuccessBench genericEither2 + , mkParseSuccessBench manualEither3 + , mkParseSuccessBench genericEither3 ] - , bgroup "parseField: fail" - [ mkParseFailBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix) - , mkParseFailBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix) - , mkParseFailBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix) - , mkParseFailBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix) - , mkParseFailBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix) + , bgroup "parseField:fail" + [ mkParseFailBench (Proxy @U2) + , mkParseFailBench (Proxy @U2Generic) + , mkParseFailBench (Proxy @U2GenericStripPrefix) + , mkParseFailBench (Proxy @U4) + , mkParseFailBench (Proxy @U4Generic) + , mkParseFailBench (Proxy @U4GenericStripPrefix) + , mkParseFailBench (Proxy @U8) + , mkParseFailBench (Proxy @U8Generic) + , mkParseFailBench (Proxy @U8GenericStripPrefix) + , mkParseFailBench (Proxy @U16) + , mkParseFailBench (Proxy @U16Generic) + , mkParseFailBench (Proxy @U16GenericStripPrefix) + , mkParseFailBench (Proxy @U32) + , mkParseFailBench (Proxy @U32Generic) + , mkParseFailBench (Proxy @U32GenericStripPrefix) + , mkParseFailBench (Proxy @ManualEither0) + , mkParseFailBench (Proxy @GenericEither0) + , mkParseFailBench (Proxy @ManualEither1) + , mkParseFailBench (Proxy @GenericEither1) + , mkParseFailBench (Proxy @ManualEither2) + , mkParseFailBench (Proxy @GenericEither2) + , mkParseFailBench (Proxy @ManualEither3) + , mkParseFailBench (Proxy @GenericEither3) ] , bgroup "toField" - [ mkToFieldBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix) - , mkToFieldBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix) - , mkToFieldBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix) - , mkToFieldBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix) - , mkToFieldBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix) + [ mkToFieldBench (genRange @U2) + , mkToFieldBench (genRange @U2Generic) + , mkToFieldBench (genRange @U2GenericStripPrefix) + , mkToFieldBench (genRange @U4) + , mkToFieldBench (genRange @U4Generic) + , mkToFieldBench (genRange @U4GenericStripPrefix) + , mkToFieldBench (genRange @U8) + , mkToFieldBench (genRange @U8Generic) + , mkToFieldBench (genRange @U8GenericStripPrefix) + , mkToFieldBench (genRange @U16) + , mkToFieldBench (genRange @U16Generic) + , mkToFieldBench (genRange @U16GenericStripPrefix) + , mkToFieldBench (genRange @U32) + , mkToFieldBench (genRange @U32Generic) + , mkToFieldBench (genRange @U32GenericStripPrefix) + , mkToFieldBench manualEither0 + , mkToFieldBench genericEither0 + , mkToFieldBench manualEither1 + , mkToFieldBench genericEither1 + , mkToFieldBench manualEither2 + , mkToFieldBench genericEither2 + , mkToFieldBench manualEither3 + , mkToFieldBench genericEither3 ] ] -type IsBench a = (Bounded a, Enum a, FromField a, ToField a, NFData a) - -mkParseSuccessBench - :: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix) - => Proxy a - -> Proxy generic - -> Proxy genericWithPrefix - -> Benchmark -mkParseSuccessBench px pxGen pxGenPfx = bgroup (show $ typeRep px) - [ mkB "manual" px - , mkB "generic" pxGen - , mkB "generic with prefix" pxGenPfx - ] - where - {- - NB: this all is about sum representations. - Manual instance tries to parse constructors from left to right, - so parsing the string matching the first constructor is the best case, - while parsing the last matcher is the worst case. - Generic representation is, however, not that flat (one can check that by - exploring 'Rep' of U32) and is more like a balanced binary tree with root - being somewhere around U32_16 constructor (rough estimation). - To level this discrepency and compare parsing efficiency more accurately - we parse the whole range @[minBound..maxBound]@ of possible values for a type. - This corresponds to the situation where data values are uniformly distributed. - -} - mkB - :: (Bounded a, Enum a, FromField a, ToField a, NFData a) - => String -> Proxy a -> Benchmark - mkB name p = env (pure $ map toField $ genEnum p) $ bench name . nf (go p) - go :: (FromField a) => Proxy a -> [Field] -> [a] - go p = map $ ((\(Right x) -> x `asProxyTypeOf` p) . parse) - -mkParseFailBench - :: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix) - => Proxy a - -> Proxy generic - -> Proxy genericWithPrefix - -> Benchmark -mkParseFailBench px pxg pxgp = bgroup (show $ typeRep px) - [ bench "manual" $ whnf (\s -> parse s `asProxyEither` px) mempty - , bench "generic" $ whnf (\s -> parse s `asProxyEither` pxg) mempty - , bench "generic with prefix" $ whnf (\s -> parse s `asProxyEither` pxgp) mempty - ] +type IsBench a = (FromField a, ToField a, NFData a, Typeable a) -asProxyEither :: Either String a -> Proxy a -> Either String a -asProxyEither = const - -mkToFieldBench - :: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix) - => Proxy a - -> Proxy generic - -> Proxy genericWithPrefix - -> Benchmark -mkToFieldBench px pxg pxgp = bgroup (show $ typeRep px) - [ mkB "manual" px - , mkB "generic" pxg - , mkB "generic with prefix" pxgp - ] +{- + Manual instance tries to parse constructors from left to right, + so parsing the string matching the first constructor is the best case, + while parsing the last matcher is the worst case. + Generic representation is, however, not that flat (one can check that by + exploring 'Rep' of U32) and is more like a balanced binary tree with root + being somewhere around U32_16 constructor (rough estimation). + To level this discrepency and compare parsing efficiency more accurately + we parse some range (@[minBound..maxBound]@ for enum) of possible values for a type. + This corresponds to the situation where data values are uniformly distributed. +-} +mkParseSuccessBench :: (IsBench a) => [a] -> Benchmark +mkParseSuccessBench xs = env (pure $ map toField xs) $ + bench (show $ typeRep xs) . nf (map $ (\(Right x) -> x `asProxyTypeOf` xs) . parse) + +mkParseFailBench :: (IsBench a) => Proxy a -> Benchmark +mkParseFailBench px = bench (show $ typeRep px) $ + nf (\s -> parse s `asProxyEither` px) mempty where - mkB :: (Bounded a, Enum a, ToField a) => String -> Proxy a -> Benchmark - mkB name = bench name . nf (map toField) . genEnum + asProxyEither :: Either String a -> Proxy a -> Either String a + asProxyEither x _ = x + +mkToFieldBench :: (IsBench a) => [a] -> Benchmark +mkToFieldBench xs = env (pure xs) $ bench (show $ typeRep xs) . nf (map toField) parse :: (FromField a) => Field -> Either String a parse = runParser . parseField -genEnum :: (Bounded a, Enum a) => Proxy a -> [a] -genEnum _ = [minBound..maxBound] +genRange :: (Bounded a, Enum a) => [a] +genRange = take 32 $ cycle [minBound..maxBound] + +manualEither0 :: [ManualEither0] +manualEither0 = take 32 $ cycle + [ LManual 1 + , RManual '!' + ] + +genericEither0 :: [GenericEither0] +genericEither0 = take 32 $ cycle + [ LGeneric 1 + , RGeneric '!' + ] + +manualEither1 :: [ManualEither1] +manualEither1 = take 32 $ cycle + [ LManual $ LManual 1 + , LManual $ RManual '!' + , RManual $ LManual 1 + , RManual $ RManual '!' + ] + +genericEither1 :: [GenericEither1] +genericEither1 = take 32 $ cycle + [ LGeneric $ LGeneric 1 + , LGeneric $ RGeneric '!' + , RGeneric $ LGeneric 1 + , RGeneric $ RGeneric '!' + ] + +manualEither2 :: [ManualEither2] +manualEither2 = take 32 $ cycle + [ LManual $ LManual $ LManual 1 + , LManual $ LManual $ RManual '!' + , LManual $ RManual $ LManual 1 + , LManual $ RManual $ RManual '!' + , RManual $ LManual $ LManual 1 + , RManual $ LManual $ RManual '!' + , RManual $ RManual $ LManual 1 + , RManual $ RManual $ RManual '!' + ] + +genericEither2 :: [GenericEither2] +genericEither2 = take 32 $ cycle + [ LGeneric $ LGeneric $ LGeneric 1 + , LGeneric $ LGeneric $ RGeneric '!' + , LGeneric $ RGeneric $ LGeneric 1 + , LGeneric $ RGeneric $ RGeneric '!' + , RGeneric $ LGeneric $ LGeneric 1 + , RGeneric $ LGeneric $ RGeneric '!' + , RGeneric $ RGeneric $ LGeneric 1 + , RGeneric $ RGeneric $ RGeneric '!' + ] + +manualEither3 :: [ManualEither3] +manualEither3 = take 32 $ cycle + [ LManual $ LManual $ LManual $ LManual 1 + , LManual $ LManual $ LManual $ RManual '!' + , LManual $ LManual $ RManual $ LManual 1 + , LManual $ LManual $ RManual $ RManual '!' + , LManual $ RManual $ LManual $ LManual 1 + , LManual $ RManual $ LManual $ RManual '!' + , LManual $ RManual $ RManual $ LManual 1 + , LManual $ RManual $ RManual $ RManual '!' + , RManual $ LManual $ LManual $ LManual 1 + , RManual $ LManual $ LManual $ RManual '!' + , RManual $ LManual $ RManual $ LManual 1 + , RManual $ LManual $ RManual $ RManual '!' + , RManual $ RManual $ LManual $ LManual 1 + , RManual $ RManual $ LManual $ RManual '!' + , RManual $ RManual $ RManual $ LManual 1 + , RManual $ RManual $ RManual $ RManual '!' + ] + +genericEither3 :: [GenericEither3] +genericEither3 = take 32 $ cycle + [ LGeneric $ LGeneric $ LGeneric $ LGeneric 1 + , LGeneric $ LGeneric $ LGeneric $ RGeneric '!' + , LGeneric $ LGeneric $ RGeneric $ LGeneric 1 + , LGeneric $ LGeneric $ RGeneric $ RGeneric '!' + , LGeneric $ RGeneric $ LGeneric $ LGeneric 1 + , LGeneric $ RGeneric $ LGeneric $ RGeneric '!' + , LGeneric $ RGeneric $ RGeneric $ LGeneric 1 + , LGeneric $ RGeneric $ RGeneric $ RGeneric '!' + , RGeneric $ LGeneric $ LGeneric $ LGeneric 1 + , RGeneric $ LGeneric $ LGeneric $ RGeneric '!' + , RGeneric $ LGeneric $ RGeneric $ LGeneric 1 + , RGeneric $ LGeneric $ RGeneric $ RGeneric '!' + , RGeneric $ RGeneric $ LGeneric $ LGeneric 1 + , RGeneric $ RGeneric $ LGeneric $ RGeneric '!' + , RGeneric $ RGeneric $ RGeneric $ LGeneric 1 + , RGeneric $ RGeneric $ RGeneric $ RGeneric '!' + ] diff --git a/benchmarks/cassava-iut.cabal b/benchmarks/cassava-iut.cabal index 71c467c..dd30731 100644 --- a/benchmarks/cassava-iut.cabal +++ b/benchmarks/cassava-iut.cabal @@ -101,6 +101,8 @@ Benchmark benchmark-iut Type: exitcode-stdio-1.0 Main-is: Benchmarks.hs other-modules: GenericFieldBench + Generic.Either + Generic.Prefix Generic.U2 Generic.U4 Generic.U8 @@ -128,6 +130,8 @@ Benchmark benchmark-ref Type: exitcode-stdio-1.0 Main-is: Benchmarks.hs other-modules: GenericFieldBench + Generic.Either + Generic.Prefix Generic.U2 Generic.U4 Generic.U8 From 88f86eb461e41218882b0a3425b50605d7911fdf Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 13:22:35 +0300 Subject: [PATCH 14/20] ToField/FromField for Data.Void.Void --- src/Data/Csv/Conversion.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index 632b9a8..a07953c 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -108,6 +108,7 @@ import Data.Vector (Vector, (!)) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import Data.Word (Word8, Word16, Word32, Word64) +import Data.Void import GHC.Float (double2Float) import GHC.Generics import Numeric.Natural @@ -1101,6 +1102,16 @@ instance ToField [Char] where toField = toField . T.pack {-# INLINE toField #-} +-- | Useless /per se/, but useful in cases like @Maybe Void@ +-- (a logical proof that only @Nothing@ can occur) +instance FromField Void where + parseField _ = error "parseField: Void term can't exist" + +-- | Useless /per se/, but useful in cases like @Maybe Void@ +-- (a logical proof that only @Nothing@ can occur) +instance ToField Void where + toField = absurd + parseSigned :: (Integral a, Num a) => String -> B.ByteString -> Parser a parseSigned typ s = case parseOnly (ws *> A8.signed A8.decimal <* ws) s of Left err -> typeError typ s (Just err) From 21d2f0180faeef4ff2e279e565f6ca6a3a67f6bc Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 13:24:10 +0300 Subject: [PATCH 15/20] GFromField/GToField for uninhabited types --- src/Data/Csv/Conversion.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index a07953c..d8fa7a4 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -1411,6 +1411,10 @@ instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B class GFromField f where gParseField :: Options -> Field -> Parser (f p) +-- Type without constructors +instance GFromField V1 where + gParseField _ = error "gFromField: type without constructors" + -- Type with single nullary constructor instance (Constructor c) => GFromField (C1 c U1) where gParseField opts field = Parser $ \onFailure onSuccess -> @@ -1439,6 +1443,10 @@ instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where class GToField f where gToField :: Options -> f p -> Field +-- Type without constructors +instance GToField V1 where + gToField _ = error "gToField: type without constructors" + -- Type with single nullary constructor instance (Constructor c) => GToField (C1 c U1) where gToField = encodeConstructor From 30c3fb93f54decd776be9d9a0cb464f5864d6416 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 15:29:39 +0300 Subject: [PATCH 16/20] Fix Nix shell --- benchmarks/shell.nix | 1 + default.nix | 43 +++++++++++++++++++++++++++++++++++-------- shell.nix | 34 +--------------------------------- 3 files changed, 37 insertions(+), 41 deletions(-) create mode 100644 benchmarks/shell.nix diff --git a/benchmarks/shell.nix b/benchmarks/shell.nix new file mode 100644 index 0000000..0f08e55 --- /dev/null +++ b/benchmarks/shell.nix @@ -0,0 +1 @@ +{...}@args: (import ../default.nix (args // { subDir = "benchmarks"; })).shell diff --git a/default.nix b/default.nix index 55a30cd..dd10e3f 100644 --- a/default.nix +++ b/default.nix @@ -1,21 +1,25 @@ -{ ghc +{ subDir ? "" +, ghc ? "ghc902" , doCheck ? true , configureFlags ? [ ] -}: +, withHoogle ? true +, ... +}@args: let - haskellNixSrc = builtins.fetchTarball "https://github.com/input-output-hk/haskell.nix/archive/b3df33abbcb736437cb06d5f53a10f6bb271bc51.tar.gz"; + haskellNixSrc = builtins.fetchTarball { + url = "https://github.com/input-output-hk/haskell.nix/archive/b3df33abbcb736437cb06d5f53a10f6bb271bc51.tar.gz"; + sha256 = "11daql694vp0hxs9rkyb3cn50yjfy840bybpsmrcq208cdjm7m0q"; + }; haskellNix = import haskellNixSrc { }; pkgs = import haskellNix.sources.nixpkgs-unstable haskellNix.nixpkgsArgs; -in { - inherit pkgs; - project = pkgs.haskell-nix.cabalProject { src = pkgs.haskell-nix.haskellLib.cleanGit { - name = "cassava"; src = ./.; + inherit subDir; + name = "cassava"; }; name = "cassava"; compiler-nix-name = ghc; @@ -25,4 +29,27 @@ in { ]; }; -} + shell = + let hsPkgs = pkgs.haskell.packages.${ghc}; + in project.shellFor { + + inherit withHoogle; + + exactDeps = true; + + buildInputs = [ + hsPkgs.cabal-install + hsPkgs.haskell-language-server + ]; + + LANG = "en_US.utf8"; + LC_ALL = "en_US.utf8"; + LOCALE_ARCHIVE = "${pkgs.glibcLocales}/lib/locale/locale-archive"; + }; + + compilers = pkgs.haskell.compiler; + +in with builtins; + if hasAttr ghc compilers + then { inherit pkgs project shell; } + else abort ("Unsupported GHC, available GHCs: " + concatStringsSep ", " (attrNames compilers)) diff --git a/shell.nix b/shell.nix index b3c669f..c460c03 100644 --- a/shell.nix +++ b/shell.nix @@ -1,33 +1 @@ -{ doCheck ? true -, ghc ? "ghc902" -, withHoogle ? true -, configureFlags ? [ ] -}: -let - result = import ./default.nix { - inherit configureFlags doCheck ghc; - }; - - inherit (result) pkgs project; - hsPkgs = pkgs.haskell.packages.${ghc}; - -in project.shellFor { - - inherit withHoogle; - - exactDeps = true; - - # We have to add 'criterion' explicitly as it depends on 'cassava' itself, - # so it will be dropped from included dependencies and benchmarks build fails. - # https://github.com/input-output-hk/haskell.nix/blob/b3df33abbcb736437cb06d5f53a10f6bb271bc51/builder/shell-for.nix#L31-L49) - additional = ps: [ps.criterion.components.library]; - - buildInputs = [ - hsPkgs.cabal-install - hsPkgs.haskell-language-server - ]; - - LANG = "en_US.utf8"; - LC_ALL = "en_US.utf8"; - LOCALE_ARCHIVE = "${pkgs.glibcLocales}/lib/locale/locale-archive"; -} +{...}@args: (import ./default.nix args).shell From 3df87c40b7478b20f9f4cb5143e68e5f150f5383 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 17:04:42 +0300 Subject: [PATCH 17/20] Fix ref tests --- benchmarks/Benchmarks.hs | 6 ++++++ benchmarks/cassava-iut.cabal | 9 +-------- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs index 58de68e..42c43cc 100644 --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -20,7 +20,11 @@ import qualified Data.Vector as V import Data.Csv import qualified Data.Csv.Streaming as Streaming + +-- This should be eventually replaced with 'cassava' version check +#ifdef GENERIC_FIELD_BENCH import GenericFieldBench +#endif #if !MIN_VERSION_bytestring(0,10,0) instance NFData (B.ByteString) where @@ -136,7 +140,9 @@ main = do , bgroup "comparison" [ bench "lazy-csv" $ nf LazyCsv.parseCSV csvData ] +#ifdef GENERIC_FIELD_BENCH , genericFieldBench +#endif ] where decodePresidents :: BL.ByteString -> Either String (Vector President) diff --git a/benchmarks/cassava-iut.cabal b/benchmarks/cassava-iut.cabal index dd30731..99817e9 100644 --- a/benchmarks/cassava-iut.cabal +++ b/benchmarks/cassava-iut.cabal @@ -123,20 +123,13 @@ Benchmark benchmark-iut ghc-options: -Wall -O2 + cpp-options: -DGENERIC_FIELD_BENCH Benchmark benchmark-ref default-language: Haskell2010 Type: exitcode-stdio-1.0 Main-is: Benchmarks.hs - other-modules: GenericFieldBench - Generic.Either - Generic.Prefix - Generic.U2 - Generic.U4 - Generic.U8 - Generic.U16 - Generic.U32 -- dependencies with version constraints inherited via lib:cassava-iut build-depends: base From 96c92ff787b47d4e49136e0375ed193346e41636 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 21:11:06 +0300 Subject: [PATCH 18/20] Static type errors --- src/Data/Csv/Conversion.hs | 9 +++++++++ tests/UnitTests.hs | 27 ++++++++++----------------- 2 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index d8fa7a4..3f6d93c 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -111,6 +111,7 @@ import Data.Word (Word8, Word16, Word32, Word64) import Data.Void import GHC.Float (double2Float) import GHC.Generics +import GHC.TypeLits import Numeric.Natural import Prelude hiding (lookup, takeWhile) @@ -1440,6 +1441,10 @@ instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where (onSuccess . L1) {-# INLINE gParseField #-} +instance (TypeError ('Text "You cannot derive FromField for product types")) => + GFromField (C1 c (c1 :*: c2)) where + gParseField _ _ = error "unreachable: gParseField for product types" + class GToField f where gToField :: Options -> f p -> Field @@ -1463,6 +1468,10 @@ instance (GToField c1, GToField c2) => GToField (c1 :+: c2) where gToField opts (R1 val) = gToField opts val {-# INLINE gToField #-} +instance (TypeError ('Text "You cannot derive ToField for product types")) => + GToField (C1 c (c1 :*: c2)) where + gToField _ = error "unreachable: gToField for product types" + encodeConstructor :: (Constructor c) => Options -> C1 c f p -> B.ByteString encodeConstructor opts = T.encodeUtf8 . T.pack . fieldLabelModifier opts . conName {-# INLINE encodeConstructor #-} diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index b82495f..224ea48 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -459,22 +459,13 @@ data Foo = Foo instance FromField Foo instance ToField Foo --- -- Should not compile --- --- -- Newtype --- newtype Foo1 = Foo1 Int deriving (Eq, Generic, Show) --- instance FromField Foo1 --- instance ToField Foo1 --- newtype FooRec1 = FooRec1 { unFooRec1 :: Int } deriving (Eq, Generic, Show) --- instance FromField FooRec1 --- instance ToField FooRec1 --- newtype FooRecF1 a = FooRecF1 { unFooRecF1 :: a } deriving (Eq, Generic, Show) --- instance (FromField a) => FromField (FooRecF1 a) --- instance (ToField a) => ToField (FooRecF1 a) --- -- Product --- data Foo2 = Foo2 Char Int deriving (Eq, Generic, Show) --- instance FromField Foo2 --- instance ToField Foo2 +data Foo1 = Foo1 Int + deriving (Eq, Generic, Show) + +instance FromField Foo1 +instance ToField Foo1 +instance Arbitrary Foo1 where + arbitrary = Foo1 <$> arbitrary data Bar = BarN1 | BarU Int | BarN2 deriving (Eq, Generic, Show) @@ -502,9 +493,11 @@ genericFieldTests :: [TF.Test] genericFieldTests = [ testGroup "nullary constructor" [ testCase "encoding" $ toField Foo @?= "Foo" - , testCase "decoding" $ runParser (parseField "Foo") @?= Right Foo ] + , testCase "decoding" $ runParser (parseField "Foo") @?= Right Foo , testCase "decoding failure" $ runParser (parseField "foo") @?= (Left "Can't parseField of type Foo from \"foo\"" :: Either String Foo) + ] + , testProperty "unary constructor roundtrip" (roundtripProp :: Foo1 -> Bool) , testProperty "sum type roundtrip" (roundtripProp :: Bar -> Bool) , testGroup "constructor modifier" [ testCase "encoding" $ toField BazOne @?= "one" From 134f856624758749d76eba84547d4f9fd8508d99 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 21:33:46 +0300 Subject: [PATCH 19/20] Some CPP to fix old GHCs Also reordered things a bit --- src/Data/Csv/Conversion.hs | 47 ++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 22 deletions(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index 3f6d93c..a23fb97 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -108,7 +108,9 @@ import Data.Vector (Vector, (!)) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import Data.Word (Word8, Word16, Word32, Word64) +#if MIN_VERSION_base(4,8,0) import Data.Void +#endif import GHC.Float (double2Float) import GHC.Generics import GHC.TypeLits @@ -1103,6 +1105,7 @@ instance ToField [Char] where toField = toField . T.pack {-# INLINE toField #-} +#if MIN_VERSION_base(4,8,0) -- | Useless /per se/, but useful in cases like @Maybe Void@ -- (a logical proof that only @Nothing@ can occur) instance FromField Void where @@ -1112,6 +1115,7 @@ instance FromField Void where -- (a logical proof that only @Nothing@ can occur) instance ToField Void where toField = absurd +#endif parseSigned :: (Integral a, Num a) => String -> B.ByteString -> Parser a parseSigned typ s = case parseOnly (ws *> A8.signed A8.decimal <* ws) s of @@ -1412,10 +1416,16 @@ instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B class GFromField f where gParseField :: Options -> Field -> Parser (f p) +class GToField f where + gToField :: Options -> f p -> Field + -- Type without constructors instance GFromField V1 where gParseField _ = error "gFromField: type without constructors" +instance GToField V1 where + gToField _ = error "gToField: type without constructors" + -- Type with single nullary constructor instance (Constructor c) => GFromField (C1 c U1) where gParseField opts field = Parser $ \onFailure onSuccess -> @@ -1428,11 +1438,19 @@ instance (Constructor c) => GFromField (C1 c U1) where val = M1 U1 {-# INLINE gParseField #-} +instance (Constructor c) => GToField (C1 c U1) where + gToField = encodeConstructor + {-# INLINE gToField #-} + -- Type with single unary constructor instance (FromField a) => GFromField (C1 c (S1 meta (K1 i a))) where gParseField _opts = fmap (M1 . M1 . K1) . parseField {-# INLINE gParseField #-} +instance (ToField a) => GToField (C1 c (S1 meta (K1 i a))) where + gToField _ = toField . unK1 . unM1 . unM1 + {-# INLINE gToField #-} + -- Sum type instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where gParseField opts field = Parser $ \onFailure onSuccess -> @@ -1441,36 +1459,21 @@ instance (GFromField c1, GFromField c2) => GFromField (c1 :+: c2) where (onSuccess . L1) {-# INLINE gParseField #-} -instance (TypeError ('Text "You cannot derive FromField for product types")) => - GFromField (C1 c (c1 :*: c2)) where - gParseField _ _ = error "unreachable: gParseField for product types" - -class GToField f where - gToField :: Options -> f p -> Field - --- Type without constructors -instance GToField V1 where - gToField _ = error "gToField: type without constructors" - --- Type with single nullary constructor -instance (Constructor c) => GToField (C1 c U1) where - gToField = encodeConstructor - {-# INLINE gToField #-} - ---- Type with single unary constructor -instance (ToField a) => GToField (C1 c (S1 meta (K1 i a))) where - gToField _ = toField . unK1 . unM1 . unM1 - {-# INLINE gToField #-} - --- Sum type instance (GToField c1, GToField c2) => GToField (c1 :+: c2) where gToField opts (L1 val) = gToField opts val gToField opts (R1 val) = gToField opts val {-# INLINE gToField #-} +-- Statically fail for product types +#if MIN_VERSION_base(4,9,0) +instance (TypeError ('Text "You cannot derive FromField for product types")) => + GFromField (C1 c (c1 :*: c2)) where + gParseField _ _ = error "unreachable: gParseField for product types" + instance (TypeError ('Text "You cannot derive ToField for product types")) => GToField (C1 c (c1 :*: c2)) where gToField _ = error "unreachable: gToField for product types" +#endif encodeConstructor :: (Constructor c) => Options -> C1 c f p -> B.ByteString encodeConstructor opts = T.encodeUtf8 . T.pack . fieldLabelModifier opts . conName From b2147ee200097d6cb510c213457483834aca01bc Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sat, 10 Dec 2022 22:20:45 +0300 Subject: [PATCH 20/20] Fix --- src/Data/Csv/Conversion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Csv/Conversion.hs b/src/Data/Csv/Conversion.hs index a23fb97..d9b5a39 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -110,10 +110,10 @@ import qualified Data.Vector.Unboxed as U import Data.Word (Word8, Word16, Word32, Word64) #if MIN_VERSION_base(4,8,0) import Data.Void +import GHC.TypeLits #endif import GHC.Float (double2Float) import GHC.Generics -import GHC.TypeLits import Numeric.Natural import Prelude hiding (lookup, takeWhile)