{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module Opaleye.SQLite.Internal.TableMaker where

import qualified Opaleye.SQLite.Column as C
import qualified Opaleye.SQLite.Internal.Column as IC
import qualified Opaleye.SQLite.Internal.PackMap as PM

import           Data.Profunctor (Profunctor, dimap)
import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import           Data.Profunctor.Product.Default (Default, def)

import           Control.Applicative (Applicative, pure, (<*>))

import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ


-- If we switch to a more lens-like approach to PackMap this should be
-- the equivalent of a Setter
newtype ViewColumnMaker strings columns =
  ViewColumnMaker (PM.PackMap () () strings columns)

newtype ColumnMaker columns columns' =
  ColumnMaker (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')

runViewColumnMaker :: ViewColumnMaker strings tablecolumns ->
                       strings -> tablecolumns
runViewColumnMaker :: ViewColumnMaker strings tablecolumns -> strings -> tablecolumns
runViewColumnMaker (ViewColumnMaker PackMap () () strings tablecolumns
f) = PackMap () () strings tablecolumns
-> (() -> ()) -> strings -> tablecolumns
forall a b s t. PackMap a b s t -> (a -> b) -> s -> t
PM.overPM PackMap () () strings tablecolumns
f () -> ()
forall a. a -> a
id

runColumnMaker :: Applicative f
                  => ColumnMaker tablecolumns columns
                  -> (HPQ.PrimExpr -> f HPQ.PrimExpr)
                  -> tablecolumns -> f columns
runColumnMaker :: ColumnMaker tablecolumns columns
-> (PrimExpr -> f PrimExpr) -> tablecolumns -> f columns
runColumnMaker (ColumnMaker PackMap PrimExpr PrimExpr tablecolumns columns
f) = PackMap PrimExpr PrimExpr tablecolumns columns
-> (PrimExpr -> f PrimExpr) -> tablecolumns -> f columns
forall (f :: * -> *) a b s t.
Applicative f =>
PackMap a b s t -> (a -> f b) -> s -> f t
PM.traversePM PackMap PrimExpr PrimExpr tablecolumns columns
f

-- There's surely a way of simplifying this implementation
tableColumn :: ViewColumnMaker String (C.Column a)
tableColumn :: ViewColumnMaker String (Column a)
tableColumn = PackMap () () String (Column a)
-> ViewColumnMaker String (Column a)
forall strings columns.
PackMap () () strings columns -> ViewColumnMaker strings columns
ViewColumnMaker
              ((forall (f :: * -> *).
 Applicative f =>
 (() -> f ()) -> String -> f (Column a))
-> PackMap () () String (Column a)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap (\() -> f ()
f String
s -> (() -> Column a) -> f () -> f (Column a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Column a -> () -> Column a
forall a b. a -> b -> a
const (String -> Column a
forall a. String -> Column a
mkColumn String
s)) (() -> f ()
f ())))
  where mkColumn :: String -> Column a
mkColumn = PrimExpr -> Column a
forall a. PrimExpr -> Column a
IC.Column (PrimExpr -> Column a)
-> (String -> PrimExpr) -> String -> Column a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PrimExpr
HPQ.BaseTableAttrExpr

column :: ColumnMaker (C.Column a) (C.Column a)
column :: ColumnMaker (Column a) (Column a)
column = PackMap PrimExpr PrimExpr (Column a) (Column a)
-> ColumnMaker (Column a) (Column a)
forall columns columns'.
PackMap PrimExpr PrimExpr columns columns'
-> ColumnMaker columns columns'
ColumnMaker
         ((forall (f :: * -> *).
 Applicative f =>
 (PrimExpr -> f PrimExpr) -> Column a -> f (Column a))
-> PackMap PrimExpr PrimExpr (Column a) (Column a)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap (\PrimExpr -> f PrimExpr
f (IC.Column s)
                      -> (PrimExpr -> Column a) -> f PrimExpr -> f (Column a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimExpr -> Column a
forall a. PrimExpr -> Column a
IC.Column (PrimExpr -> f PrimExpr
f PrimExpr
s)))

instance Default ViewColumnMaker String (C.Column a) where
  def :: ViewColumnMaker String (Column a)
def = ViewColumnMaker String (Column a)
forall a. ViewColumnMaker String (Column a)
tableColumn

instance Default ColumnMaker (C.Column a) (C.Column a) where
  def :: ColumnMaker (Column a) (Column a)
def = ColumnMaker (Column a) (Column a)
forall a. ColumnMaker (Column a) (Column a)
column

-- {

-- Boilerplate instance definitions.  Theoretically, these are derivable.

instance Functor (ViewColumnMaker a) where
  fmap :: (a -> b) -> ViewColumnMaker a a -> ViewColumnMaker a b
fmap a -> b
f (ViewColumnMaker PackMap () () a a
g) = PackMap () () a b -> ViewColumnMaker a b
forall strings columns.
PackMap () () strings columns -> ViewColumnMaker strings columns
ViewColumnMaker ((a -> b) -> PackMap () () a a -> PackMap () () a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PackMap () () a a
g)

instance Applicative (ViewColumnMaker a) where
  pure :: a -> ViewColumnMaker a a
pure = PackMap () () a a -> ViewColumnMaker a a
forall strings columns.
PackMap () () strings columns -> ViewColumnMaker strings columns
ViewColumnMaker (PackMap () () a a -> ViewColumnMaker a a)
-> (a -> PackMap () () a a) -> a -> ViewColumnMaker a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PackMap () () a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ViewColumnMaker PackMap () () a (a -> b)
f <*> :: ViewColumnMaker a (a -> b)
-> ViewColumnMaker a a -> ViewColumnMaker a b
<*> ViewColumnMaker PackMap () () a a
x = PackMap () () a b -> ViewColumnMaker a b
forall strings columns.
PackMap () () strings columns -> ViewColumnMaker strings columns
ViewColumnMaker (PackMap () () a (a -> b)
f PackMap () () a (a -> b) -> PackMap () () a a -> PackMap () () a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PackMap () () a a
x)

instance Profunctor ViewColumnMaker where
  dimap :: (a -> b) -> (c -> d) -> ViewColumnMaker b c -> ViewColumnMaker a d
dimap a -> b
f c -> d
g (ViewColumnMaker PackMap () () b c
q) = PackMap () () a d -> ViewColumnMaker a d
forall strings columns.
PackMap () () strings columns -> ViewColumnMaker strings columns
ViewColumnMaker ((a -> b) -> (c -> d) -> PackMap () () b c -> PackMap () () 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
g PackMap () () b c
q)

instance ProductProfunctor ViewColumnMaker where
  empty :: ViewColumnMaker () ()
empty = ViewColumnMaker () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
  ***! :: ViewColumnMaker a b
-> ViewColumnMaker a' b' -> ViewColumnMaker (a, a') (b, b')
(***!) = ViewColumnMaker a b
-> ViewColumnMaker a' b' -> ViewColumnMaker (a, a') (b, b')
forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.defaultProfunctorProduct

instance Functor (ColumnMaker a) where
  fmap :: (a -> b) -> ColumnMaker a a -> ColumnMaker a b
fmap a -> b
f (ColumnMaker PackMap PrimExpr PrimExpr a a
g) = PackMap PrimExpr PrimExpr a b -> ColumnMaker a b
forall columns columns'.
PackMap PrimExpr PrimExpr columns columns'
-> ColumnMaker columns columns'
ColumnMaker ((a -> b)
-> PackMap PrimExpr PrimExpr a a -> PackMap PrimExpr PrimExpr a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PackMap PrimExpr PrimExpr a a
g)

instance Applicative (ColumnMaker a) where
  pure :: a -> ColumnMaker a a
pure = PackMap PrimExpr PrimExpr a a -> ColumnMaker a a
forall columns columns'.
PackMap PrimExpr PrimExpr columns columns'
-> ColumnMaker columns columns'
ColumnMaker (PackMap PrimExpr PrimExpr a a -> ColumnMaker a a)
-> (a -> PackMap PrimExpr PrimExpr a a) -> a -> ColumnMaker a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PackMap PrimExpr PrimExpr a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ColumnMaker PackMap PrimExpr PrimExpr a (a -> b)
f <*> :: ColumnMaker a (a -> b) -> ColumnMaker a a -> ColumnMaker a b
<*> ColumnMaker PackMap PrimExpr PrimExpr a a
x = PackMap PrimExpr PrimExpr a b -> ColumnMaker a b
forall columns columns'.
PackMap PrimExpr PrimExpr columns columns'
-> ColumnMaker columns columns'
ColumnMaker (PackMap PrimExpr PrimExpr a (a -> b)
f PackMap PrimExpr PrimExpr a (a -> b)
-> PackMap PrimExpr PrimExpr a a -> PackMap PrimExpr PrimExpr a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PackMap PrimExpr PrimExpr a a
x)

instance Profunctor ColumnMaker where
  dimap :: (a -> b) -> (c -> d) -> ColumnMaker b c -> ColumnMaker a d
dimap a -> b
f c -> d
g (ColumnMaker PackMap PrimExpr PrimExpr b c
q) = PackMap PrimExpr PrimExpr a d -> ColumnMaker a d
forall columns columns'.
PackMap PrimExpr PrimExpr columns columns'
-> ColumnMaker columns columns'
ColumnMaker ((a -> b)
-> (c -> d)
-> PackMap PrimExpr PrimExpr b c
-> PackMap PrimExpr PrimExpr 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
g PackMap PrimExpr PrimExpr b c
q)

instance ProductProfunctor ColumnMaker where
  empty :: ColumnMaker () ()
empty = ColumnMaker () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
  ***! :: ColumnMaker a b -> ColumnMaker a' b' -> ColumnMaker (a, a') (b, b')
(***!) = ColumnMaker a b -> ColumnMaker a' b' -> ColumnMaker (a, a') (b, b')
forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.defaultProfunctorProduct

--}