{-# 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) = 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 = forall a. Identity a -> a
I.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a. a -> Identity a
I.Identity 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) <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (a
a, Int
i forall a. Num a => a -> a -> a
+ Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return (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) <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ([a]
as 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
_)) = 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 <- 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
forall a. a -> PM [a] ()
write (Symbol
s, primExpr
pe)
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 = forall primExpr.
(primExpr -> String -> String)
-> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
extractAttrPE (forall a b. a -> b -> a
const (String
s 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 =
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second) s1 -> s2
to forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b c a. (b -> c) -> (a -> b) -> a -> c
. s2 -> s1
from) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) s1 s2 a.
Functor m =>
(s1 -> s2) -> (s2 -> s1) -> StateT s1 m a -> StateT s2 m a
isoState forall {b} {b} {d}. ([(b, b)], d) -> ([b], d)
to forall {a} {d}. ([a], d) -> ([(a, ())], d)
from (forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
extractAttr String
s Tag
t ())
where
to :: ([(b, b)], d) -> ([b], d)
to = (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a b. (a, b) -> a
fst
from :: ([a], d) -> ([(a, ())], d)
from = (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right)) (p a (f b)
f 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 a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
h (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 a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f 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 a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)) forall (f :: * -> *).
Applicative f =>
(a -> f b) -> s -> f (a -> b)
f 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 a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g)) 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 = 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
(****) = 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 a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PackMap (\a -> f b
x -> 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 (forall (f :: * -> *). Applicative f => (a -> f b) -> a -> f b
f a -> f b
x) (forall (f :: * -> *). Applicative f => (a -> f b) -> a' -> f b'
g a -> f b
x))