diff --git a/Data/Csv/Conversion.hs b/Data/Csv/Conversion.hs index 5034ff9..892c329 100644 --- a/Data/Csv/Conversion.hs +++ b/Data/Csv/Conversion.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, Rank2Types #-} +{-# LANGUAGE CPP, FlexibleInstances, OverloadedStrings, Rank2Types #-} +#ifdef GENERICS +{-# LANGUAGE DefaultSignatures, TypeOperators, KindSignatures, FlexibleContexts, + MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-} +#endif module Data.Csv.Conversion ( -- * Type conversion @@ -50,6 +54,11 @@ import Prelude hiding (takeWhile) import Data.Csv.Conversion.Internal import Data.Csv.Types +#ifdef GENERICS +import GHC.Generics +import qualified Data.IntMap as IM +#endif + ------------------------------------------------------------------------ -- Type conversion @@ -81,6 +90,11 @@ import Data.Csv.Types -- @ class FromRecord a where parseRecord :: Record -> Parser a + +#ifdef GENERICS + default parseRecord :: (Generic a, GFromRecord (Rep a)) => Record -> Parser a + parseRecord r = to <$> gparseRecord r +#endif -- | Haskell lacks a single-element tuple type, so if you CSV data -- with just one column you can use the 'Only' type to represent a @@ -107,6 +121,11 @@ newtype Only a = Only { class ToRecord a where toRecord :: a -> Record +#ifdef GENERICS + default toRecord :: (Generic a, GToRecord (Rep a) Field) => a -> Record + toRecord = V.fromList . gtoRecord . from +#endif + instance FromField a => FromRecord (Only a) where parseRecord v | n == 1 = Only <$> parseField (V.unsafeIndex v 0) @@ -273,6 +292,11 @@ instance ToField a => ToRecord (Vector a) where class FromNamedRecord a where parseNamedRecord :: NamedRecord -> Parser a +#ifdef GENERICS + default parseNamedRecord :: (Generic a, GFromNamedRecord (Rep a)) => NamedRecord -> Parser a + parseNamedRecord r = to <$> gparseNamedRecord r +#endif + -- | A type that can be converted to a single CSV record. -- -- An example type and instance: @@ -286,6 +310,11 @@ class FromNamedRecord a where class ToNamedRecord a where toNamedRecord :: a -> NamedRecord +#ifdef GENERICS + default toNamedRecord :: (Generic a, GToRecord (Rep a) (B.ByteString, B.ByteString)) => a -> NamedRecord + toNamedRecord = namedRecord . gtoRecord . from +#endif + instance FromField a => FromNamedRecord (M.Map B.ByteString a) where parseNamedRecord m = M.fromList <$> (traverse parseSnd $ HM.toList m) @@ -685,3 +714,97 @@ apP d e = do parse :: Parser a -> Result a parse p = runParser p Error Success {-# INLINE parse #-} + + + +#ifdef GENERICS + +class GFromRecord f where + gparseRecord :: Record -> Parser (f p) + +instance GFromRecordSum f Record => GFromRecord (M1 i n f) where + gparseRecord v = + case (IM.lookup n gparseRecordSum) of + Nothing -> lengthMismatch n v + Just p -> M1 <$> p v + where + n = V.length v + +class GFromNamedRecord f where + gparseNamedRecord :: NamedRecord -> Parser (f p) + +instance GFromRecordSum f NamedRecord => GFromNamedRecord (M1 i n f) where + gparseNamedRecord v = + foldr (\f p -> M1 <$> f v <|> p) empty (IM.elems gparseRecordSum) + + +class GFromRecordSum f r where + gparseRecordSum :: IM.IntMap (r -> Parser (f p)) + +instance (GFromRecordSum a r, GFromRecordSum b r) => GFromRecordSum (a :+: b) r where + gparseRecordSum = + IM.unionWith (\a b r -> a r <|> b r) + (fmap (L1 <$>) <$> gparseRecordSum) + (fmap (R1 <$>) <$> gparseRecordSum) + +instance GFromRecordProd f r => GFromRecordSum (M1 i n f) r where + gparseRecordSum = IM.singleton n (fmap (M1 <$>) f) + where + (n, f) = gparseRecordProd 0 + +class GFromRecordProd f r where + gparseRecordProd :: Int -> (Int, r -> Parser (f p)) + +instance GFromRecordProd U1 r where + gparseRecordProd n = (n, const (pure U1)) + +instance (GFromRecordProd a r, GFromRecordProd b r) => GFromRecordProd (a :*: b) r where + gparseRecordProd n0 = (n2, f) + where + f r = (:*:) <$> fa r <*> fb r + (n1, fa) = gparseRecordProd n0 + (n2, fb) = gparseRecordProd n1 + +instance GFromRecordProd f Record => GFromRecordProd (M1 i n f) Record where + gparseRecordProd n = fmap (M1 <$>) <$> gparseRecordProd n + +instance FromField a => GFromRecordProd (K1 i a) Record where + gparseRecordProd n = (n + 1, \v -> K1 <$> parseField (V.unsafeIndex v n)) + +data Proxy s (f :: * -> *) a = Proxy + +instance (FromField a, Selector s) => GFromRecordProd (M1 S s (K1 i a)) NamedRecord where + gparseRecordProd n = (n + 1, \v -> (M1 . K1) <$> v .: name) + where + name = T.encodeUtf8 (T.pack (selName (Proxy :: Proxy s f a))) + + +class GToRecord a f where + gtoRecord :: a p -> [f] + +instance GToRecord U1 f where + gtoRecord U1 = [] + +instance (GToRecord a f, GToRecord b f) => GToRecord (a :*: b) f where + gtoRecord (a :*: b) = gtoRecord a ++ gtoRecord b + +instance (GToRecord a f, GToRecord b f) => GToRecord (a :+: b) f where + gtoRecord (L1 a) = gtoRecord a + gtoRecord (R1 b) = gtoRecord b + +instance GToRecord a f => GToRecord (M1 D c a) f where + gtoRecord (M1 a) = gtoRecord a + +instance GToRecord a f => GToRecord (M1 C c a) f where + gtoRecord (M1 a) = gtoRecord a + +instance GToRecord a Field => GToRecord (M1 S c a) Field where + gtoRecord (M1 a) = gtoRecord a + +instance ToField a => GToRecord (K1 i a) Field where + gtoRecord (K1 a) = [toField a] + +instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B.ByteString) where + gtoRecord m@(M1 (K1 a)) = [T.encodeUtf8 (T.pack (selName m)) .= toField a] + +#endif \ No newline at end of file diff --git a/cassava.cabal b/cassava.cabal index 2cb5419..e053a14 100644 --- a/cassava.cabal +++ b/cassava.cabal @@ -1,5 +1,5 @@ Name: cassava -Version: 0.1.0.1 +Version: 0.1.0.2 Synopsis: A CSV parsing and encoding library Description: A CSV parsing and encoding library optimized for ease of use and high @@ -22,7 +22,6 @@ Extra-source-files: examples/*.hs Library Exposed-modules: Data.Csv Data.Csv.Parser - Data.Csv.Conversion.Generics Other-modules: Data.Csv.Conversion Data.Csv.Conversion.Internal @@ -35,13 +34,16 @@ Library blaze-builder, bytestring, containers, - ghc-prim >= 0.2, text, unordered-containers, vector ghc-options: -Wall -O2 + if impl(ghc >= 7.2.1) + cpp-options: -DGENERICS + build-depends: ghc-prim >= 0.2 + Test-suite unit-tests Type: exitcode-stdio-1.0 Main-is: UnitTests.hs