module Database.Record.Persistable (
PersistableSqlType, runPersistableNullValue, unsafePersistableSqlTypeFromNull,
PersistableRecordWidth, runPersistableRecordWidth,
unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth,
PersistableType(..), sqlNullValue,
PersistableWidth (..), derivedWidth,
GFieldWidthList,
ProductConst, getProductConst,
genericFieldOffsets,
) where
import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)
import Control.Applicative ((<$>), pure, Const (..))
import Data.Monoid (Monoid, Sum (..))
import Data.Array (Array, listArray, bounds, (!))
import Data.DList (DList)
import qualified Data.DList as DList
import Data.Functor.ProductIsomorphic
(ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), )
newtype PersistableSqlType q = PersistableSqlType q
runPersistableNullValue :: PersistableSqlType q -> q
runPersistableNullValue (PersistableSqlType q) = q
unsafePersistableSqlTypeFromNull :: q
-> PersistableSqlType q
unsafePersistableSqlTypeFromNull = PersistableSqlType
newtype ProductConst a b =
ProductConst { unPC :: Const a b }
deriving (ProductIsoFunctor, ProductIsoApplicative)
getProductConst :: ProductConst a b -> a
getProductConst = getConst . unPC
type PersistableRecordWidth a = ProductConst (Sum Int) a
pmap' :: Monoid e => (a -> b) -> ProductConst e a -> ProductConst e b
f `pmap'` prw = ProductConst $ f <$> unPC prw
runPersistableRecordWidth :: PersistableRecordWidth a -> Int
runPersistableRecordWidth = getSum . getConst . unPC
instance Show a => Show (ProductConst a b) where
show = ("PC " ++) . show . getConst . unPC
unsafePersistableRecordWidth :: Int
-> PersistableRecordWidth a
unsafePersistableRecordWidth = ProductConst . Const . Sum
unsafeValueWidth :: PersistableRecordWidth a
unsafeValueWidth = unsafePersistableRecordWidth 1
(<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
a <&> b = (,) |$| a |*| b
maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
maybeWidth = pmap' Just
class Eq q => PersistableType q where
persistableType :: PersistableSqlType q
sqlNullValue :: PersistableType q => q
sqlNullValue = runPersistableNullValue persistableType
class PersistableWidth a where
persistableWidth :: PersistableRecordWidth a
default persistableWidth :: (Generic a, GFieldWidthList (Rep a)) => PersistableRecordWidth a
persistableWidth = pmapConst (Sum . lastA) genericFieldOffsets
where
lastA a = a ! (snd $ bounds a)
pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c
pmapConst f = ProductConst . Const . f . getConst . unPC
class GFieldWidthList f where
gFieldWidthList :: ProductConst (DList Int) (f a)
instance GFieldWidthList U1 where
gFieldWidthList = pureP U1
instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where
gFieldWidthList = (:*:) |$| gFieldWidthList |*| gFieldWidthList
instance GFieldWidthList a => GFieldWidthList (M1 i c a) where
gFieldWidthList = M1 |$| gFieldWidthList
instance PersistableWidth a => GFieldWidthList (K1 i a) where
gFieldWidthList = K1 |$| pmapConst (pure . getSum) persistableWidth
offsets :: [Int] -> Array Int Int
offsets ws = listArray (0, length ws) $ scanl (+) 0 ws
genericFieldOffsets :: (Generic a, GFieldWidthList (Rep a)) => ProductConst (Array Int Int) a
genericFieldOffsets = pmapConst (offsets . DList.toList) $ to `pmap'` gFieldWidthList
instance PersistableWidth a => PersistableWidth (Maybe a) where
persistableWidth = maybeWidth persistableWidth
instance PersistableWidth ()
derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int)
derivedWidth = (pw, runPersistableRecordWidth pw) where
pw = persistableWidth