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