{-# LANGUAGE TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}

-- TODO: dInsert and iDelete should not just invoke "error", but a proper fix is
-- most likely to define a relational transaction that supports this correctly

{-| 
Module      : Database.HaskRel.Relational.Assignment
Description : Relational assignment
Copyright   : © Thor Michael Støre, 2015
License     : GPL v2 without "any later version" clause
Maintainer  : thormichael át gmail døt com
Stability   : experimental

Relational assignment and specalizations thereof. As with
"Database.HaskRel.Relational.Algebra" this does not support relational
expressions building on relvars, but defers that to
"Database.HaskRel.Relational.Expression".
-}
module Database.HaskRel.Relational.Assignment (
  -- * The primitive assignment function
  assign,
  -- * Specialized assignment functions
  insert, dInsert, update, updateAll, delete, iDelete, deleteP,
  -- * Further specialized and simplified forms of update
  updateA, updateAllA
  ) where

import Control.Monad ( unless )

import Data.HList.CommonMain

import Data.Set ( Set, filter, difference, fromList, size )
import qualified Data.Set ( map, foldr )

import Data.Typeable ( Typeable )

import System.Directory ( renameFile )

import Database.HaskRel.Relational.Definition ( Relation, RTuple, bodyAsList, relRearrange' )
import Database.HaskRel.HFWTabulation ( HPresentRecAttr, showHRecSetTab )

import Database.HaskRel.Relational.Algebra ( intersect, minus, minus_ )
import Database.HaskRel.Relational.Variable


rewriteRelvar
  :: (Show (HList (RecordValuesR r)), RecordValues r) =>
     Relvar a -> Relation r -> IO ()
rewriteRelvar rv updated =
  do writeRelvarBody ( relvarPath rv ++ ".new" ) ( bodyAsList updated )
     renameFile ( relvarPath rv ++ ".new" ) ( relvarPath rv )


-- == Relation variable update operations == --

-- | Writes a relation value to a relvar file, replacing the existing value.
assign
  :: (Ord (HList a), Show (HList (RecordValuesR a)), RecordValues a,
      HRearrange3 (LabelsOf a) r a, HLabelSet (LabelsOf a),
      SameLength' r a, SameLength' r (LabelsOf a), SameLength' a r,
      SameLength' (LabelsOf a) r) =>
     Relvar a -> Relation r -> IO ()
assign rv r = do rewriteRelvar rv ( relRearrange' r $ relvarType rv )
                 putStrLn $ "Value assigned to " ++ relvarPath rv


appendRelvar :: (Show (t a), Foldable t) => Relvar t1 -> t a -> Bool -> IO ()
appendRelvar rv hll empty =
    let prefix = if empty then "" else ","
     in unless (null hll)
            $ appendFile (relvarPath rv) $ prefix ++ init ( tail $ show hll )

-- == Inserts

{-| Inserts a relation into a relvar. This differs from SQL's INSERT; the relvar
is updated to the union of the relvar and the relation value given as arguments.

See `Database.HaskRel.Relational.Expression.insert`.
-}
insert
  :: (Ord (HList a), Read (HList (RecordValuesR a)),
      Show (HList (RecordValuesR a)), RecordValues a,
      HRearrange3 (LabelsOf a) r a, HLabelSet (LabelsOf a),
      HMapAux HList TaggedFn (RecordValuesR a) a, SameLength' r a,
      SameLength' r (LabelsOf a), SameLength' a r,
      SameLength' (LabelsOf a) r) =>
     Relvar a -> Relation r -> IO ()
insert rv r = do
    rv' <- readRelvar rv
    let diff = ( r `minus_` rv' )
        in do appendRelvar rv ( bodyAsList diff ) ( null rv' )
              putStrLn $ "Inserted " ++ show ( size diff ) ++ " of " ++
                         show ( size r ) ++ " tuples into " ++ relvarPath rv
-- Note: "minus_" is used in place of "minus" to rearrange the relation to the relvar, and not vice-versa, as it must be.


{-| Disjoint insert. Closer to SQL INSERT, except that this will never insert a
duplicate tuple.

See `Database.HaskRel.Relational.Expression.dInsert`.
-}
dInsert
  :: (Ord (HList t), Read (HList (RecordValuesR t)),
      Show (HList (RecordValuesR r)), Typeable t, RecordValues r,
      RecordValues t, HRearrange3 (LabelsOf t) r t,
      HLabelSet (LabelsOf t), HMapAux HList TaggedFn (RecordValuesR t) t,
      HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR t) [[String]],
      SameLength' r t, SameLength' r (LabelsOf t), SameLength' t r,
      SameLength' (LabelsOf t) r) =>
     Relvar t -> Relation r -> IO ()
dInsert rv r = do
    rv' <- readRelvar rv
    let inter = ( rv' `intersect` r )
        in
      if not ( null inter )
         then error $ "Unique constraint violation, tuples already present in " ++ relvarPath rv ++ ":\n" ++ showHRecSetTab inter
         else 
           do appendRelvar rv ( bodyAsList r ) ( null rv' )
              putStrLn $ "Inserted " ++ show ( size r ) ++ " tuples into " ++ relvarPath rv

-- == Updates

-- Warning: Doesn't infer the way I'd like it to.
funSelfUpdate
  :: (HRearrange3 (LabelsOf r') (HAppendListR r r'2) r',
      HLabelSet (LabelsOf r'), HLabelSet (LabelsOf (HAppendListR r r'2)),
      HDeleteLabels (LabelsOf r) r' r'2, HAppendList r r'2,
      SameLength' r' (HAppendListR r r'2),
      SameLength' (LabelsOf r') (HAppendListR r r'2),
      SameLength' (HAppendListR r r'2) r',
      SameLength' (HAppendListR r r'2) (LabelsOf r'),
      HAllTaggedLV (HAppendListR r r'2)) =>
     (Record r' -> Record r) -> Record r' -> Record r'
funSelfUpdate f t = hRearrange ( labelsOf t ) ( f t .<++. t )

update'
  :: (Num t, Num t1, Ord (HList r'),
      HRearrange3 (LabelsOf r') (HAppendListR r r'2) r',
      HLabelSet (LabelsOf r'), HLabelSet (LabelsOf (HAppendListR r r'2)),
      HDeleteLabels (LabelsOf r) r' r'2, HAppendList r r'2,
      SameLength' r' (HAppendListR r r'2),
      SameLength' (LabelsOf r') (HAppendListR r r'2),
      SameLength' (HAppendListR r r'2) r',
      SameLength' (HAppendListR r r'2) (LabelsOf r'),
      HAllTaggedLV (HAppendListR r r'2)) =>
     Set (Record r')
     -> (Record r' -> Bool)
     -> (Record r' -> Record r)
     -> (t, t1, Set (Record r'))
update' r p f = update'' r p (funSelfUpdate f)

updateA'
  :: (Num t, Num t1, Ord (record r), HUpdateAtLabel record l v r r,
      SameLength' r r) =>
     Set (record r) -> (record r -> Bool) -> (record r -> Tagged l v)
     -> (t, t1, Set (record r))
updateA' r p f = update'' r p (\t -> f t .<. t)

update'' :: (Num t, Num t1, Ord a) =>
     Set a -> (a -> Bool) -> (a -> a) -> (t, t1, Set a)
update'' r p f = 
    let (a,b,c) = Data.Set.foldr
                      (\t (a',b',c') ->
                          if p t then ( a' + 1, b' + 1, f t : c' )
                                 else ( a', b' + 1, t : c' ) )
                      (0,0,[])
                      r
        in (a, b, fromList c)

updateAll'
  :: (Num t, Ord (HList r'),
      HRearrange3 (LabelsOf r') (HAppendListR r r'2) r',
      HLabelSet (LabelsOf r'), HLabelSet (LabelsOf (HAppendListR r r'2)),
      HDeleteLabels (LabelsOf r) r' r'2, HAppendList r r'2,
      SameLength' r' (HAppendListR r r'2),
      SameLength' (LabelsOf r') (HAppendListR r r'2),
      SameLength' (HAppendListR r r'2) r',
      SameLength' (HAppendListR r r'2) (LabelsOf r'),
      HAllTaggedLV (HAppendListR r r'2)) =>
     Set (Record r') -> (Record r' -> Record r) -> (t, Set (Record r'))
updateAll' r f = updateAll'' r (funSelfUpdate f)

updateAllA'
  :: (Num t, Ord (record r), HUpdateAtLabel record l v r r,
      SameLength' r r) =>
     Set (record r) -> (record r -> Tagged l v) -> (t, Set (record r))
updateAllA' r f = updateAll'' r (\t -> f t .<. t)

updateAll'' :: (Num t, Ord a1) => Set a -> (a -> a1) -> (t, Set a1)
updateAll'' r f = 
    let (a,b) = Data.Set.foldr (\t (a',b') -> ( a' + 1, f t : b' ) ) (0,[]) r
        in (a, fromList b)


doUpdate
  :: (Show a, Show a1, Show (HList (RecordValuesR r)),
      RecordValues r) =>
     Relvar a2 -> (a, a1, Relation r) -> IO ()
doUpdate rv ( updCount, totCount, updated ) =
  do rewriteRelvar rv updated
     putStrLn $ "Updated " ++ show updCount ++ " of " ++ show totCount ++ " tuples in " ++ relvarPath rv


{-| Updates tuples of a relvar that match the given predicate. As SQL UPDATE.

>>> update sp (\ [pun|pno|] -> pno == "P2" || pno == "P3" ) (\ [pun|qty|] -> _qty ( qty - 25 ) .*. emptyRecord)
Updated 5 of 12 tuples in SuppliersPartsDB/SP.rv
*SuppliersPartsExample> rPrint$ sp
┌─────┬─────┬─────┐
│ sno │ pno │ qty │
╞═════╪═════╪═════╡
│ S1  │ P1  │ 300 │
│ S1  │ P2  │ 175 │
│ S1  │ P3  │ 375 │
│ S1  │ P4  │ 200 │
...

Note how the cardinality of the relvar will be equal or lower after an update:

>>> assign sp sp'
Value assigned to SuppliersPartsDB/SP.rv
>>> count sp
12
>>> update sp (\[pun|pno|] -> pno == "P1" || pno == "P2" || pno == "P3") (\_ -> _pno "P1" .*. _qty 50 .*. emptyRecord)
Updated 7 of 12 tuples in SuppliersPartsDB/SP.rv
>>> count sp
9
-}
-- TODO: Fix update count message to reflect the situation in the last example
-- above, although this is tricky as this is most likely something that belongs
-- naturally in the set level functions. Note however that it is not feasable to
-- give update counts at all in RDBSMs, as keeping exact track of the
-- cardinality of relvars constitutes an overhead that is in many cases
-- unacceptable, and doesn't provide information that is as useful as a naïve
-- mind might think anyhow.
update
  :: (Ord (HList a), Read (HList (RecordValuesR a)),
      Show (HList (RecordValuesR a)), RecordValues a,
      HRearrange3 (LabelsOf a) (HAppendListR r r'2) a,
      HLabelSet (LabelsOf a), HLabelSet (LabelsOf (HAppendListR r r'2)),
      HDeleteLabels (LabelsOf r) a r'2,
      HMapAux HList TaggedFn (RecordValuesR a) a, HAppendList r r'2,
      SameLength' a (HAppendListR r r'2),
      SameLength' (LabelsOf a) (HAppendListR r r'2),
      SameLength' (HAppendListR r r'2) a,
      SameLength' (HAppendListR r r'2) (LabelsOf a),
      HAllTaggedLV (HAppendListR r r'2)) =>
     Relvar a -> (Record a -> Bool) -> (Record a -> Record r) -> IO ()
update rv p f = do
    rv' <- readRelvar rv
    doUpdate rv ( update' rv' p f )


{-| Updates all tuples of a relvar. The second argument is a function that results
in an attribute, making for a simpler function than for `update`.

>>> updateA sp (\ [pun|pno|] -> pno == "P2" || pno == "P3" ) (\ [pun|qty|] -> _qty $ qty - 25)
Updated 5 of 12 tuples in SuppliersPartsDB/SP.rv
-}
-- TODO: Can't get the type signature to compile, HUpdateAtLabel2 isn't exported
-- from Data.HList.Record
updateA rv p f = do
    rv' <- readRelvar rv
    doUpdate rv ( updateA' rv' p f )


doUpdateAll
  :: (Show a, Show (HList (RecordValuesR r)), RecordValues r) =>
     Relvar a1 -> (a, Relation r) -> IO ()
doUpdateAll rv ( count, updated ) =
  do rewriteRelvar rv updated
     putStrLn $ "Updated " ++ show count ++ " tuples in " ++ relvarPath rv

{-| Updates tuples of a relvar that match the given predicate.

In SQL and Tutorial D both the predicate of @UPDATE@ is an optional clause, but
optional clauses isn't idiomatic Haskell, hence this separate updateAll
function.

>>> updateAll sp (\ [pun|qty pno|] -> _qty ( qty - 25 ) .*. _pno ( pno ++ "X" ) .*. emptyRecord)
Updated 12 tuples in SuppliersPartsDB/SP.rv
*SuppliersPartsExample> pt sp
┌───────────────┬───────────────┬────────────────┐
│ sno :: String │ pno :: String │ qty :: Integer │
╞═══════════════╪═══════════════╪════════════════╡
│ S1            │ P1X           │ 275            │
...
-}
updateAll
  :: (Ord (HList a), Read (HList (RecordValuesR a)),
      Show (HList (RecordValuesR a)), RecordValues a,
      HRearrange3 (LabelsOf a) (HAppendListR r r'2) a,
      HLabelSet (LabelsOf a), HLabelSet (LabelsOf (HAppendListR r r'2)),
      HDeleteLabels (LabelsOf r) a r'2,
      HMapAux HList TaggedFn (RecordValuesR a) a, HAppendList r r'2,
      SameLength' a (HAppendListR r r'2),
      SameLength' (LabelsOf a) (HAppendListR r r'2),
      SameLength' (HAppendListR r r'2) a,
      SameLength' (HAppendListR r r'2) (LabelsOf a),
      HAllTaggedLV (HAppendListR r r'2)) =>
     Relvar a -> (Record a -> Record r) -> IO ()
updateAll rv f = do
    rv' <- readRelvar rv
    doUpdateAll rv (updateAll' rv' f)

{-| Updates all tuples of a relvar. The second argument is a function that results
in an attribute, making for a simpler function than for `updateAll`.

>>> updateAllA sp (\ [pun|qty|] -> _qty $ qty - 50)
Updated 12 tuples in SuppliersPartsDB/SP.rv
>>> rPrint$ sp
┌───────────────┬───────────────┬────────────────┐
│ sno :: String │ pno :: String │ qty :: Integer │
╞═══════════════╪═══════════════╪════════════════╡
│ S1            │ P1            │ 250            │
...
-}
-- TODO: Can't get the type signature to compile, HUpdateAtLabel2 isn't visible
-- from Data.HList.Record
updateAllA rv f = do
    rv' <- readRelvar rv
    doUpdateAll rv (updateAllA' rv' f)

-- == Deletes

doDelete rv filtered nDeleted =
  do writeRelvarBody ( relvarPath rv ++ ".new" ) ( bodyAsList filtered )
     renameFile ( relvarPath rv ++ ".new" ) ( relvarPath rv )
     putStrLn $ "Deleted " ++ nDeleted ++ " tuples from " ++ relvarPath rv

{-| Deletes a specified subset of a relvar. Note that this is not SQL DELETE, but
instead a generalization thereof.

See `Database.HaskRel.Relational.Expression.delete`.
-}
delete
  :: (Ord (HList t), Read (HList (RecordValuesR t)),
      Show (HList (RecordValuesR t)), RecordValues t,
      HMapAux HList TaggedFn (RecordValuesR t) t) =>
     Relvar t -> Relation t -> IO ()
delete rv r = do
    rv' <- readRelvar rv
    let filtered = Data.Set.difference rv' r
        in doDelete rv filtered ( show $ size rv' - size filtered )

{-| Performs an inclusive delete against a relvar. Also not SQL DELETE. This will
fail if the second argument is not a subset of the relation value identified by
the relation variable reference.

See `Database.HaskRel.Relational.Expression.iDelete`.
-}
iDelete
  :: (Ord (HList a), Ord (HList t), Read (HList (RecordValuesR t)),
      Show (HList (RecordValuesR t)), Typeable a, RecordValues a,
      RecordValues t, HRearrange3 (LabelsOf t) a t,
      HRearrange3 (LabelsOf a) t a, HLabelSet (LabelsOf t),
      HLabelSet (LabelsOf a), HMapAux HList TaggedFn (RecordValuesR t) t,
      HFoldr (Mapcar HPresentRecAttr) [[String]] (RecordValuesR a) [[String]],
      SameLength' a t, SameLength' a (LabelsOf t), SameLength' t a,
      SameLength' t (LabelsOf a), SameLength' (LabelsOf t) a,
      SameLength' (LabelsOf a) t) =>
     Relvar t -> Relation a -> IO ()
iDelete rv r = do
    rv' <- readRelvar rv
    let filtered = rv' `minus` r
        in if size filtered > ( size rv' - size r )
           then error $ "Tuples not found in relvar " ++ relvarPath rv ++ ":\n" ++ showHRecSetTab ( r `minus` rv' )
           else doDelete rv filtered ( show $ size rv' - size filtered )

{- | Delete by predicate, as SQL DELETE.

>>> let newProd = relation [rTuple (pno .=. "P7", pName .=. "Baloon", color .=. "Red", weight .=. (-5 :: Rational), city .=. "Berlin")]
>>> insert p newProd
Inserted 1 of 1 tuples into SuppliersPartsDB/P.rv
>>> deleteP p (\ [pun|pno|] -> pno == "P7" )
Deleted 1 tuples from SuppliersPartsDB/P.rv
-}
deleteP
  :: (Ord (HList t), Read (HList (RecordValuesR t)),
      Show (HList (RecordValuesR t)), RecordValues t,
      HMapAux HList TaggedFn (RecordValuesR t) t) =>
     Relvar t -> (RTuple t -> Bool) -> IO ()
deleteP rv p = do
    rv' <- readRelvar rv
    let filtered = Data.Set.filter ( not . p ) rv'
        in doDelete rv filtered ( show $ size rv' - size filtered )

-- An iDeleteP function could also be defined, but its utility would be
-- marginal.