module Database.Relational.Query.Pi.Unsafe (
Pi,
pfmap, pap,
pzero,
width', width,
(<.>), (<?.>), (<?.?>),
pi,
definePi, defineDirectPi', defineDirectPi,
unsafeExpandIndexes',
unsafeExpandIndexes
) where
import Prelude hiding (pi, (.), id)
import Control.Category (Category (..), (>>>))
import Data.Array (listArray, (!))
import Database.Record.Persistable
(PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>),
PersistableWidth (persistableWidth), maybeWidth)
import Database.Relational.Query.ProjectableClass
(ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), )
data Pi' r0 r1 = Leftest Int
| Map [Int]
unsafePiAppend' :: Pi' a b' -> Pi' b c' -> Pi' a c
unsafePiAppend' = d where
d (Leftest i) (Leftest j) = Leftest $ i + j
d (Leftest i) (Map js) = Map $ map (i +) js
d (Map is) (Leftest j) = Map $ drop j is
d (Map is) (Map js) = Map [ is' ! j | j <- js ] where
is' = listArray (0, length is) is
newtype Pi r0 r1 = Pi { runPi :: PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1) }
instance PersistableWidth r0 => Show (Pi r0 r1) where
show p = unwords ["Pi", show $ unsafeExpandIndexes p]
unsafePiAppend :: (PersistableRecordWidth b' -> PersistableRecordWidth b)
-> (PersistableRecordWidth c' -> PersistableRecordWidth c)
-> Pi a b' -> Pi b c' -> Pi a c
unsafePiAppend wbf wcf (Pi f) (Pi g) = Pi $ \wa ->
let (pab, wb) = f wa
(pbc, wc) = g $ wbf wb
in (pab `unsafePiAppend'` pbc, wcf wc)
unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int]
unsafeExpandIndexes' wa (Pi f) = d $ f wa where
d (Map is, _) = is
d (Leftest i, w) = [ i .. i + w' 1 ] where
w' = runPersistableRecordWidth w
unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int]
unsafeExpandIndexes = unsafeExpandIndexes' persistableWidth
unsafeCastRecordWidth :: PersistableRecordWidth a -> PersistableRecordWidth a'
unsafeCastRecordWidth = unsafePersistableRecordWidth . runPersistableRecordWidth
unsafeCast :: Pi a b' -> Pi a b
unsafeCast = c where
d (Leftest i) = Leftest i
d (Map m) = Map m
c (Pi f) = Pi $ \wa ->
let (pb, wb) = f wa in
(d pb, unsafeCastRecordWidth wb)
pfmap :: ProductConstructor (a -> b)
=> (a -> b) -> Pi r a -> Pi r b
_ `pfmap` p = unsafeCast p
pap :: Pi r (a -> b) -> Pi r a -> Pi r b
pap pab pb =
Pi $ \wr ->
let (_, wab) = runPi pab wr
(_, wb) = runPi pb wr in
(Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb,
unsafeCastRecordWidth $ wab <&> wb)
instance ProjectableFunctor (Pi a) where
(|$|) = pfmap
instance ProjectableApplicative (Pi a) where
(|*|) = pap
pzero :: Pi a ()
pzero = Pi $ \_ -> (Map [], persistableWidth)
width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct
width' (Pi f) = snd $ f persistableWidth
width :: PersistableWidth r => Pi r a -> Int
width = runPersistableRecordWidth . width'
justWidth :: PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a
justWidth = unsafeCastRecordWidth
instance Category Pi where
id = Pi $ \pw -> (Leftest 0, pw)
Pi fb . Pi fa = Pi $ \wa ->
let (pb, wb) = fa wa
(pc, wc) = fb wb
in (unsafePiAppend' pb pc, wc)
(<.>) :: Pi a b -> Pi b c -> Pi a c
(<.>) = (>>>)
(<?.>) :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)
(<?.>) = unsafePiAppend justWidth maybeWidth
(<?.?>) :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c)
(<?.?>) = unsafePiAppend justWidth id
infixl 8 <.>, <?.>, <?.?>
pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a]
pi w0 (Pi f) cs = d p' where
(p', w1) = f w0
d (Leftest i) = take (runPersistableRecordWidth w1) . drop i $ cs
d (Map is) = [cs' ! i | i <- is]
cs' = listArray (0, length cs) cs
definePi' :: PersistableRecordWidth r1
-> Int
-> Pi r0 r1
definePi' pw i = Pi $ \_ -> (Leftest i, pw)
definePi :: PersistableWidth r1
=> Int
-> Pi r0 r1
definePi = definePi' persistableWidth
defineDirectPi' :: PersistableRecordWidth r1
-> [Int]
-> Pi r0 r1
defineDirectPi' pw is = Pi $ \_ -> (Map is, pw)
defineDirectPi :: PersistableWidth r1
=> [Int]
-> Pi r0 r1
defineDirectPi = defineDirectPi' persistableWidth