[ #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'

Author: stevladimir

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

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).
 

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 ()