content: {-# LANGUAGE DefaultSignatures    #-}
  {-# LANGUAGE FlexibleContexts     #-}
  {-# LANGUAGE FlexibleInstances    #-}
  {-# LANGUAGE ScopedTypeVariables  #-}
  {-# LANGUAGE TypeOperators        #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE CPP #-}
  
  module ProjectM36.Tupleable
    ( toInsertExpr
    , toDefineExpr
    , tupleAssocsEqualityPredicate
    , partitionByAttributes
    , toUpdateExpr
    , toDeleteExpr
    , validateAttributes
    , Tupleable(..)
  
      -- * Generics
    , genericToTuple
    , genericFromTuple
    , genericToAttributes
    , TupleableG(..)
      -- ** Options
    , defaultTupleableOptions
    , TupleableOptions()
    , fieldModifier
    ) where
  
  import           Data.Foldable
  import           Data.List                      (partition)
  import qualified Data.Map                       as Map
  #if __GLASGOW_HASKELL__ < 804
  import           Data.Monoid
  #endif
  import           Data.Proxy
  import qualified Data.Text                      as T
  import qualified Data.Vector                    as V
  import           GHC.Generics
  import           ProjectM36.Atomable
  import           ProjectM36.Attribute           as A hiding (null, toList)
  import           ProjectM36.Base
  import           ProjectM36.DataTypes.Primitive
  import           ProjectM36.Error
  import           ProjectM36.Tuple
  import           ProjectM36.TupleSet
  import qualified Data.Set as S
  
  {-import Data.Binary
  import Control.DeepSeq
  
  data Test1T = Test1C {
    attrA :: Int
    }
              deriving (Generic, Show)
  
  data Test2T a b = Test2C {
    attrB :: a,
    attrC :: b
    }
    deriving (Generic, Show)
  
  instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
  
  instance Tupleable Test1T
  
  data TestUnnamed1 = TestUnnamed1 Int Double T.Text
                      deriving (Show,Eq, Generic)
  
  instance Tupleable TestUnnamed1
  
  data Test7A = Test7AC Integer
              deriving (Generic, Show, Eq, Atomable, NFData, Binary)
  
  
  data Test7T = Test7C Test7A
                deriving (Generic, Show, Eq)
  
  instance Tupleable Test7T
  -}
  
  -- | Convert a 'Traverseable' of 'Tupleable's to an 'Insert' 'DatabaseContextExpr'. This is useful for converting, for example, a list of data values to a set of Insert expressions which can be used to add the values to the database.
  toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr
  toInsertExpr vals rvName = do
    let attrs = toAttributes (Proxy :: Proxy a)
    tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
    let rel = MakeStaticRelation attrs tuples
    pure (Insert rvName rel)
  
  -- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.
  toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
  toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList (attributesVec attrs)))
    where
      attrs = toAttributes (Proxy :: Proxy a)
  
  tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
  tupleAssocsEqualityPredicate [] = TruePredicate
  tupleAssocsEqualityPredicate pairs =
    foldr1 AndPredicate $
    map
      (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
      pairs
  
  partitionByAttributes ::
       Tupleable a
    => [AttributeName]
    -> a
    -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
  partitionByAttributes attrs =
    partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
  
  -- | Convert a list of key attributes and a 'Tupleable' value to an 'Update'
  --   expression. This expression flushes the non-key attributes of the value to
  --   a tuple with the matching key attributes.
  toUpdateExpr ::
       forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
  toUpdateExpr rvName keyAttrs a = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Update rvName updateMap keyRestriction)
    where
      (keyPairs, updatePairs) = partitionByAttributes keyAttrs a
      updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs
      keyRestriction = tupleAssocsEqualityPredicate keyPairs
      expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
  
  -- | Convert a list of key attributes and a 'Tupleable' value to a 'Delete'
  --   expression. This expression deletes tuples matching the key attributes from
  --   the value.
  toDeleteExpr ::
       forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
  toDeleteExpr rvName keyAttrs val = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Delete rvName keyRestriction)
    where
      keyPairs = fst $ partitionByAttributes keyAttrs val
      keyRestriction = tupleAssocsEqualityPredicate keyPairs
      expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
  
  validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
  validateAttributes actualAttrs expectedAttrs val
     | S.null actualAttrs = Left EmptyAttributesError
     | not (S.null nonMatchingAttrs) = Left (NoSuchAttributeNamesError nonMatchingAttrs)
     | otherwise = Right val
    where
        nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs
  
  -- | Types that can be converted to and from 'RelationTuple'.
  --
  -- deriving without customization:
  --
  -- > data Example = Example
  -- >     { foo :: Integer
  -- >     , bar :: Text
  -- >     }
  -- >     deriving (Generic)
  -- >
  -- > instance Tupleable Example
  --
  -- deriving with customization using "ProjectM36.Tupleable.Deriving":
  --
  -- > data Example = Example
  -- >     { exampleFoo :: Integer
  -- >     , exampleBar :: Text
  -- >     }
  -- >     deriving stock (Generic)
  -- >     deriving (Tupleable)
  -- >         via Codec (Field (DropPrefix "example" >>> CamelCase)) Example
  class Tupleable a where
    toTuple :: a -> RelationTuple
  
    fromTuple :: RelationTuple -> Either RelationalError a
  
    toAttributes :: Proxy a -> Attributes
  
    default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
    toTuple = genericToTuple defaultTupleableOptions
  
    default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
    fromTuple = genericFromTuple defaultTupleableOptions
  
    default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes
    toAttributes = genericToAttributes defaultTupleableOptions
  
  -- | Options that influence deriving behavior.
  newtype TupleableOptions = TupleableOptions {
    -- | A function that translates record field names into attribute names.
    fieldModifier :: T.Text -> T.Text
    }
  
  -- | The default options for deriving Tupleable instances.
  --
  -- These options can be customized by using record update syntax. For example,
  --
  -- > defaultTupleableOptions
  -- >     { fieldModifier = \fieldName ->
  -- >         case Data.Text.stripPrefix "example" fieldName of
  -- >             Nothing -> fieldName
  -- >             Just attributeName -> attributeName
  -- >     }
  --
  -- will result in record field names being translated into attribute names by
  -- removing the prefix "example" from the field names.
  defaultTupleableOptions :: TupleableOptions
  defaultTupleableOptions = TupleableOptions {
    fieldModifier = id
    }
  
  genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple
  genericToTuple opts v = toTupleG opts (from v)
  
  genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a
  genericFromTuple opts tup = to <$> fromTupleG opts tup
  
  genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes
  genericToAttributes opts _ = toAttributesG opts (from (undefined :: a))
  
  class TupleableG g where
    toTupleG :: TupleableOptions -> g a -> RelationTuple
    toAttributesG :: TupleableOptions -> g a -> Attributes
    fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (g a)
    isRecordTypeG :: g a -> Bool
  
  --data type metadata
  instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
    toTupleG opts (M1 v) = toTupleG opts v
    toAttributesG opts (M1 v) = toAttributesG opts v
    fromTupleG opts v = M1 <$> fromTupleG opts v
    isRecordTypeG (M1 v) = isRecordTypeG v
  
  --constructor metadata
  instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
    toTupleG opts (M1 v) = RelationTuple attrs atoms
      where
        attrsToCheck = toAttributesG opts v
        counter = V.generate (arity attrsToCheck) id
        attrs = attributesFromList (V.toList attrsV)
        attrsV = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
                                                               Attribute ("attr" <> T.pack (show (num + 1))) typ
                                                             else
                                                               attr) counter (attributesVec attrsToCheck)
        atoms = V.fromList (toAtomsG v)
    toAttributesG opts (M1 v) = toAttributesG opts v
    fromTupleG opts tup = M1 <$> fromTupleG opts tup
    isRecordTypeG (M1 v) = isRecordTypeG v
  
  -- product types
  instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
    toTupleG = error "toTupleG"
    toAttributesG opts ~(x :*: y) = toAttributesG opts x <> toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception
    fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple
      where
        processedTuple = if isRecordTypeG (undefined :: a x) then
                           tup
                         else
                           trimTuple 1 tup
    isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y
  
  --selector/record
  instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
    toTupleG = error "toTupleG"
    toAttributesG opts m@(M1 v) = A.singleton (Attribute modifiedName aType)
     where
       name = T.pack (selName m)
       modifiedName = if T.null name then
                        name
                      else
                        fieldModifier opts name
       aType = toAtomTypeG v
    fromTupleG opts tup = if null name then -- non-record type, just pull off the first tuple item
                       M1 <$> atomv (V.head (tupleAtoms tup))
                     else do
                       atom <- atomForAttributeName (fieldModifier opts (T.pack name)) tup
                       val <- atomv atom
                       pure (M1 val)
     where
       expectedAtomType = atomType (V.head (attributesVec (toAttributesG opts (undefined :: M1 S c a x))))
       atomv atom = maybe (Left (AtomTypeMismatchError
                                 expectedAtomType
                                 (atomTypeForAtom atom)
                                )) Right (fromAtomG atom [atom])
       name = selName (undefined :: M1 S c a x)
    isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x)))
  
  --constructors with no arguments
  --basically useless but orthoganal to relationTrue
  instance TupleableG U1 where
    toTupleG _ _ = emptyTuple
    toAttributesG _ _ = emptyAttributes
    fromTupleG _ _ = pure U1
    isRecordTypeG _ = False
  
  