{-# 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

-- This is rather like a Control.Lens.Traversal with the type
-- parameters switched but I'm not sure if it should be required to
-- obey the same laws.
--
-- TODO: We could attempt to generalise this to
--
-- data LensLike f a b s t = LensLike ((a -> f b) -> s -> f t)
--
-- i.e. a wrapped, argument-flipped Control.Lens.LensLike
--
-- This would allow us to do the Profunctor and ProductProfunctor
-- instances (requiring just Functor f and Applicative f respectively)
-- and share them between many different restrictions of f.  For
-- example, TableColumnMaker is like a Setter so we would restrict f
-- to the Distributive case.

-- | A 'PackMap' @a@ @b@ @s@ @t@ encodes how an @s@ contains an
-- updatable sequence of @a@ inside it.  Each @a@ in the sequence can
-- be updated to a @b@ (and the @s@ changes to a @t@ to reflect this
-- change of type).
--
-- 'PackMap' is just like a @Traversal@ from the lens package.
-- 'PackMap' has a different order of arguments to @Traversal@ because
-- it typically needs to be made a 'Profunctor' (and indeed
-- 'ProductProfunctor') in @s@ and @t@.  It is unclear at this point
-- whether we want the same @Traversal@ laws to hold or not.  Our use
-- cases may be much more general.
newtype PackMap a b s t =
  PackMap (forall f. Applicative f => (a -> f b) -> s -> f t)

-- | Replaces the targeted occurrences of @a@ in @s@ with @b@ (changing
-- the @s@ to a @t@ in the process).  This can be done via an
-- 'Applicative' action.
--
-- 'traversePM' is just like @traverse@ from the @lens@ package.
-- 'traversePM' used to be called @packmap@.
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

-- | Modify the targeted occurrences of @a@ in @s@ with @b@ (changing
-- the @s@ to a @t@ in the process).
--
-- 'overPM' is just like @over@ from the @lens@ package.
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)


-- {

-- | A helpful monad for writing columns in the AST
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)

-- }


-- { General functions for writing columns in the AST

-- | Make a fresh name for an input value (the variable @primExpr@
-- type is typically actually a 'HPQ.PrimExpr') based on the supplied
-- function and the unique 'T.Tag' that is used as part of our
-- @QueryArr@.
--
-- Add the fresh name and the input value it refers to the list in
-- the state parameter.
extractAttrPE :: (primExpr -> String -> String)
              -> T.Tag
              -> primExpr
              -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
extractAttrPE :: forall primExpr.
(primExpr -> String -> String)
-> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
extractAttrPE 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)

-- | As 'extractAttrPE' but ignores the 'primExpr' when making the
-- fresh column name and just uses the supplied 'String' and 'T.Tag'.
extractAttr :: String
            -> T.Tag
            -> primExpr
            -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
extractAttr :: forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
extractAttr 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
extract :: String -> Tag -> PM [Symbol] PrimExpr
extract 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)

-- | Like 'Control.Lens.Iso.iso'.  In practice it won't actually be
-- used as an isomorphism, but it seems to be appropriate anyway.
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))

-- {

-- Boilerplate instance definitions.  There's no choice here apart
-- from the order in which the applicative is applied.

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))

-- }