{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
-- Module      : Database.Record.Persistable
-- Copyright   : 2013-2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines proposition interfaces
-- for database value type and record type width.
module Database.Record.Persistable (
  -- * Specify database value type
  PersistableSqlType, runPersistableNullValue, unsafePersistableSqlTypeFromNull,

  -- * Specify record width
  PersistableRecordWidth, runPersistableRecordWidth,
  unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth,

  -- * Implicit derivation rules, database value type and record type width
  PersistableType(..), sqlNullValue,
  PersistableWidth (..), derivedWidth,

  -- * low-level interfaces
  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, (|*|), )


-- | Proposition to specify type 'q' is database value type, contains null value
newtype PersistableSqlType q = PersistableSqlType q

-- | Null value of database value type 'q'.
runPersistableNullValue :: PersistableSqlType q -> q
runPersistableNullValue :: forall q. PersistableSqlType q -> q
runPersistableNullValue (PersistableSqlType q
q) = q
q

-- | Unsafely specify 'PersistableSqlType' axiom from specified database null value which type is 'q'.
unsafePersistableSqlTypeFromNull :: q                    -- ^ null value of database value type 'q'
                                 -> PersistableSqlType q -- ^ Result proof object
unsafePersistableSqlTypeFromNull :: forall q. q -> PersistableSqlType q
unsafePersistableSqlTypeFromNull =  forall q. q -> PersistableSqlType q
PersistableSqlType


-- | Restricted in product isomorphism record type b
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)

-- | extract constant value of 'ProductConst'.
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 #-}

-- | Proposition to specify width of Haskell type 'a'.
--   The width is length of database value list which is converted from Haskell type 'a'.
type PersistableRecordWidth a = ProductConst (Sum Int) a

-- unsafely map PersistableRecordWidth
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


-- | Get width 'Int' value of record type 'a'.
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

-- | Unsafely specify 'PersistableRecordWidth' axiom from specified width of Haskell type 'a'.
unsafePersistableRecordWidth :: Int                      -- ^ Specify width of Haskell type 'a'
                             -> PersistableRecordWidth a -- ^ Result proof object
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 #-}

-- | Unsafely specify 'PersistableRecordWidth' axiom for Haskell type 'a' which is single column type.
unsafeValueWidth :: PersistableRecordWidth a
unsafeValueWidth :: forall a. PersistableRecordWidth a
unsafeValueWidth =  forall a. Int -> PersistableRecordWidth a
unsafePersistableRecordWidth Int
1
{-# INLINE unsafeValueWidth #-}

-- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type.
(<&>) :: 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

-- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'.
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


-- | Interface of derivation rule for 'PersistableSqlType'.
class Eq q => PersistableType q where
  persistableType :: PersistableSqlType q

-- | Implicitly derived null value of database value type.
sqlNullValue :: PersistableType q => q
sqlNullValue :: forall q. PersistableType q => q
sqlNullValue =  forall q. PersistableSqlType q -> q
runPersistableNullValue forall q. PersistableType q => PersistableSqlType q
persistableType


{- |
'PersistableWidth' 'a' is implicit rule to derive 'PersistableRecordWidth' 'a' width proposition for type 'a'.

Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#generic-programming>)
with default signature is available for 'PersistableWidth' class,
so you can make instance like below:

@
  \{\-\# LANGUAGE DeriveGeneric \#\-\}
  import GHC.Generics (Generic)
  --
  data Foo = Foo { ... } deriving Generic
  instance PersistableWidth Foo
@

-}
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

-- | Generic width value list of record fields.
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

-- | Generic offset array of record fields.
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


-- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type.
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

-- | Inference rule of 'PersistableRecordWidth' for Haskell unit () type. Derive from axiom.
instance PersistableWidth ()  -- default generic instance

-- | Pass type parameter and inferred width value.
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