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)
import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import qualified Data.Functor.Identity as I
data PackMap a b s t = PackMap (Applicative f =>
(a -> f b) -> s -> f t)
packmap :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t
packmap (PackMap f) = f
over :: PackMap a b s t -> (a -> b) -> s -> t
over p f = I.runIdentity . packmap p (I.Identity . f)
type PM a = State.State (a, Int)
new :: PM a String
new = do
(a, i) <- State.get
State.put (a, i + 1)
return (show i)
write :: a -> PM [a] ()
write a = do
(as, i) <- State.get
State.put (as ++ [a], i)
run :: PM [a] r -> (r, [a])
run m = (r, as)
where (r, (as, _)) = State.runState m ([], 0)
extractAttr :: (String -> String) -> T.Tag -> a
-> PM [(String, a)] HPQ.PrimExpr
extractAttr = extractAttrPE . const
extractAttrPE :: (a -> String -> String) -> T.Tag -> a
-> PM [(String, a)] HPQ.PrimExpr
extractAttrPE mkName t pe = do
i <- new
let s = T.tagWith t (mkName pe i)
write (s, pe)
return (HPQ.AttrExpr s)
instance Functor (PackMap a b s) where
fmap f (PackMap g) = PackMap ((fmap . fmap . fmap) f g)
instance Applicative (PackMap a b s) where
pure x = PackMap (pure (pure (pure x)))
PackMap f <*> PackMap x = PackMap (liftA2 (liftA2 (<*>)) f x)
instance Profunctor (PackMap a b) where
dimap f g (PackMap q) = PackMap (fmap (dimap f (fmap g)) q)
instance ProductProfunctor (PackMap a b) where
empty = PP.defaultEmpty
(***!) = PP.defaultProfunctorProduct