[ #206 ] Deriving FromField/ToField instances

.gitignore

@@ -8,6 +8,7 @@
 .hpc/
 dist/
 dist-newstyle/
+newdist/
 cabal.sandbox.config
 .ghc.environment.*
 .stack-work

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)

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

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

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"}

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"}

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"}