{-# LANGUAGE Rank2Types #-}
module Opaleye.Internal.PackMap where
import qualified Opaleye.Internal.Tag as T
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Control.Applicative (Applicative, pure, (<*>), liftA2)
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]
++))
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))