{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}

module Opaleye.SQLite.Internal.Table where

import           Opaleye.SQLite.Internal.Column (Column, unColumn)
import qualified Opaleye.SQLite.Internal.TableMaker as TM
import qualified Opaleye.SQLite.Internal.Tag as Tag
import qualified Opaleye.SQLite.Internal.PrimQuery as PQ
import qualified Opaleye.SQLite.Internal.PackMap as PM

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

import qualified Data.Functor.Identity as I
import           Data.Profunctor (Profunctor, dimap, lmap)
import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import qualified Data.List.NonEmpty as NEL
import           Data.Semigroup (Semigroup, (<>))
import           Data.Monoid (Monoid, mempty)
import           Control.Applicative (Applicative, pure, (<*>), liftA2)
import qualified Control.Arrow as Arr

-- | Define a table as follows, where \"id\", \"color\", \"location\",
-- \"quantity\" and \"radius\" are the tables columns in Postgres and
-- the types are given in the type signature.  The @id@ field is an
-- autoincrementing field (i.e. optional for writes).
--
-- @
-- data Widget a b c d e = Widget { wid      :: a
--                                , color    :: b
--                                , location :: c
--                                , quantity :: d
--                                , radius   :: e }
--
-- $('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget)
--
-- widgetTable :: Table (Widget (Maybe (Column PGInt4)) (Column PGText) (Column PGText)
--                              (Column PGInt4) (Column PGFloat8))
--                      (Widget (Column PGText) (Column PGText) (Column PGText)
--                              (Column PGInt4) (Column PGFloat8))
-- widgetTable = Table \"widgetTable\"
--                      (pWidget Widget { wid      = optional \"id\"
--                                      , color    = required \"color\"
--                                      , location = required \"location\"
--                                      , quantity = required \"quantity\"
--                                      , radius   = required \"radius\" })
-- @
data Table writerColumns viewColumns =
  Table String (TableProperties writerColumns viewColumns)

data TableProperties writerColumns viewColumns =
  TableProperties (Writer writerColumns viewColumns) (View viewColumns)

data View columns = View columns

-- There's no reason the second parameter should exist except that we
-- use ProductProfunctors more than ProductContravariants so it makes
-- things easier if we make it one of the former.
--
-- Writer has become very mysterious.  I really couldn't tell you what
-- it means.  It seems to be saying that a `Writer` tells you how an
-- `f columns` contains a list of `(f HPQ.PrimExpr, String)`, i.e. how
-- it contains each column: a column header and the entries in this
-- column for all the rows.
newtype Writer columns dummy =
  Writer (forall f. Functor f =>
          PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())

queryTable :: TM.ColumnMaker viewColumns columns
            -> Table writerColumns viewColumns
            -> Tag.Tag
            -> (columns, PQ.PrimQuery)
queryTable :: ColumnMaker viewColumns columns
-> Table writerColumns viewColumns -> Tag -> (columns, PrimQuery)
queryTable ColumnMaker viewColumns columns
cm Table writerColumns viewColumns
table Tag
tag = (columns
primExprs, PrimQuery
primQ) where
  (Table String
tableName (TableProperties Writer writerColumns viewColumns
_ (View viewColumns
tableCols))) = Table writerColumns viewColumns
table
  (columns
primExprs, [(Symbol, PrimExpr)]
projcols) = ColumnMaker viewColumns columns
-> Tag -> viewColumns -> (columns, [(Symbol, PrimExpr)])
forall tablecolumns columns.
ColumnMaker tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
runColumnMaker ColumnMaker viewColumns columns
cm Tag
tag viewColumns
tableCols
  primQ :: PQ.PrimQuery
  primQ :: PrimQuery
primQ = String -> [(Symbol, PrimExpr)] -> PrimQuery
PQ.BaseTable String
tableName [(Symbol, PrimExpr)]
projcols

runColumnMaker :: TM.ColumnMaker tablecolumns columns
                  -> Tag.Tag
                  -> tablecolumns
                  -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])
runColumnMaker :: ColumnMaker tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
runColumnMaker ColumnMaker tablecolumns columns
cm Tag
tag tablecolumns
tableCols = PM [(Symbol, PrimExpr)] columns -> (columns, [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (ColumnMaker tablecolumns columns
-> (PrimExpr
    -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> tablecolumns
-> PM [(Symbol, PrimExpr)] columns
forall (f :: * -> *) tablecolumns columns.
Applicative f =>
ColumnMaker tablecolumns columns
-> (PrimExpr -> f PrimExpr) -> tablecolumns -> f columns
TM.runColumnMaker ColumnMaker tablecolumns columns
cm PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
f tablecolumns
tableCols) where
  f :: PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
f = (PrimExpr -> String -> String)
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
(primExpr -> String -> String)
-> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttrPE PrimExpr -> String -> String
mkName Tag
tag
  -- The non-AttrExpr PrimExprs are not created by 'makeView' or a
  -- 'ViewColumnMaker' so could only arise from an fmap (if we
  -- implemented a Functor instance) or a direct manipulation of the
  -- tablecols contained in the View (which would be naughty)
  mkName :: PrimExpr -> String -> String
mkName PrimExpr
pe String
i = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case PrimExpr
pe of
    HPQ.BaseTableAttrExpr String
columnName -> String
columnName
    PrimExpr
_ -> String
"tablecolumn"

runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]
runWriter :: Writer columns columns' -> columns -> [(PrimExpr, String)]
runWriter (Writer (PM.PackMap f)) columns
columns = [(PrimExpr, String)]
outColumns
  where ([(PrimExpr, String)]
outColumns, ()) = ((Identity PrimExpr, String) -> ([(PrimExpr, String)], ()))
-> Identity columns -> ([(PrimExpr, String)], ())
forall (f :: * -> *).
Applicative f =>
((Identity PrimExpr, String) -> f ()) -> Identity columns -> f ()
f (Identity PrimExpr, String) -> ([(PrimExpr, String)], ())
forall a b. (Identity a, b) -> ([(a, b)], ())
extract (columns -> Identity columns
forall a. a -> Identity a
I.Identity columns
columns)
        extract :: (Identity a, b) -> ([(a, b)], ())
extract (Identity a
pes, b
s) = ([(Identity a -> a
forall a. Identity a -> a
I.runIdentity Identity a
pes, b
s)], ())

-- This works more generally for any "zippable", that is an
-- Applicative that satisfies
--
--    x == (,) <$> fmap fst x <*> fmap snd x
--
-- However, I'm unaware of a typeclass for this.
runWriter' :: Writer columns columns' -> NEL.NonEmpty columns -> (NEL.NonEmpty [HPQ.PrimExpr], [String])
runWriter' :: Writer columns columns'
-> NonEmpty columns -> (NonEmpty [PrimExpr], [String])
runWriter' (Writer (PM.PackMap f)) NonEmpty columns
columns = (Zip PrimExpr -> NonEmpty [PrimExpr])
-> (Zip PrimExpr, [String]) -> (NonEmpty [PrimExpr], [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arr.first Zip PrimExpr -> NonEmpty [PrimExpr]
forall a. Zip a -> NonEmpty [a]
unZip (Zip PrimExpr, [String])
outColumns
  where ((Zip PrimExpr, [String])
outColumns, ()) = ((NonEmpty PrimExpr, String) -> ((Zip PrimExpr, [String]), ()))
-> NonEmpty columns -> ((Zip PrimExpr, [String]), ())
forall (f :: * -> *).
Applicative f =>
((NonEmpty PrimExpr, String) -> f ()) -> NonEmpty columns -> f ()
f (NonEmpty PrimExpr, String) -> ((Zip PrimExpr, [String]), ())
forall a a. (NonEmpty a, a) -> ((Zip a, [a]), ())
extract NonEmpty columns
columns
        extract :: (NonEmpty a, a) -> ((Zip a, [a]), ())
extract (NonEmpty a
pes, a
s) = ((NonEmpty [a] -> Zip a
forall a. NonEmpty [a] -> Zip a
Zip ((a -> [a]) -> NonEmpty a -> NonEmpty [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty a
pes), [a
s]), ())

data Zip a = Zip { Zip a -> NonEmpty [a]
unZip :: NEL.NonEmpty [a] }

instance Semigroup (Zip a) where
  Zip NonEmpty [a]
xs <> :: Zip a -> Zip a -> Zip a
<> Zip NonEmpty [a]
ys = NonEmpty [a] -> Zip a
forall a. NonEmpty [a] -> Zip a
Zip (([a] -> [a] -> [a]) -> NonEmpty [a] -> NonEmpty [a] -> NonEmpty [a]
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NEL.zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) NonEmpty [a]
xs NonEmpty [a]
ys)

instance Monoid (Zip a) where
  mempty :: Zip a
mempty = NonEmpty [a] -> Zip a
forall a. NonEmpty [a] -> Zip a
Zip NonEmpty [a]
forall a. NonEmpty [a]
mempty'
    where mempty' :: NonEmpty [a]
mempty' = [] [a] -> NonEmpty [a] -> NonEmpty [a]
forall a. a -> NonEmpty a -> NonEmpty a
`NEL.cons` NonEmpty [a]
mempty'

required :: String -> Writer (Column a) (Column a)
required :: String -> Writer (Column a) (Column a)
required String
columnName =
  (forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f (Column a)) ())
-> Writer (Column a) (Column a)
forall columns dummy.
(forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((forall (f :: * -> *).
 Applicative f =>
 ((f PrimExpr, String) -> f ()) -> f (Column a) -> f ())
-> PackMap (f PrimExpr, String) () (f (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 PrimExpr, String) -> f ()
f f (Column a)
columns -> (f PrimExpr, String) -> f ()
f ((Column a -> PrimExpr) -> f (Column a) -> f PrimExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Column a -> PrimExpr
forall a. Column a -> PrimExpr
unColumn f (Column a)
columns, String
columnName)))

optional :: String -> Writer (Maybe (Column a)) (Column a)
optional :: String -> Writer (Maybe (Column a)) (Column a)
optional String
columnName =
  (forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f (Maybe (Column a))) ())
-> Writer (Maybe (Column a)) (Column a)
forall columns dummy.
(forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((forall (f :: * -> *).
 Applicative f =>
 ((f PrimExpr, String) -> f ()) -> f (Maybe (Column a)) -> f ())
-> PackMap (f PrimExpr, String) () (f (Maybe (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 PrimExpr, String) -> f ()
f f (Maybe (Column a))
columns -> (f PrimExpr, String) -> f ()
f ((Maybe (Column a) -> PrimExpr)
-> f (Maybe (Column a)) -> f PrimExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Column a) -> PrimExpr
forall a. Maybe (Column a) -> PrimExpr
maybeUnColumn f (Maybe (Column a))
columns, String
columnName)))
  where maybeUnColumn :: Maybe (Column a) -> PrimExpr
maybeUnColumn Maybe (Column a)
Nothing = PrimExpr
HPQ.DefaultInsertExpr
        maybeUnColumn (Just Column a
column) = Column a -> PrimExpr
forall a. Column a -> PrimExpr
unColumn Column a
column

-- {

-- Boilerplate instance definitions

instance Functor (Writer a) where
  fmap :: (a -> b) -> Writer a a -> Writer a b
fmap a -> b
_ (Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
g) = (forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f a) ())
-> Writer a b
forall columns dummy.
(forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
g

instance Applicative (Writer a) where
  pure :: a -> Writer a a
pure a
x = (forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f a) ())
-> Writer a a
forall columns dummy.
(forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((a -> ())
-> PackMap (f PrimExpr, String) () (f a) a
-> PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) (a -> PackMap (f PrimExpr, String) () (f a) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
  Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
f <*> :: Writer a (a -> b) -> Writer a a -> Writer a b
<*> Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
x = (forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f a) ())
-> Writer a b
forall columns dummy.
(forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((() -> () -> ())
-> PackMap (f PrimExpr, String) () (f a) ()
-> PackMap (f PrimExpr, String) () (f a) ()
-> PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\()
_ ()
_ -> ()) PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
f PackMap (f PrimExpr, String) () (f a) ()
forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f a) ()
x)

instance Profunctor Writer where
  dimap :: (a -> b) -> (c -> d) -> Writer b c -> Writer a d
dimap a -> b
f c -> d
_ (Writer forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f b) ()
h) = (forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f a) ())
-> Writer a d
forall columns dummy.
(forall (f :: * -> *).
 Functor f =>
 PackMap (f PrimExpr, String) () (f columns) ())
-> Writer columns dummy
Writer ((f a -> f b)
-> PackMap (f PrimExpr, String) () (f b) ()
-> PackMap (f PrimExpr, String) () (f a) ()
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) PackMap (f PrimExpr, String) () (f b) ()
forall (f :: * -> *).
Functor f =>
PackMap (f PrimExpr, String) () (f b) ()
h)

instance ProductProfunctor Writer where
  empty :: Writer () ()
empty = Writer () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
  ***! :: Writer a b -> Writer a' b' -> Writer (a, a') (b, b')
(***!) = Writer a b -> Writer a' b' -> Writer (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 (TableProperties a) where
  fmap :: (a -> b) -> TableProperties a a -> TableProperties a b
fmap a -> b
f (TableProperties Writer a a
w (View a
v)) = Writer a b -> View b -> TableProperties a b
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties ((a -> b) -> Writer a a -> Writer a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Writer a a
w) (b -> View b
forall columns. columns -> View columns
View (a -> b
f a
v))

instance Applicative (TableProperties a) where
  pure :: a -> TableProperties a a
pure a
x = Writer a a -> View a -> TableProperties a a
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties (a -> Writer a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> View a
forall columns. columns -> View columns
View a
x)
  TableProperties Writer a (a -> b)
fw (View a -> b
fv) <*> :: TableProperties a (a -> b)
-> TableProperties a a -> TableProperties a b
<*> TableProperties Writer a a
xw (View a
xv) =
    Writer a b -> View b -> TableProperties a b
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties (Writer a (a -> b)
fw Writer a (a -> b) -> Writer a a -> Writer a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Writer a a
xw) (b -> View b
forall columns. columns -> View columns
View (a -> b
fv a
xv))

instance Profunctor TableProperties where
  dimap :: (a -> b) -> (c -> d) -> TableProperties b c -> TableProperties a d
dimap a -> b
f c -> d
g (TableProperties Writer b c
w (View c
v)) = Writer a d -> View d -> TableProperties a d
forall writerColumns viewColumns.
Writer writerColumns viewColumns
-> View viewColumns -> TableProperties writerColumns viewColumns
TableProperties ((a -> b) -> (c -> d) -> Writer b c -> Writer 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 Writer b c
w)
                                                            (d -> View d
forall columns. columns -> View columns
View (c -> d
g c
v))
instance ProductProfunctor TableProperties where
  empty :: TableProperties () ()
empty = TableProperties () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
  ***! :: TableProperties a b
-> TableProperties a' b' -> TableProperties (a, a') (b, b')
(***!) = TableProperties a b
-> TableProperties a' b' -> TableProperties (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 (Table a) where
  fmap :: (a -> b) -> Table a a -> Table a b
fmap a -> b
f (Table String
s TableProperties a a
tp) = String -> TableProperties a b -> Table a b
forall writerColumns viewColumns.
String
-> TableProperties writerColumns viewColumns
-> Table writerColumns viewColumns
Table String
s ((a -> b) -> TableProperties a a -> TableProperties a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f TableProperties a a
tp)

-- }