{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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
runPersistableNullValue (PersistableSqlType q :: q
q) = q
q
unsafePersistableSqlTypeFromNull :: q
-> PersistableSqlType q
unsafePersistableSqlTypeFromNull :: q -> PersistableSqlType q
unsafePersistableSqlTypeFromNull = q -> PersistableSqlType q
forall q. q -> PersistableSqlType q
PersistableSqlType
newtype ProductConst a b =
ProductConst { ProductConst a b -> Const a b
unPC :: Const a b }
deriving ((a -> b) -> ProductConst a a -> ProductConst a b
(forall a b.
ProductConstructor (a -> b) =>
(a -> b) -> ProductConst a a -> ProductConst a b)
-> ProductIsoFunctor (ProductConst a)
forall a b.
ProductConstructor (a -> b) =>
(a -> b) -> ProductConst a a -> ProductConst a b
forall a a b.
ProductConstructor (a -> b) =>
(a -> b) -> ProductConst a a -> ProductConst a b
forall (f :: * -> *).
(forall a b. ProductConstructor (a -> b) => (a -> b) -> f a -> f b)
-> ProductIsoFunctor f
|$| :: (a -> b) -> ProductConst a a -> ProductConst a b
$c|$| :: forall a a b.
ProductConstructor (a -> b) =>
(a -> b) -> ProductConst a a -> ProductConst a b
ProductIsoFunctor, ProductIsoFunctor (ProductConst a)
a -> ProductConst a a
ProductIsoFunctor (ProductConst a) =>
(forall a. ProductConstructor a => a -> ProductConst a a)
-> (forall a b.
ProductConst a (a -> b) -> ProductConst a a -> ProductConst a b)
-> ProductIsoApplicative (ProductConst a)
ProductConst a (a -> b) -> ProductConst a a -> ProductConst a b
forall a. Monoid a => ProductIsoFunctor (ProductConst a)
forall a a.
(Monoid a, ProductConstructor a) =>
a -> ProductConst a a
forall a a b.
Monoid a =>
ProductConst a (a -> b) -> ProductConst a a -> ProductConst a b
forall a. ProductConstructor a => a -> ProductConst a a
forall a b.
ProductConst a (a -> b) -> ProductConst a a -> ProductConst a b
forall (f :: * -> *).
ProductIsoFunctor f =>
(forall a. ProductConstructor a => a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> ProductIsoApplicative f
|*| :: ProductConst a (a -> b) -> ProductConst a a -> ProductConst a b
$c|*| :: forall a a b.
Monoid a =>
ProductConst a (a -> b) -> ProductConst a a -> ProductConst a b
pureP :: a -> ProductConst a a
$cpureP :: forall a a.
(Monoid a, ProductConstructor a) =>
a -> ProductConst a a
$cp1ProductIsoApplicative :: forall a. Monoid a => ProductIsoFunctor (ProductConst a)
ProductIsoApplicative)
getProductConst :: ProductConst a b -> a
getProductConst :: ProductConst a b -> a
getProductConst = Const a b -> a
forall a k (b :: k). Const a b -> a
getConst (Const a b -> a)
-> (ProductConst a b -> Const a b) -> ProductConst a b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProductConst a b -> Const a b
forall a b. ProductConst a b -> Const a b
unPC
{-# INLINE getProductConst #-}
type PersistableRecordWidth a = ProductConst (Sum Int) a
pmap' :: Monoid e => (a -> b) -> ProductConst e a -> ProductConst e b
f :: a -> b
f pmap' :: (a -> b) -> ProductConst e a -> ProductConst e b
`pmap'` prw :: ProductConst e a
prw = Const e b -> ProductConst e b
forall a b. Const a b -> ProductConst a b
ProductConst (Const e b -> ProductConst e b) -> Const e b -> ProductConst e b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> Const e a -> Const e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProductConst e a -> Const e a
forall a b. ProductConst a b -> Const a b
unPC ProductConst e a
prw
runPersistableRecordWidth :: PersistableRecordWidth a -> Int
runPersistableRecordWidth :: PersistableRecordWidth a -> Int
runPersistableRecordWidth = Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int)
-> (PersistableRecordWidth a -> Sum Int)
-> PersistableRecordWidth a
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (Sum Int) a -> Sum Int
forall a k (b :: k). Const a b -> a
getConst (Const (Sum Int) a -> Sum Int)
-> (PersistableRecordWidth a -> Const (Sum Int) a)
-> PersistableRecordWidth a
-> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistableRecordWidth a -> Const (Sum Int) a
forall a b. ProductConst a b -> Const a b
unPC
{-# INLINE runPersistableRecordWidth #-}
instance Show a => Show (ProductConst a b) where
show :: ProductConst a b -> String
show = ("PC " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (ProductConst a b -> String) -> ProductConst a b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> String)
-> (ProductConst a b -> a) -> ProductConst a b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const a b -> a
forall a k (b :: k). Const a b -> a
getConst (Const a b -> a)
-> (ProductConst a b -> Const a b) -> ProductConst a b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProductConst a b -> Const a b
forall a b. ProductConst a b -> Const a b
unPC
unsafePersistableRecordWidth :: Int
-> PersistableRecordWidth a
unsafePersistableRecordWidth :: Int -> PersistableRecordWidth a
unsafePersistableRecordWidth = Const (Sum Int) a -> PersistableRecordWidth a
forall a b. Const a b -> ProductConst a b
ProductConst (Const (Sum Int) a -> PersistableRecordWidth a)
-> (Int -> Const (Sum Int) a) -> Int -> PersistableRecordWidth a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Const (Sum Int) a
forall k a (b :: k). a -> Const a b
Const (Sum Int -> Const (Sum Int) a)
-> (Int -> Sum Int) -> Int -> Const (Sum Int) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Sum Int
forall a. a -> Sum a
Sum
{-# INLINE unsafePersistableRecordWidth #-}
unsafeValueWidth :: PersistableRecordWidth a
unsafeValueWidth :: PersistableRecordWidth a
unsafeValueWidth = Int -> PersistableRecordWidth a
forall a. Int -> PersistableRecordWidth a
unsafePersistableRecordWidth 1
{-# INLINE unsafeValueWidth #-}
(<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
a :: PersistableRecordWidth a
a <&> :: PersistableRecordWidth a
-> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
<&> b :: PersistableRecordWidth b
b = (,) (a -> b -> (a, b))
-> PersistableRecordWidth a -> ProductConst (Sum Int) (b -> (a, b))
forall (f :: * -> *) a b.
(ProductIsoFunctor f, ProductConstructor (a -> b)) =>
(a -> b) -> f a -> f b
|$| PersistableRecordWidth a
a ProductConst (Sum Int) (b -> (a, b))
-> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
forall (f :: * -> *) a b.
ProductIsoApplicative f =>
f (a -> b) -> f a -> f b
|*| PersistableRecordWidth b
b
maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
maybeWidth = (a -> Maybe a)
-> PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
forall e a b.
Monoid e =>
(a -> b) -> ProductConst e a -> ProductConst e b
pmap' a -> Maybe a
forall a. a -> Maybe a
Just
class Eq q => PersistableType q where
persistableType :: PersistableSqlType q
sqlNullValue :: PersistableType q => q
sqlNullValue :: q
sqlNullValue = PersistableSqlType q -> q
forall q. PersistableSqlType q -> q
runPersistableNullValue PersistableSqlType q
forall q. PersistableType q => PersistableSqlType q
persistableType
class PersistableWidth a where
persistableWidth :: PersistableRecordWidth a
default persistableWidth :: (Generic a, GFieldWidthList (Rep a)) => PersistableRecordWidth a
persistableWidth = (Array Int Int -> Sum Int)
-> ProductConst (Array Int Int) a -> PersistableRecordWidth a
forall a b c. (a -> b) -> ProductConst a c -> ProductConst b c
pmapConst (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int)
-> (Array Int Int -> Int) -> Array Int Int -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Int Int -> Int
forall b e. Ix b => Array b e -> e
lastA) ProductConst (Array Int Int) a
forall a.
(Generic a, GFieldWidthList (Rep a)) =>
ProductConst (Array Int Int) a
genericFieldOffsets
where
lastA :: Array b e -> e
lastA a :: Array b e
a = Array b e
a Array b e -> b -> e
forall i e. Ix i => Array i e -> i -> e
! ((b, b) -> b
forall a b. (a, b) -> b
snd ((b, b) -> b) -> (b, b) -> b
forall a b. (a -> b) -> a -> b
$ Array b e -> (b, b)
forall i e. Array i e -> (i, i)
bounds Array b e
a)
pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c
pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c
pmapConst f :: a -> b
f = Const b c -> ProductConst b c
forall a b. Const a b -> ProductConst a b
ProductConst (Const b c -> ProductConst b c)
-> (ProductConst a c -> Const b c)
-> ProductConst a c
-> ProductConst b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Const b c
forall k a (b :: k). a -> Const a b
Const (b -> Const b c)
-> (ProductConst a c -> b) -> ProductConst a c -> Const b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> b) -> (ProductConst a c -> a) -> ProductConst a c -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const a c -> a
forall a k (b :: k). Const a b -> a
getConst (Const a c -> a)
-> (ProductConst a c -> Const a c) -> ProductConst a c -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProductConst a c -> Const a c
forall a b. ProductConst a b -> Const a b
unPC
class GFieldWidthList f where
gFieldWidthList :: ProductConst (DList Int) (f a)
instance GFieldWidthList U1 where
gFieldWidthList :: ProductConst (DList Int) (U1 a)
gFieldWidthList = U1 a -> ProductConst (DList Int) (U1 a)
forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP U1 a
forall k (p :: k). U1 p
U1
instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where
gFieldWidthList :: ProductConst (DList Int) ((:*:) a b a)
gFieldWidthList = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> ProductConst (DList Int) (a a)
-> ProductConst (DList Int) (b a -> (:*:) a b a)
forall (f :: * -> *) a b.
(ProductIsoFunctor f, ProductConstructor (a -> b)) =>
(a -> b) -> f a -> f b
|$| ProductConst (DList Int) (a a)
forall (f :: * -> *) a.
GFieldWidthList f =>
ProductConst (DList Int) (f a)
gFieldWidthList ProductConst (DList Int) (b a -> (:*:) a b a)
-> ProductConst (DList Int) (b a)
-> ProductConst (DList Int) ((:*:) a b a)
forall (f :: * -> *) a b.
ProductIsoApplicative f =>
f (a -> b) -> f a -> f b
|*| ProductConst (DList Int) (b a)
forall (f :: * -> *) a.
GFieldWidthList f =>
ProductConst (DList Int) (f a)
gFieldWidthList
instance GFieldWidthList a => GFieldWidthList (M1 i c a) where
gFieldWidthList :: ProductConst (DList Int) (M1 i c a a)
gFieldWidthList = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a)
-> ProductConst (DList Int) (a a)
-> ProductConst (DList Int) (M1 i c a a)
forall (f :: * -> *) a b.
(ProductIsoFunctor f, ProductConstructor (a -> b)) =>
(a -> b) -> f a -> f b
|$| ProductConst (DList Int) (a a)
forall (f :: * -> *) a.
GFieldWidthList f =>
ProductConst (DList Int) (f a)
gFieldWidthList
instance PersistableWidth a => GFieldWidthList (K1 i a) where
gFieldWidthList :: ProductConst (DList Int) (K1 i a a)
gFieldWidthList = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a)
-> ProductConst (DList Int) a
-> ProductConst (DList Int) (K1 i a a)
forall (f :: * -> *) a b.
(ProductIsoFunctor f, ProductConstructor (a -> b)) =>
(a -> b) -> f a -> f b
|$| (Sum Int -> DList Int)
-> ProductConst (Sum Int) a -> ProductConst (DList Int) a
forall a b c. (a -> b) -> ProductConst a c -> ProductConst b c
pmapConst (Int -> DList Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> DList Int) -> (Sum Int -> Int) -> Sum Int -> DList Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum) ProductConst (Sum Int) a
forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth
offsets :: [Int] -> Array Int Int
offsets :: [Int] -> Array Int Int
offsets ws :: [Int]
ws = (Int, Int) -> [Int] -> Array Int Int
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (0, [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ws) ([Int] -> Array Int Int) -> [Int] -> Array Int Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 0 [Int]
ws
genericFieldOffsets :: (Generic a, GFieldWidthList (Rep a)) => ProductConst (Array Int Int) a
genericFieldOffsets :: ProductConst (Array Int Int) a
genericFieldOffsets = (DList Int -> Array Int Int)
-> ProductConst (DList Int) a -> ProductConst (Array Int Int) a
forall a b c. (a -> b) -> ProductConst a c -> ProductConst b c
pmapConst ([Int] -> Array Int Int
offsets ([Int] -> Array Int Int)
-> (DList Int -> [Int]) -> DList Int -> Array Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList Int -> [Int]
forall a. DList a -> [a]
DList.toList) (ProductConst (DList Int) a -> ProductConst (Array Int Int) a)
-> ProductConst (DList Int) a -> ProductConst (Array Int Int) a
forall a b. (a -> b) -> a -> b
$ Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a)
-> ProductConst (DList Int) (Rep a Any)
-> ProductConst (DList Int) a
forall e a b.
Monoid e =>
(a -> b) -> ProductConst e a -> ProductConst e b
`pmap'` ProductConst (DList Int) (Rep a Any)
forall (f :: * -> *) a.
GFieldWidthList f =>
ProductConst (DList Int) (f a)
gFieldWidthList
instance PersistableWidth a => PersistableWidth (Maybe a) where
persistableWidth :: PersistableRecordWidth (Maybe a)
persistableWidth = PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
forall a.
PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
maybeWidth PersistableRecordWidth a
forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth
instance PersistableWidth ()
derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int)
derivedWidth :: (PersistableRecordWidth a, Int)
derivedWidth = (PersistableRecordWidth a
pw, PersistableRecordWidth a -> Int
forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth PersistableRecordWidth a
pw) where
pw :: PersistableRecordWidth a
pw = PersistableRecordWidth a
forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth