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/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs index 89a5e51..42c43cc 100644 --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -21,6 +21,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 rnf !s = () @@ -135,6 +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/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/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..6af43da --- /dev/null +++ b/benchmarks/GenericFieldBench.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeApplications #-} + +module GenericFieldBench + ( genericFieldBench + ) where + +import Control.DeepSeq +import Criterion +import Data.Csv +import Data.Proxy +import Data.Typeable +import Generic.Either +import Generic.U2 +import Generic.U4 +import Generic.U8 +import Generic.U16 +import Generic.U32 + + +genericFieldBench :: Benchmark +genericFieldBench = bgroup "genericField" + [ 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) + , 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 (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 = (FromField a, ToField a, NFData a, Typeable a) + +{- + 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 + 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 + +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 2f82936..99817e9 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,14 @@ 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 + Generic.U16 + Generic.U32 -- dependencies with version constraints inherited via lib:cassava-iut build-depends: base @@ -114,6 +123,7 @@ Benchmark benchmark-iut ghc-options: -Wall -O2 + cpp-options: -DGENERIC_FIELD_BENCH Benchmark benchmark-ref default-language: Haskell2010 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/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..dd10e3f --- /dev/null +++ b/default.nix @@ -0,0 +1,55 @@ +{ subDir ? "" +, ghc ? "ghc902" +, doCheck ? true +, configureFlags ? [ ] +, withHoogle ? true +, ... +}@args: +let + 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; + + project = pkgs.haskell-nix.cabalProject { + src = pkgs.haskell-nix.haskellLib.cleanGit { + src = ./.; + inherit subDir; + name = "cassava"; + }; + name = "cassava"; + compiler-nix-name = ghc; + index-state = "2022-09-03T00:00:00Z"; + modules = [ + { inherit doCheck configureFlags; } + ]; + }; + + 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 new file mode 100644 index 0000000..c460c03 --- /dev/null +++ b/shell.nix @@ -0,0 +1 @@ +{...}@args: (import ./default.nix args).shell 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..d9b5a39 100644 --- a/src/Data/Csv/Conversion.hs +++ b/src/Data/Csv/Conversion.hs @@ -9,6 +9,7 @@ OverloadedStrings, Rank2Types, ScopedTypeVariables, + TypeFamilies, TypeOperators, UndecidableInstances #-} @@ -44,6 +45,8 @@ module Data.Csv.Conversion , genericParseNamedRecord , genericToNamedRecord , genericHeaderOrder + , genericParseField + , genericToField -- *** Generic type conversion options , Options @@ -105,6 +108,10 @@ 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 +import GHC.TypeLits +#endif import GHC.Float (double2Float) import GHC.Generics import Numeric.Natural @@ -760,6 +767,22 @@ parseBoth (k, v) = (,) <$> parseField k <*> parseField v class FromField a where parseField :: 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 + :: forall a rep meta. (Generic a, GFromField rep, Rep a ~ D1 meta rep, Datatype meta) + => Options -> Field -> Parser a +genericParseField opts field = Parser $ \onFailure onSuccess -> + unParser (gParseField opts field) (\_ -> onFailure err) (onSuccess . to . M1) + where + 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. -- -- Example type and instance: @@ -775,6 +798,14 @@ class FromField a where class ToField a where toField :: 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, 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. instance FromField a => FromField (Maybe a) where parseField s @@ -1074,6 +1105,18 @@ 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 + 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 +#endif + 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) @@ -1370,6 +1413,72 @@ 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 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 -> + 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 + 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 -> + unParser (gParseField opts field) + (\_ -> unParser (gParseField opts field) onFailure $ onSuccess . R1) + (onSuccess . L1) + {-# INLINE gParseField #-} + +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 +{-# INLINE encodeConstructor #-} + -- 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..224ea48 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 @@ -35,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 ------------------------------------------------------------------------ @@ -448,6 +450,64 @@ 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 + +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) + +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 "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" + , 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 +518,7 @@ allTests = [ testGroup "positional" positionalTests , testGroup "custom-options" customOptionsTests , testGroup "instances" instanceTests , testGroup "generic-conversions" genericConversionTests + , testGroup "generic-field-conversions" genericFieldTests ] main :: IO ()