{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TupleSections #-}
module Opaleye.Internal.PackMap where
import qualified Opaleye.Internal.Tag as T
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Control.Applicative (liftA2)
import Control.Arrow (first, second)
import qualified Control.Monad.Trans.State as State
import Data.Profunctor (Profunctor, dimap, rmap)
import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import qualified Data.Functor.Identity as I
newtype PackMap a b s t =
PackMap (forall f. Applicative f => (a -> f b) -> s -> f t)
traversePM :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t
traversePM :: forall (f :: * -> *) a b s t.
Applicative f =>
PackMap a b s t -> (a -> f b) -> s -> f t
traversePM (PackMap forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
f) = (a -> f b) -> s -> f t
forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
f
overPM :: PackMap a b s t -> (a -> b) -> s -> t
overPM :: forall a b s t. PackMap a b s t -> (a -> b) -> s -> t
overPM PackMap a b s t
p a -> b
f = Identity t -> t
forall a. Identity a -> a
I.runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackMap a b s t -> (a -> Identity b) -> s -> Identity t
forall (f :: * -> *) a b s t.
Applicative f =>
PackMap a b s t -> (a -> f b) -> s -> f t
traversePM PackMap a b s t
p (b -> Identity b
forall a. a -> Identity a
I.Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
type PM a = State.State (a, Int)
new :: PM a String
new :: forall a. PM a String
new = do
(a
a, Int
i) <- StateT (a, Int) Identity (a, Int)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
(a, Int) -> StateT (a, Int) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (a
a, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
String -> PM a String
forall a. a -> StateT (a, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String
forall a. Show a => a -> String
show Int
i)
write :: a -> PM [a] ()
write :: forall a. a -> PM [a] ()
write a
a = do
([a]
as, Int
i) <- StateT ([a], Int) Identity ([a], Int)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
([a], Int) -> PM [a] ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ([a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
a], Int
i)
run :: PM [a] r -> (r, [a])
run :: forall a r. PM [a] r -> (r, [a])
run PM [a] r
m = (r
r, [a]
as)
where (r
r, ([a]
as, Int
_)) = PM [a] r -> ([a], Int) -> (r, ([a], Int))
forall s a. State s a -> s -> (a, s)
State.runState PM [a] r
m ([], Int
0)
extractAttrPE :: (primExpr -> String -> String)
-> T.Tag
-> primExpr
-> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
primExpr -> String -> String
mkName Tag
t primExpr
pe = do
String
i <- PM [(Symbol, primExpr)] String
forall a. PM a String
new
let s :: Symbol
s = String -> Tag -> Symbol
HPQ.Symbol (primExpr -> String -> String
mkName primExpr
pe String
i) Tag
t
(Symbol, primExpr) -> PM [(Symbol, primExpr)] ()
forall a. a -> PM [a] ()
write (Symbol
s, primExpr
pe)
PrimExpr -> PM [(Symbol, primExpr)] PrimExpr
forall a. a -> StateT ([(Symbol, primExpr)], Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> PrimExpr
HPQ.AttrExpr Symbol
s)
extractAttr :: String
-> T.Tag
-> primExpr
-> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
String
s = (primExpr -> String -> String)
-> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
forall primExpr.
(primExpr -> String -> String)
-> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
extractAttrPE ((String -> String) -> primExpr -> String -> String
forall a b. a -> b -> a
const (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++))
isoState ::
Functor m =>
(s1 -> s2) ->
(s2 -> s1) ->
State.StateT s1 m a ->
State.StateT s2 m a
isoState :: forall (m :: * -> *) s1 s2 a.
Functor m =>
(s1 -> s2) -> (s2 -> s1) -> StateT s1 m a -> StateT s2 m a
isoState s1 -> s2
to s2 -> s1
from =
(s2 -> m (a, s2)) -> StateT s2 m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((s2 -> m (a, s2)) -> StateT s2 m a)
-> (StateT s1 m a -> s2 -> m (a, s2))
-> StateT s1 m a
-> StateT s2 m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((((a, s1) -> (a, s2)) -> m (a, s1) -> m (a, s2)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, s1) -> (a, s2)) -> m (a, s1) -> m (a, s2))
-> ((s1 -> s2) -> (a, s1) -> (a, s2))
-> (s1 -> s2)
-> m (a, s1)
-> m (a, s2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s1 -> s2) -> (a, s1) -> (a, s2)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second) s1 -> s2
to (m (a, s1) -> m (a, s2)) -> (s2 -> m (a, s1)) -> s2 -> m (a, s2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((s2 -> m (a, s1)) -> s2 -> m (a, s2))
-> (StateT s1 m a -> s2 -> m (a, s1))
-> StateT s1 m a
-> s2
-> m (a, s2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((s1 -> m (a, s1)) -> (s2 -> s1) -> s2 -> m (a, s1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s2 -> s1
from) ((s1 -> m (a, s1)) -> s2 -> m (a, s1))
-> (StateT s1 m a -> s1 -> m (a, s1))
-> StateT s1 m a
-> s2
-> m (a, s1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT s1 m a -> s1 -> m (a, s1)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT
extract :: String -> T.Tag -> PM [HPQ.Symbol] HPQ.PrimExpr
String
s Tag
t = (([(Symbol, ())], Int) -> ([Symbol], Int))
-> (([Symbol], Int) -> ([(Symbol, ())], Int))
-> StateT ([(Symbol, ())], Int) Identity PrimExpr
-> PM [Symbol] PrimExpr
forall (m :: * -> *) s1 s2 a.
Functor m =>
(s1 -> s2) -> (s2 -> s1) -> StateT s1 m a -> StateT s2 m a
isoState ([(Symbol, ())], Int) -> ([Symbol], Int)
forall {b} {b} {d}. ([(b, b)], d) -> ([b], d)
to ([Symbol], Int) -> ([(Symbol, ())], Int)
forall {a} {d}. ([a], d) -> ([(a, ())], d)
from (String
-> Tag -> () -> StateT ([(Symbol, ())], Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
extractAttr String
s Tag
t ())
where
to :: ([(b, b)], d) -> ([b], d)
to = (([(b, b)] -> [b]) -> ([(b, b)], d) -> ([b], d)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([(b, b)] -> [b]) -> ([(b, b)], d) -> ([b], d))
-> (((b, b) -> b) -> [(b, b)] -> [b])
-> ((b, b) -> b)
-> ([(b, b)], d)
-> ([b], d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, b) -> b) -> [(b, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (b, b) -> b
forall a b. (a, b) -> a
fst
from :: ([a], d) -> ([(a, ())], d)
from = (([a] -> [(a, ())]) -> ([a], d) -> ([(a, ())], d)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([a] -> [(a, ())]) -> ([a], d) -> ([(a, ())], d))
-> ((a -> (a, ())) -> [a] -> [(a, ())])
-> (a -> (a, ()))
-> ([a], d)
-> ([(a, ())], d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, ())) -> [a] -> [(a, ())]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\a
x -> (a
x, ()))
eitherFunction :: (PP.SumProfunctor p, Functor f)
=> p a (f b)
-> p a' (f b')
-> p (Either a a') (f (Either b b'))
eitherFunction :: forall (p :: * -> * -> *) (f :: * -> *) a b a' b'.
(SumProfunctor p, Functor f) =>
p a (f b) -> p a' (f b') -> p (Either a a') (f (Either b b'))
eitherFunction p a (f b)
f p a' (f b')
g = (Either (f b) (f b') -> f (Either b b'))
-> p (Either a a') (Either (f b) (f b'))
-> p (Either a a') (f (Either b b'))
forall b c a. (b -> c) -> p a b -> p a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((f b -> f (Either b b'))
-> (f b' -> f (Either b b'))
-> Either (f b) (f b')
-> f (Either b b')
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((b -> Either b b') -> f b -> f (Either b b')
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either b b'
forall a b. a -> Either a b
Left) ((b' -> Either b b') -> f b' -> f (Either b b')
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b' -> Either b b'
forall a b. b -> Either a b
Right)) (p a (f b)
f p a (f b) -> p a' (f b') -> p (Either a a') (Either (f b) (f b'))
forall a b a' b'. p a b -> p a' b' -> p (Either a a') (Either b b')
forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
PP.+++! p a' (f b')
g)
iso :: (s -> a) -> (b -> t) -> PackMap a b s t
iso :: forall s a b t. (s -> a) -> (b -> t) -> PackMap a b s t
iso s -> a
h b -> t
g = (forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap ((s -> a) -> (f b -> f t) -> (a -> f b) -> s -> f t
forall a b c d. (a -> b) -> (c -> d) -> (b -> c) -> a -> d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
h ((b -> t) -> f b -> f t
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
g))
instance Functor (PackMap a b s) where
fmap :: forall a b. (a -> b) -> PackMap a b s a -> PackMap a b s b
fmap a -> b
f (PackMap forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f a
g) = (forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f b)
-> PackMap a b s b
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap ((((s -> f a) -> s -> f b)
-> ((a -> f b) -> s -> f a) -> (a -> f b) -> s -> f b
forall a b. (a -> b) -> ((a -> f b) -> a) -> (a -> f b) -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((s -> f a) -> s -> f b)
-> ((a -> f b) -> s -> f a) -> (a -> f b) -> s -> f b)
-> ((a -> b) -> (s -> f a) -> s -> f b)
-> (a -> b)
-> ((a -> f b) -> s -> f a)
-> (a -> f b)
-> s
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> f b) -> (s -> f a) -> s -> f b
forall a b. (a -> b) -> (s -> a) -> s -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f a -> f b) -> (s -> f a) -> s -> f b)
-> ((a -> b) -> f a -> f b) -> (a -> b) -> (s -> f a) -> s -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f (a -> f b) -> s -> f a
forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f a
g)
instance Applicative (PackMap a b s) where
pure :: forall a. a -> PackMap a b s a
pure a
x = (forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f a)
-> PackMap a b s a
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap ((s -> f a) -> (a -> f b) -> s -> f a
forall a. a -> (a -> f b) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> s -> f a
forall a. a -> s -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)))
PackMap forall (f :: * -> *).
Applicative f =>
(a -> f b) -> s -> f (a -> b)
f <*> :: forall a b.
PackMap a b s (a -> b) -> PackMap a b s a -> PackMap a b s b
<*> PackMap forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f a
x = (forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f b)
-> PackMap a b s b
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (((s -> f (a -> b)) -> (s -> f a) -> s -> f b)
-> ((a -> f b) -> s -> f (a -> b))
-> ((a -> f b) -> s -> f a)
-> (a -> f b)
-> s
-> f b
forall a b c.
(a -> b -> c)
-> ((a -> f b) -> a) -> ((a -> f b) -> b) -> (a -> f b) -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((f (a -> b) -> f a -> f b)
-> (s -> f (a -> b)) -> (s -> f a) -> s -> f b
forall a b c. (a -> b -> c) -> (s -> a) -> (s -> b) -> s -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)) (a -> f b) -> s -> f (a -> b)
forall (f :: * -> *).
Applicative f =>
(a -> f b) -> s -> f (a -> b)
f (a -> f b) -> s -> f a
forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f a
x)
instance Profunctor (PackMap a b) where
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> PackMap a b b c -> PackMap a b a d
dimap a -> b
f c -> d
g (PackMap forall (f :: * -> *). Applicative f => (a -> f b) -> b -> f c
q) = (forall (f :: * -> *). Applicative f => (a -> f b) -> a -> f d)
-> PackMap a b a d
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (((b -> f c) -> a -> f d)
-> ((a -> f b) -> b -> f c) -> (a -> f b) -> a -> f d
forall a b. (a -> b) -> ((a -> f b) -> a) -> (a -> f b) -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (f c -> f d) -> (b -> f c) -> a -> f d
forall a b c d. (a -> b) -> (c -> d) -> (b -> c) -> a -> d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f ((c -> d) -> f c -> f d
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g)) (a -> f b) -> b -> f c
forall (f :: * -> *). Applicative f => (a -> f b) -> b -> f c
q)
instance ProductProfunctor (PackMap a b) where
purePP :: forall b a. b -> PackMap a b a b
purePP = b -> PackMap a b a b
forall a. a -> PackMap a b a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a b c.
PackMap a b a (b -> c) -> PackMap a b a b -> PackMap a b a c
(****) = PackMap a b a (b -> c) -> PackMap a b a b -> PackMap a b a c
forall a b.
PackMap a b a (a -> b) -> PackMap a b a a -> PackMap a b a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
instance PP.SumProfunctor (PackMap a b) where
PackMap forall (f :: * -> *). Applicative f => (a -> f b) -> a -> f b
f +++! :: forall a b a' b'.
PackMap a b a b
-> PackMap a b a' b' -> PackMap a b (Either a a') (Either b b')
+++! PackMap forall (f :: * -> *). Applicative f => (a -> f b) -> a' -> f b'
g = (forall (f :: * -> *).
Applicative f =>
(a -> f b) -> Either a a' -> f (Either b b'))
-> PackMap a b (Either a a') (Either b b')
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (\a -> f b
x -> (a -> f b) -> (a' -> f b') -> Either a a' -> f (Either b b')
forall (p :: * -> * -> *) (f :: * -> *) a b a' b'.
(SumProfunctor p, Functor f) =>
p a (f b) -> p a' (f b') -> p (Either a a') (f (Either b b'))
eitherFunction ((a -> f b) -> a -> f b
forall (f :: * -> *). Applicative f => (a -> f b) -> a -> f b
f a -> f b
x) ((a -> f b) -> a' -> f b'
forall (f :: * -> *). Applicative f => (a -> f b) -> a' -> f b'
g a -> f b
x))