{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.Relational.Pi.Unsafe
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines typed projection path objects.
-- Contains internal structure and unsafe interfaces.
module Database.Relational.Pi.Unsafe (
  -- * Projection path
  Pi,

  width', width,

  (<.>), (<?.>), (<?.?>),

  pi,

  definePi, defineDirectPi', defineDirectPi,

  expandIndexes', expandIndexes,

  -- * Deprecated
  unsafeExpandIndexes',
  unsafeExpandIndexes
  ) where

import Prelude hiding (pi, (.), id)
import Control.Category (Category (..), (>>>))
import Data.Array (listArray, (!))
import Data.Functor.ProductIsomorphic
  (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|),
   ProductIsoEmpty, pureE, peRight, peLeft, )

import Database.Record.Persistable
  (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth,
   PersistableWidth (persistableWidth), maybeWidth)


-- | Projection path primary structure type.
data Pi' r0 r1 = Leftest Int
               | Map [Int]

unsafePiAppend' :: Pi' a b' -> Pi' b c' -> Pi' a c
unsafePiAppend' :: forall a b' b c' c. Pi' a b' -> Pi' b c' -> Pi' a c
unsafePiAppend' = forall {r0} {r1} {r0} {r1} {r0} {r1}.
Pi' r0 r1 -> Pi' r0 r1 -> Pi' r0 r1
d  where
  d :: Pi' r0 r1 -> Pi' r0 r1 -> Pi' r0 r1
d (Leftest Int
i) (Leftest Int
j) = forall r0 r1. Int -> Pi' r0 r1
Leftest forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
j
  d (Leftest Int
i) (Map [Int]
js)    = forall r0 r1. [Int] -> Pi' r0 r1
Map forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int
i forall a. Num a => a -> a -> a
+) [Int]
js
  d (Map [Int]
is)    (Leftest Int
j) = forall r0 r1. [Int] -> Pi' r0 r1
Map forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
j [Int]
is
  d (Map [Int]
is)    (Map [Int]
js)    = forall r0 r1. [Int] -> Pi' r0 r1
Map   [ Array Int Int
is' forall i e. Ix i => Array i e -> i -> e
! Int
j | Int
j <- [Int]
js ]  where
    is' :: Array Int Int
is' = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
is) [Int]
is

-- | Projection path from type 'r0' into type 'r1'.
--   This type also indicate key object which type is 'r1' for record type 'r0'.
newtype Pi r0 r1 = Pi { forall r0 r1.
Pi r0 r1
-> PersistableRecordWidth r0
-> (Pi' r0 r1, PersistableRecordWidth r1)
runPi :: PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1) }

instance PersistableWidth r0 => Show (Pi r0 r1) where
  show :: Pi r0 r1 -> String
show Pi r0 r1
p = [String] -> String
unwords [String
"Pi", forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a b. PersistableWidth a => Pi a b -> [Int]
unsafeExpandIndexes Pi r0 r1
p]

