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

-- 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 occurences 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 :: 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@ pacakge.
overPM :: PackMap a b s t -> (a -> b) -> s -> t
overPM :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Int -> String
forall a. Show a => a -> String
show Int
i)

write :: a -> PM [a] ()
write :: 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 :: 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 to the list in
-- the state parameter.
extractAttrPE :: (primExpr -> String -> String)
              -> T.Tag
              -> primExpr
              -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
extractAttrPE :: (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 (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 :: 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]
++))

-- }

eitherFunction :: (PP.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) -> 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 (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 (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 (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 (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 :: (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 (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 (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 :: (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 (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 (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 (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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> s -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <*> :: 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 (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 (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 :: (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 (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 (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 (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 :: b -> PackMap a b a b
purePP = b -> PackMap a b a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: 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 (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 +++! :: 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))

-- }