{-# 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 :: t a -> RelVarName -> Either RelationalError DatabaseContextExpr
toInsertExpr t a
vals RelVarName
rvName = do
  let attrs :: Attributes
attrs = Proxy a -> Attributes
forall a. Tupleable a => Proxy a -> Attributes
toAttributes (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
  RelationTupleSet
tuples <- Attributes
-> [RelationTuple] -> Either RelationalError RelationTupleSet
mkTupleSet Attributes
attrs ([RelationTuple] -> Either RelationalError RelationTupleSet)
-> [RelationTuple] -> Either RelationalError RelationTupleSet
forall a b. (a -> b) -> a -> b
$ t RelationTuple -> [RelationTuple]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((a -> RelationTuple) -> t a -> t RelationTuple
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> RelationTuple
forall a. Tupleable a => a -> RelationTuple
toTuple t a
vals)
  let rel :: RelationalExprBase a
rel = Attributes -> RelationTupleSet -> RelationalExprBase a
forall a. Attributes -> RelationTupleSet -> RelationalExprBase a
MakeStaticRelation Attributes
attrs RelationTupleSet
tuples
  DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelVarName -> RelationalExprBase () -> DatabaseContextExpr
forall a.
RelVarName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert RelVarName
rvName RelationalExprBase ()
forall a. RelationalExprBase a
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 :: proxy a -> RelVarName -> DatabaseContextExpr
toDefineExpr proxy a
_ RelVarName
rvName = RelVarName -> [AttributeExprBase ()] -> DatabaseContextExpr
forall a.
RelVarName -> [AttributeExprBase a] -> DatabaseContextExprBase a
Define RelVarName
rvName ((Attribute -> AttributeExprBase ())
-> [Attribute] -> [AttributeExprBase ()]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> AttributeExprBase ()
forall a. Attribute -> AttributeExprBase a
NakedAttributeExpr (Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList (Attributes -> Vector Attribute
attributesVec Attributes
attrs)))
  where
    attrs :: Attributes
attrs = Proxy a -> Attributes
forall a. Tupleable a => Proxy a -> Attributes
toAttributes (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
tupleAssocsEqualityPredicate :: [(RelVarName, Atom)] -> RestrictionPredicateExpr
tupleAssocsEqualityPredicate [] = RestrictionPredicateExpr
forall a. RestrictionPredicateExprBase a
TruePredicate
tupleAssocsEqualityPredicate [(RelVarName, Atom)]
pairs =
  (RestrictionPredicateExpr
 -> RestrictionPredicateExpr -> RestrictionPredicateExpr)
-> [RestrictionPredicateExpr] -> RestrictionPredicateExpr
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 RestrictionPredicateExpr
-> RestrictionPredicateExpr -> RestrictionPredicateExpr
forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate ([RestrictionPredicateExpr] -> RestrictionPredicateExpr)
-> [RestrictionPredicateExpr] -> RestrictionPredicateExpr
forall a b. (a -> b) -> a -> b
$
  ((RelVarName, Atom) -> RestrictionPredicateExpr)
-> [(RelVarName, Atom)] -> [RestrictionPredicateExpr]
forall a b. (a -> b) -> [a] -> [b]
map
    (\(RelVarName
name, Atom
atom) -> RelVarName -> AtomExprBase () -> RestrictionPredicateExpr
forall a.
RelVarName -> AtomExprBase a -> RestrictionPredicateExprBase a
AttributeEqualityPredicate RelVarName
name (Atom -> AtomExprBase ()
forall a. Atom -> AtomExprBase a
NakedAtomExpr Atom
atom))
    [(RelVarName, Atom)]
pairs

partitionByAttributes ::
     Tupleable a
  => [AttributeName]
  -> a
  -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
partitionByAttributes :: [RelVarName] -> a -> ([(RelVarName, Atom)], [(RelVarName, Atom)])
partitionByAttributes [RelVarName]
attrs =
  ((RelVarName, Atom) -> Bool)
-> [(RelVarName, Atom)]
-> ([(RelVarName, Atom)], [(RelVarName, Atom)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((RelVarName -> [RelVarName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RelVarName]
attrs) (RelVarName -> Bool)
-> ((RelVarName, Atom) -> RelVarName) -> (RelVarName, Atom) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RelVarName, Atom) -> RelVarName
forall a b. (a, b) -> a
fst) ([(RelVarName, Atom)]
 -> ([(RelVarName, Atom)], [(RelVarName, Atom)]))
-> (a -> [(RelVarName, Atom)])
-> a
-> ([(RelVarName, Atom)], [(RelVarName, Atom)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationTuple -> [(RelVarName, Atom)]
tupleAssocs (RelationTuple -> [(RelVarName, Atom)])
-> (a -> RelationTuple) -> a -> [(RelVarName, Atom)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RelationTuple
forall a. Tupleable a => a -> RelationTuple
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 :: RelVarName
-> [RelVarName] -> a -> Either RelationalError DatabaseContextExpr
toUpdateExpr RelVarName
rvName [RelVarName]
keyAttrs a
a = Set RelVarName
-> Set RelVarName
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
forall a.
Set RelVarName -> Set RelVarName -> a -> Either RelationalError a
validateAttributes ([RelVarName] -> Set RelVarName
forall a. Ord a => [a] -> Set a
S.fromList [RelVarName]
keyAttrs) Set RelVarName
expectedAttrSet (RelVarName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExpr
-> DatabaseContextExpr
forall a.
RelVarName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExprBase a
-> DatabaseContextExprBase a
Update RelVarName
rvName AttributeNameAtomExprMap
forall a. Map RelVarName (AtomExprBase a)
updateMap RestrictionPredicateExpr
keyRestriction)
  where
    ([(RelVarName, Atom)]
keyPairs, [(RelVarName, Atom)]
updatePairs) = [RelVarName] -> a -> ([(RelVarName, Atom)], [(RelVarName, Atom)])
forall a.
Tupleable a =>
[RelVarName] -> a -> ([(RelVarName, Atom)], [(RelVarName, Atom)])
partitionByAttributes [RelVarName]
keyAttrs a
a
    updateMap :: Map RelVarName (AtomExprBase a)
updateMap = [(RelVarName, AtomExprBase a)] -> Map RelVarName (AtomExprBase a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(RelVarName, AtomExprBase a)] -> Map RelVarName (AtomExprBase a))
-> [(RelVarName, AtomExprBase a)]
-> Map RelVarName (AtomExprBase a)
forall a b. (a -> b) -> a -> b
$ (Atom -> AtomExprBase a)
-> (RelVarName, Atom) -> (RelVarName, AtomExprBase a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Atom -> AtomExprBase a
forall a. Atom -> AtomExprBase a
NakedAtomExpr ((RelVarName, Atom) -> (RelVarName, AtomExprBase a))
-> [(RelVarName, Atom)] -> [(RelVarName, AtomExprBase a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RelVarName, Atom)]
updatePairs
    keyRestriction :: RestrictionPredicateExpr
keyRestriction = [(RelVarName, Atom)] -> RestrictionPredicateExpr
tupleAssocsEqualityPredicate [(RelVarName, Atom)]
keyPairs
    expectedAttrSet :: Set RelVarName
expectedAttrSet = Attributes -> Set RelVarName
attributeNameSet (Proxy a -> Attributes
forall a. Tupleable a => Proxy a -> Attributes
toAttributes (Proxy a
forall k (t :: k). Proxy t
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 :: RelVarName
-> [RelVarName] -> a -> Either RelationalError DatabaseContextExpr
toDeleteExpr RelVarName
rvName [RelVarName]
keyAttrs a
val = Set RelVarName
-> Set RelVarName
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
forall a.
Set RelVarName -> Set RelVarName -> a -> Either RelationalError a
validateAttributes ([RelVarName] -> Set RelVarName
forall a. Ord a => [a] -> Set a
S.fromList [RelVarName]
keyAttrs) Set RelVarName
expectedAttrSet (RelVarName -> RestrictionPredicateExpr -> DatabaseContextExpr
forall a.
RelVarName
-> RestrictionPredicateExprBase a -> DatabaseContextExprBase a
Delete RelVarName
rvName RestrictionPredicateExpr
keyRestriction)
  where
    keyPairs :: [(RelVarName, Atom)]
keyPairs = ([(RelVarName, Atom)], [(RelVarName, Atom)])
-> [(RelVarName, Atom)]
forall a b. (a, b) -> a
fst (([(RelVarName, Atom)], [(RelVarName, Atom)])
 -> [(RelVarName, Atom)])
-> ([(RelVarName, Atom)], [(RelVarName, Atom)])
-> [(RelVarName, Atom)]
forall a b. (a -> b) -> a -> b
$ [RelVarName] -> a -> ([(RelVarName, Atom)], [(RelVarName, Atom)])
forall a.
Tupleable a =>
[RelVarName] -> a -> ([(RelVarName, Atom)], [(RelVarName, Atom)])
partitionByAttributes [RelVarName]
keyAttrs a
val
    keyRestriction :: RestrictionPredicateExpr
keyRestriction = [(RelVarName, Atom)] -> RestrictionPredicateExpr
tupleAssocsEqualityPredicate [(RelVarName, Atom)]
keyPairs
    expectedAttrSet :: Set RelVarName
expectedAttrSet = Attributes -> Set RelVarName
attributeNameSet (Proxy a -> Attributes
forall a. Tupleable a => Proxy a -> Attributes
toAttributes (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
validateAttributes :: Set RelVarName -> Set RelVarName -> a -> Either RelationalError a
validateAttributes Set RelVarName
actualAttrs Set RelVarName
expectedAttrs a
val
   | Set RelVarName -> Bool
forall a. Set a -> Bool
S.null Set RelVarName
actualAttrs = RelationalError -> Either RelationalError a
forall a b. a -> Either a b
Left RelationalError
EmptyAttributesError
   | Bool -> Bool
not (Set RelVarName -> Bool
forall a. Set a -> Bool
S.null Set RelVarName
nonMatchingAttrs) = RelationalError -> Either RelationalError a
forall a b. a -> Either a b
Left (Set RelVarName -> RelationalError
NoSuchAttributeNamesError Set RelVarName
nonMatchingAttrs)
   | Bool
otherwise = a -> Either RelationalError a
forall a b. b -> Either a b
Right a
val
  where
      nonMatchingAttrs :: Set RelVarName
nonMatchingAttrs = Set RelVarName -> Set RelVarName -> Set RelVarName
attributeNamesNotContained Set RelVarName
actualAttrs Set RelVarName
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 = TupleableOptions -> a -> RelationTuple
forall a.
(Generic a, TupleableG (Rep a)) =>
TupleableOptions -> a -> RelationTuple
genericToTuple TupleableOptions
defaultTupleableOptions

  default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
  fromTuple = TupleableOptions -> RelationTuple -> Either RelationalError a
forall a.
(Generic a, TupleableG (Rep a)) =>
TupleableOptions -> RelationTuple -> Either RelationalError a
genericFromTuple TupleableOptions
defaultTupleableOptions

  default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes
  toAttributes = TupleableOptions -> Proxy a -> Attributes
forall a.
(Generic a, TupleableG (Rep a)) =>
TupleableOptions -> Proxy a -> Attributes
genericToAttributes TupleableOptions
defaultTupleableOptions

-- | Options that influence deriving behavior.
newtype TupleableOptions = TupleableOptions {
  -- | A function that translates record field names into attribute names.
  TupleableOptions -> RelVarName -> RelVarName
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
defaultTupleableOptions = TupleableOptions :: (RelVarName -> RelVarName) -> TupleableOptions
TupleableOptions {
  fieldModifier :: RelVarName -> RelVarName
fieldModifier = RelVarName -> RelVarName
forall a. a -> a
id
  }

genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple
genericToTuple :: TupleableOptions -> a -> RelationTuple
genericToTuple TupleableOptions
opts a
v = TupleableOptions -> Rep a Any -> RelationTuple
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> RelationTuple
toTupleG TupleableOptions
opts (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
v)

genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a
genericFromTuple :: TupleableOptions -> RelationTuple -> Either RelationalError a
genericFromTuple TupleableOptions
opts RelationTuple
tup = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a)
-> Either RelationalError (Rep a Any) -> Either RelationalError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupleableOptions
-> RelationTuple -> Either RelationalError (Rep a Any)
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> RelationTuple -> Either RelationalError (g a)
fromTupleG TupleableOptions
opts RelationTuple
tup

genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes
genericToAttributes :: TupleableOptions -> Proxy a -> Attributes
genericToAttributes TupleableOptions
opts Proxy a
_ = TupleableOptions -> Rep a Any -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from (a
forall a. HasCallStack => a
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 :: TupleableOptions -> M1 D c a a -> RelationTuple
toTupleG TupleableOptions
opts (M1 a a
v) = TupleableOptions -> a a -> RelationTuple
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> RelationTuple
toTupleG TupleableOptions
opts a a
v
  toAttributesG :: TupleableOptions -> M1 D c a a -> Attributes
toAttributesG TupleableOptions
opts (M1 a a
v) = TupleableOptions -> a a -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts a a
v
  fromTupleG :: TupleableOptions
-> RelationTuple -> Either RelationalError (M1 D c a a)
fromTupleG TupleableOptions
opts RelationTuple
v = a a -> M1 D c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 D c a a)
-> Either RelationalError (a a)
-> Either RelationalError (M1 D c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupleableOptions -> RelationTuple -> Either RelationalError (a a)
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> RelationTuple -> Either RelationalError (g a)
fromTupleG TupleableOptions
opts RelationTuple
v
  isRecordTypeG :: M1 D c a a -> Bool
isRecordTypeG (M1 a a
v) = a a -> Bool
forall (g :: * -> *) a. TupleableG g => g a -> Bool
isRecordTypeG a a
v

--constructor metadata
instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
  toTupleG :: TupleableOptions -> M1 C c a a -> RelationTuple
toTupleG TupleableOptions
opts (M1 a a
v) = Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
attrs Vector Atom
atoms
    where
      attrsToCheck :: Attributes
attrsToCheck = TupleableOptions -> a a -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts a a
v
      counter :: Vector Int
counter = Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate (Attributes -> Int
arity Attributes
attrsToCheck) Int -> Int
forall a. a -> a
id
      attrs :: Attributes
attrs = [Attribute] -> Attributes
attributesFromList (Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList Vector Attribute
attrsV)
      attrsV :: Vector Attribute
attrsV = (Int -> Attribute -> Attribute)
-> Vector Int -> Vector Attribute -> Vector Attribute
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith (\Int
num attr :: Attribute
attr@(Attribute RelVarName
name AtomType
typ) -> if RelVarName -> Bool
T.null RelVarName
name then
                                                             RelVarName -> AtomType -> Attribute
Attribute (RelVarName
"attr" RelVarName -> RelVarName -> RelVarName
forall a. Semigroup a => a -> a -> a
<> String -> RelVarName
T.pack (Int -> String
forall a. Show a => a -> String
show (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))) AtomType
typ
                                                           else
                                                             Attribute
attr) Vector Int
counter (Attributes -> Vector Attribute
attributesVec Attributes
attrsToCheck)
      atoms :: Vector Atom
atoms = [Atom] -> Vector Atom
forall a. [a] -> Vector a
V.fromList (a a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
v)
  toAttributesG :: TupleableOptions -> M1 C c a a -> Attributes
toAttributesG TupleableOptions
opts (M1 a a
v) = TupleableOptions -> a a -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts a a
v
  fromTupleG :: TupleableOptions
-> RelationTuple -> Either RelationalError (M1 C c a a)
fromTupleG TupleableOptions
opts RelationTuple
tup = a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 C c a a)
-> Either RelationalError (a a)
-> Either RelationalError (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupleableOptions -> RelationTuple -> Either RelationalError (a a)
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> RelationTuple -> Either RelationalError (g a)
fromTupleG TupleableOptions
opts RelationTuple
tup
  isRecordTypeG :: M1 C c a a -> Bool
isRecordTypeG (M1 a a
v) = a a -> Bool
forall (g :: * -> *) a. TupleableG g => g a -> Bool
isRecordTypeG a a
v

-- product types
instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
  toTupleG :: TupleableOptions -> (:*:) a b a -> RelationTuple
toTupleG = String -> TupleableOptions -> (:*:) a b a -> RelationTuple
forall a. HasCallStack => String -> a
error String
"toTupleG"
  toAttributesG :: TupleableOptions -> (:*:) a b a -> Attributes
toAttributesG TupleableOptions
opts ~(a a
x :*: b a
y) = TupleableOptions -> a a -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts a a
x Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> TupleableOptions -> b a -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts b a
y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception
  fromTupleG :: TupleableOptions
-> RelationTuple -> Either RelationalError ((:*:) a b a)
fromTupleG TupleableOptions
opts RelationTuple
tup = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> Either RelationalError (a a)
-> Either RelationalError (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupleableOptions -> RelationTuple -> Either RelationalError (a a)
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> RelationTuple -> Either RelationalError (g a)
fromTupleG TupleableOptions
opts RelationTuple
tup Either RelationalError (b a -> (:*:) a b a)
-> Either RelationalError (b a)
-> Either RelationalError ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TupleableOptions -> RelationTuple -> Either RelationalError (b a)
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> RelationTuple -> Either RelationalError (g a)
fromTupleG TupleableOptions
opts RelationTuple
processedTuple
    where
      processedTuple :: RelationTuple
processedTuple = if a Any -> Bool
forall (g :: * -> *) a. TupleableG g => g a -> Bool
isRecordTypeG (forall x. a x
forall a. HasCallStack => a
undefined :: a x) then
                         RelationTuple
tup
                       else
                         Int -> RelationTuple -> RelationTuple
trimTuple Int
1 RelationTuple
tup
  isRecordTypeG :: (:*:) a b a -> Bool
isRecordTypeG ~(a a
x :*: b a
y) = a a -> Bool
forall (g :: * -> *) a. TupleableG g => g a -> Bool
isRecordTypeG a a
x Bool -> Bool -> Bool
|| b a -> Bool
forall (g :: * -> *) a. TupleableG g => g a -> Bool
isRecordTypeG b a
y

--selector/record
instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
  toTupleG :: TupleableOptions -> M1 S c a a -> RelationTuple
toTupleG = String -> TupleableOptions -> M1 S c a a -> RelationTuple
forall a. HasCallStack => String -> a
error String
"toTupleG"
  toAttributesG :: TupleableOptions -> M1 S c a a -> Attributes
toAttributesG TupleableOptions
opts m :: M1 S c a a
m@(M1 a a
v) = Attribute -> Attributes
A.singleton (RelVarName -> AtomType -> Attribute
Attribute RelVarName
modifiedName AtomType
aType)
   where
     name :: RelVarName
name = String -> RelVarName
T.pack (M1 S c a a -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S c a a
m)
     modifiedName :: RelVarName
modifiedName = if RelVarName -> Bool
T.null RelVarName
name then
                      RelVarName
name
                    else
                      TupleableOptions -> RelVarName -> RelVarName
fieldModifier TupleableOptions
opts RelVarName
name
     aType :: AtomType
aType = a a -> AtomType
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG a a
v
  fromTupleG :: TupleableOptions
-> RelationTuple -> Either RelationalError (M1 S c a a)
fromTupleG TupleableOptions
opts RelationTuple
tup = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name then -- non-record type, just pull off the first tuple item
                     a a -> M1 S c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 S c a a)
-> Either RelationalError (a a)
-> Either RelationalError (M1 S c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> Either RelationalError (a a)
forall (g :: * -> *) a.
AtomableG g =>
Atom -> Either RelationalError (g a)
atomv (Vector Atom -> Atom
forall a. Vector a -> a
V.head (RelationTuple -> Vector Atom
tupleAtoms RelationTuple
tup))
                   else do
                     Atom
atom <- RelVarName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName (TupleableOptions -> RelVarName -> RelVarName
fieldModifier TupleableOptions
opts (String -> RelVarName
T.pack String
name)) RelationTuple
tup
                     a a
val <- Atom -> Either RelationalError (a a)
forall (g :: * -> *) a.
AtomableG g =>
Atom -> Either RelationalError (g a)
atomv Atom
atom
                     M1 S c a a -> Either RelationalError (M1 S c a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a a -> M1 S c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 a a
val)
   where
     expectedAtomType :: AtomType
expectedAtomType = Attribute -> AtomType
atomType (Vector Attribute -> Attribute
forall a. Vector a -> a
V.head (Attributes -> Vector Attribute
attributesVec (TupleableOptions -> M1 S c a Any -> Attributes
forall (g :: * -> *) a.
TupleableG g =>
TupleableOptions -> g a -> Attributes
toAttributesG TupleableOptions
opts (forall x. M1 S c a x
forall a. HasCallStack => a
undefined :: M1 S c a x))))
     atomv :: Atom -> Either RelationalError (g a)
atomv Atom
atom = Either RelationalError (g a)
-> (g a -> Either RelationalError (g a))
-> Maybe (g a)
-> Either RelationalError (g a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RelationalError -> Either RelationalError (g a)
forall a b. a -> Either a b
Left (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError
                               AtomType
expectedAtomType
                               (Atom -> AtomType
atomTypeForAtom Atom
atom)
                              )) g a -> Either RelationalError (g a)
forall a b. b -> Either a b
Right (Atom -> [Atom] -> Maybe (g a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom
atom])
     name :: String
name = M1 S c a Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall x. M1 S c a x
forall a. HasCallStack => a
undefined :: M1 S c a x)
  isRecordTypeG :: M1 S c a a -> Bool
isRecordTypeG M1 S c a a
_ = Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (M1 S c a Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall x. M1 S c a x
forall a. HasCallStack => a
undefined :: M1 S c a x)))

--constructors with no arguments
--basically useless but orthoganal to relationTrue
instance TupleableG U1 where
  toTupleG :: TupleableOptions -> U1 a -> RelationTuple
toTupleG TupleableOptions
_ U1 a
_ = RelationTuple
emptyTuple
  toAttributesG :: TupleableOptions -> U1 a -> Attributes
toAttributesG TupleableOptions
_ U1 a
_ = Attributes
emptyAttributes
  fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (U1 a)
fromTupleG TupleableOptions
_ RelationTuple
_ = U1 a -> Either RelationalError (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
  isRecordTypeG :: U1 a -> Bool
isRecordTypeG U1 a
_ = Bool
False