unsafePiAppend :: (PersistableRecordWidth b' -> PersistableRecordWidth b)
               -> (PersistableRecordWidth c' -> PersistableRecordWidth c)
               -> Pi a b' -> Pi b c' -> Pi a c
unsafePiAppend :: forall b' b c' c a.
(PersistableRecordWidth b' -> PersistableRecordWidth b)
-> (PersistableRecordWidth c' -> PersistableRecordWidth c)
-> Pi a b'
-> Pi b c'
-> Pi a c
unsafePiAppend PersistableRecordWidth b' -> PersistableRecordWidth b
wbf PersistableRecordWidth c' -> PersistableRecordWidth c
wcf (Pi PersistableRecordWidth a -> (Pi' a b', PersistableRecordWidth b')
f) (Pi PersistableRecordWidth b -> (Pi' b c', PersistableRecordWidth c')
g) = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth a
wa ->
  let (Pi' a b'
pab, PersistableRecordWidth b'
wb) = PersistableRecordWidth a -> (Pi' a b', PersistableRecordWidth b')
f PersistableRecordWidth a
wa
      (Pi' b c'
pbc, PersistableRecordWidth c'
wc) = PersistableRecordWidth b -> (Pi' b c', PersistableRecordWidth c')
g forall a b. (a -> b) -> a -> b
$ PersistableRecordWidth b' -> PersistableRecordWidth b
wbf PersistableRecordWidth b'
wb
  in (Pi' a b'
pab forall a b' b c' c. Pi' a b' -> Pi' b c' -> Pi' a c
`unsafePiAppend'` Pi' b c'
pbc, PersistableRecordWidth c' -> PersistableRecordWidth c
wcf PersistableRecordWidth c'
wc)

-- | Expand indexes from key.
expandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int]
expandIndexes' :: forall a b. PersistableRecordWidth a -> Pi a b -> [Int]
expandIndexes' PersistableRecordWidth a
wa (Pi PersistableRecordWidth a -> (Pi' a b, PersistableRecordWidth b)
f) = forall {r0} {r1} {a}.
(Pi' r0 r1, PersistableRecordWidth a) -> [Int]
d forall a b. (a -> b) -> a -> b
$ PersistableRecordWidth a -> (Pi' a b, PersistableRecordWidth b)
f PersistableRecordWidth a
wa where
  d :: (Pi' r0 r1, PersistableRecordWidth a) -> [Int]
d (Map [Int]
is, PersistableRecordWidth a
_)    = [Int]
is
  d (Leftest Int
i, PersistableRecordWidth a
w) = [ Int
i .. Int
i forall a. Num a => a -> a -> a
+ Int
w' forall a. Num a => a -> a -> a
- Int
1 ]  where
    w' :: Int
w' = forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth PersistableRecordWidth a
w

unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int]
unsafeExpandIndexes' :: forall a b. PersistableRecordWidth a -> Pi a b -> [Int]
unsafeExpandIndexes' = forall a b. PersistableRecordWidth a -> Pi a b -> [Int]
expandIndexes'
{-# DEPRECATED unsafeExpandIndexes' "Use expandIndexes' instead of this." #-}

-- | Expand indexes from key. Inferred width version.
expandIndexes :: PersistableWidth a => Pi a b -> [Int]
expandIndexes :: forall a b. PersistableWidth a => Pi a b -> [Int]
expandIndexes = forall a b. PersistableRecordWidth a -> Pi a b -> [Int]
expandIndexes' forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth

unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int]
unsafeExpandIndexes :: forall a b. PersistableWidth a => Pi a b -> [Int]
unsafeExpandIndexes = forall a b. PersistableWidth a => Pi a b -> [Int]
expandIndexes
{-# DEPRECATED unsafeExpandIndexes "use expandIndexes instead of this." #-}

-- | Unsafely cast width proof object of record. Result record must be same width.
unsafeCastRecordWidth :: PersistableRecordWidth a -> PersistableRecordWidth a'
unsafeCastRecordWidth :: forall a a'. PersistableRecordWidth a -> PersistableRecordWidth a'
unsafeCastRecordWidth =  forall a. Int -> PersistableRecordWidth a
unsafePersistableRecordWidth forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth

unsafeCast :: Pi a b' -> Pi a b
unsafeCast :: forall a b' b. Pi a b' -> Pi a b
unsafeCast =  forall a b' b. Pi a b' -> Pi a b
c  where
  d :: Pi' r0 r1 -> Pi' r0 r1
d (Leftest Int
i) = forall r0 r1. Int -> Pi' r0 r1
Leftest Int
i
  d (Map [Int]
m)     = forall r0 r1. [Int] -> Pi' r0 r1
Map [Int]
m
  c :: Pi r0 a -> Pi r0 r1
c (Pi PersistableRecordWidth r0 -> (Pi' r0 a, PersistableRecordWidth a)
f)    = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth r0
wa ->
    let (Pi' r0 a
pb, PersistableRecordWidth a
wb) = PersistableRecordWidth r0 -> (Pi' r0 a, PersistableRecordWidth a)
f PersistableRecordWidth r0
wa in
    (forall {r0} {r1} {r0} {r1}. Pi' r0 r1 -> Pi' r0 r1
d Pi' r0 a
pb, forall a a'. PersistableRecordWidth a -> PersistableRecordWidth a'
unsafeCastRecordWidth PersistableRecordWidth a
wb)

-- | 'Pi' with zero width which projects to unit
pzero :: Pi a ()
pzero :: forall a. Pi a ()
pzero = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth a
_ -> (forall r0 r1. [Int] -> Pi' r0 r1
Map [], forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth)

-- | Map projection path 'Pi' which has record result type.
instance ProductIsoFunctor (Pi a) where
  a -> b
_ |$| :: forall a b.
ProductConstructor (a -> b) =>
(a -> b) -> Pi a a -> Pi a b
|$| Pi a a
p = forall a b' b. Pi a b' -> Pi a b
unsafeCast Pi a a
p

-- | Compose projection path 'Pi' which has record result type using applicative style.
instance ProductIsoApplicative (Pi a) where
  pureP :: forall a. ProductConstructor a => a -> Pi a a
pureP a
_ = forall a b' b. Pi a b' -> Pi a b
unsafeCast forall a. Pi a ()
pzero
  Pi a (a -> b)
pab |*| :: forall a b. Pi a (a -> b) -> Pi a a -> Pi a b
|*| Pi a a
pb =
    forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth a
wr ->
           let (Pi' a (a -> b)
_, PersistableRecordWidth (a -> b)
wab) = forall r0 r1.
Pi r0 r1
-> PersistableRecordWidth r0
-> (Pi' r0 r1, PersistableRecordWidth r1)
runPi Pi a (a -> b)
pab PersistableRecordWidth a
wr
               (Pi' a a
_, PersistableRecordWidth a
wb)  = forall r0 r1.
Pi r0 r1
-> PersistableRecordWidth r0
-> (Pi' r0 r1, PersistableRecordWidth r1)
runPi Pi a a
pb  PersistableRecordWidth a
wr in
             (forall r0 r1. [Int] -> Pi' r0 r1
Map forall a b. (a -> b) -> a -> b
$ forall a b. PersistableRecordWidth a -> Pi a b -> [Int]
unsafeExpandIndexes' PersistableRecordWidth a
wr Pi a (a -> b)
pab forall a. [a] -> [a] -> [a]
++ forall a b. PersistableRecordWidth a -> Pi a b -> [Int]
unsafeExpandIndexes' PersistableRecordWidth a
wr Pi a a
pb,
              PersistableRecordWidth (a -> b)
wab forall (f :: * -> *) a b.
ProductIsoApplicative f =>
f (a -> b) -> f a -> f b
|*| PersistableRecordWidth a
wb)

instance ProductIsoEmpty (Pi a) () where
  pureE :: Pi a ()
pureE   = forall a. Pi a ()
pzero
  peRight :: forall a. Pi a (a, ()) -> Pi a a
peRight = forall a b' b. Pi a b' -> Pi a b
unsafeCast
  peLeft :: forall a. Pi a ((), a) -> Pi a a
peLeft  = forall a b' b. Pi a b' -> Pi a b
unsafeCast

-- | Get record width proof object.
width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct
width' :: forall r ct.
PersistableWidth r =>
Pi r ct -> PersistableRecordWidth ct
width' (Pi PersistableRecordWidth r -> (Pi' r ct, PersistableRecordWidth ct)
f) = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ PersistableRecordWidth r -> (Pi' r ct, PersistableRecordWidth ct)
f forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth

-- | Get record width.
width :: PersistableWidth r => Pi r a -> Int
width :: forall r a. PersistableWidth r => Pi r a -> Int
width =  forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r ct.
PersistableWidth r =>
Pi r ct -> PersistableRecordWidth ct
width'

justWidth :: PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a
justWidth :: forall a.
PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a
justWidth = forall a a'. PersistableRecordWidth a -> PersistableRecordWidth a'
unsafeCastRecordWidth


instance Category Pi where
  id :: forall a. Pi a a
id = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth a
pw -> (forall r0 r1. Int -> Pi' r0 r1
Leftest Int
0, PersistableRecordWidth a
pw)
  Pi PersistableRecordWidth b -> (Pi' b c, PersistableRecordWidth c)
fb . :: forall b c a. Pi b c -> Pi a b -> Pi a c
. Pi PersistableRecordWidth a -> (Pi' a b, PersistableRecordWidth b)
fa = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth a
wa ->
    let (Pi' a b
pb, PersistableRecordWidth b
wb) = PersistableRecordWidth a -> (Pi' a b, PersistableRecordWidth b)
fa PersistableRecordWidth a
wa
        (Pi' b c
pc, PersistableRecordWidth c
wc) = PersistableRecordWidth b -> (Pi' b c, PersistableRecordWidth c)
fb PersistableRecordWidth b
wb
    in (forall a b' b c' c. Pi' a b' -> Pi' b c' -> Pi' a c
unsafePiAppend' Pi' a b
pb Pi' b c
pc, PersistableRecordWidth c
wc)

-- | Compose projection path.
(<.>) :: Pi a b -> Pi b c -> Pi a c
<.> :: forall a b c. Pi a b -> Pi b c -> Pi a c
(<.>) = forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>)

-- | Compose projection path. 'Maybe' phantom functor is 'map'-ed.
(<?.>) :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)
<?.> :: forall a b c. Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)
(<?.>) = forall b' b c' c a.
(PersistableRecordWidth b' -> PersistableRecordWidth b)
-> (PersistableRecordWidth c' -> PersistableRecordWidth c)
-> Pi a b'
-> Pi b c'
-> Pi a c
unsafePiAppend forall a.
PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a
justWidth forall a.
PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
maybeWidth

-- | Compose projection path. 'Maybe' phantom functors are 'join'-ed like '>=>'.
(<?.?>) :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c)
<?.?> :: forall a b c. Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c)
(<?.?>) = forall b' b c' c a.
(PersistableRecordWidth b' -> PersistableRecordWidth b)
-> (PersistableRecordWidth c' -> PersistableRecordWidth c)
-> Pi a b'
-> Pi b c'
-> Pi a c
unsafePiAppend forall a.
PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a
justWidth forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

infixl 8 <.>, <?.>, <?.?>

-- | Unsafely project untyped value list.
pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a]
pi :: forall r0 r1 a. PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a]
pi PersistableRecordWidth r0
w0 (Pi PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1)
f) [a]
cs = forall {r0} {r1}. Pi' r0 r1 -> [a]
d Pi' r0 r1
p'  where
  (Pi' r0 r1
p', PersistableRecordWidth r1
w1) = PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1)
f PersistableRecordWidth r0
w0
  d :: Pi' r0 r1 -> [a]
d (Leftest Int
i) = forall a. Int -> [a] -> [a]
take (forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth PersistableRecordWidth r1
w1) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Int -> [a] -> [a]
drop Int
i forall a b. (a -> b) -> a -> b
$ [a]
cs
  d (Map [Int]
is)    = [Array Int a
cs' forall i e. Ix i => Array i e -> i -> e
! Int
i | Int
i <- [Int]
is]
  cs' :: Array Int a
cs' = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
cs) [a]
cs

-- | Unsafely define projection path from type 'r0' into type 'r1'.
definePi' :: PersistableRecordWidth r1
          -> Int      -- ^ Index of flat SQL value list
          -> Pi r0 r1 -- ^ Result projection path
definePi' :: forall r1 r0. PersistableRecordWidth r1 -> Int -> Pi r0 r1
definePi' PersistableRecordWidth r1
pw Int
i = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth r0
_ -> (forall r0 r1. Int -> Pi' r0 r1
Leftest Int
i, PersistableRecordWidth r1
pw)

-- | Unsafely define projection path from type 'r0' into type 'r1'.
--   Use inferred 'PersistableRecordWidth'.
definePi :: PersistableWidth r1
         => Int      -- ^ Index of flat SQL value list
         -> Pi r0 r1 -- ^ Result projection path
definePi :: forall r1 r0. PersistableWidth r1 => Int -> Pi r0 r1
definePi = forall r1 r0. PersistableRecordWidth r1 -> Int -> Pi r0 r1
definePi' forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth

-- | Unsafely define projection path from type 'r0' into type 'r1'.
defineDirectPi' :: PersistableRecordWidth r1
                -> [Int]    -- ^ Indexes of flat SQL value list
                -> Pi r0 r1 -- ^ Result projection path
defineDirectPi' :: forall r1 r0. PersistableRecordWidth r1 -> [Int] -> Pi r0 r1
defineDirectPi' PersistableRecordWidth r1
pw [Int]
is = forall r0 r1.
(PersistableRecordWidth r0
 -> (Pi' r0 r1, PersistableRecordWidth r1))
-> Pi r0 r1
Pi forall a b. (a -> b) -> a -> b
$ \PersistableRecordWidth r0
_ -> (forall r0 r1. [Int] -> Pi' r0 r1
Map [Int]
is, PersistableRecordWidth r1
pw)

-- | Unsafely define projection path from type 'r0' into type 'r1'.
--   Use inferred 'PersistableRecordWidth'.
defineDirectPi :: PersistableWidth r1
               => [Int]    -- ^ Indexes of flat SQL value list
               -> Pi r0 r1 -- ^ Result projection path
defineDirectPi :: forall r1 r0. PersistableWidth r1 => [Int] -> Pi r0 r1
defineDirectPi = forall r1 r0. PersistableRecordWidth r1 -> [Int] -> Pi r0 r1
defineDirectPi' forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth