persistable-record: add generic definitions of PersistableWidth.

persistable-record/src/Database/Record/Persistable.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
 
 -- |
 -- Module      : Database.Record.Persistable
@@ -23,9 +26,10 @@ module Database.Record.Persistable (
   -- * Inference rules for proof objects
 
   PersistableType(..), sqlNullValue,
-  PersistableWidth (..), derivedWidth
+  PersistableWidth (..), derivedWidth,
   ) where
 
+import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)
 import Control.Applicative ((<$>), (<*>), Const (..))
 import Data.Monoid (mempty, Sum (..))
 
@@ -48,6 +52,15 @@ unsafePersistableSqlTypeFromNull =  PersistableSqlType
 newtype PersistableRecordWidth a =
   PersistableRecordWidth { unPRW :: Const (Sum Int) a }
 
+-- unsafely map PersistableRecordWidth
+wmap :: (a -> b) -> PersistableRecordWidth a -> PersistableRecordWidth b
+f `wmap` prw = PersistableRecordWidth $ f <$> unPRW prw
+
+-- unsafely ap PersistableRecordWidth
+wap :: PersistableRecordWidth (a -> b) -> PersistableRecordWidth a -> PersistableRecordWidth b
+wf `wap` prw = PersistableRecordWidth $ unPRW wf <*> unPRW prw
+
+
 -- | Get width 'Int' value of record type 'a'.
 runPersistableRecordWidth :: PersistableRecordWidth a -> Int
 runPersistableRecordWidth = getSum . getConst . unPRW
@@ -66,11 +79,11 @@ unsafeValueWidth =  unsafePersistableRecordWidth 1
 
 -- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type.
 (<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
-a <&> b = PersistableRecordWidth $ (,) <$> unPRW a <*> unPRW b
+a <&> b = (,) `wmap` a `wap` b
 
 -- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'.
 maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
-maybeWidth = PersistableRecordWidth . (Just <$>) . unPRW
+maybeWidth = wmap Just
 
 -- | Axiom of 'PersistableRecordWidth' for Haskell unit () type.
 voidWidth :: PersistableRecordWidth ()
@@ -90,6 +103,9 @@ sqlNullValue =  runPersistableNullValue persistableType
 class PersistableWidth a where
   persistableWidth :: PersistableRecordWidth a
 
+  default persistableWidth :: (Generic a, GPersistableWidth (Rep a)) => PersistableRecordWidth a
+  persistableWidth = to `wmap` gPersistableWidth
+
 -- | Inference rule of 'PersistableRecordWidth' proof object for tuple ('a', 'b') type.
 instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where
   persistableWidth = persistableWidth <&> persistableWidth
@@ -106,3 +122,19 @@ instance PersistableWidth () where
 derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int)
 derivedWidth =  (pw, runPersistableRecordWidth pw) where
   pw = persistableWidth
+
+
+class GPersistableWidth f where
+  gPersistableWidth :: PersistableRecordWidth (f a)
+
+instance GPersistableWidth U1 where
+  gPersistableWidth = PersistableRecordWidth $ Const mempty
+
+instance (GPersistableWidth a, GPersistableWidth b) => GPersistableWidth (a :*: b) where
+  gPersistableWidth = (:*:) `wmap` gPersistableWidth `wap` gPersistableWidth
+
+instance (GPersistableWidth a) => GPersistableWidth (M1 i c a) where
+  gPersistableWidth = M1 `wmap` gPersistableWidth
+
+instance PersistableWidth a => GPersistableWidth (K1 i a) where
+  gPersistableWidth = K1 `wmap` persistableWidth