@@ -1,18 +1,27 @@
1−{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-}
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+
28module ProjectM36.Tupleable where
3−import ProjectM36.Base
4−import ProjectM36.Error
5−import ProjectM36.TupleSet
6−import ProjectM36.Tuple
7−import ProjectM36.Atomable
8−import ProjectM36.DataTypes.Primitive
9−import ProjectM36.Attribute hiding (null)
10−import GHC.Generics
11−import qualified Data.Vector as V
12−import qualified Data.Text as T
13−import Data.Monoid
14−import Data.Proxy
15−import Data.Foldable
9+
10+import Data.Foldable
11+import Data.List (partition)
12+import qualified Data.Map as Map
13+import Data.Monoid
14+import Data.Proxy
15+import qualified Data.Text as T
16+import qualified Data.Vector as V
17+import GHC.Generics
18+import ProjectM36.Atomable
19+import ProjectM36.Attribute hiding (null)
20+import ProjectM36.Base
21+import ProjectM36.DataTypes.Primitive
22+import ProjectM36.Error
23+import ProjectM36.Tuple
24+import ProjectM36.TupleSet
1625
1726{-import Data.Binary
1827import Control.DeepSeq
@@ -21,27 +30,27 @@ data Test1T = Test1C {
2130 attrA :: Int
2231 }
2332 deriving (Generic, Show)
24−
33+
2534data Test2T a b = Test2C {
2635 attrB :: a,
2736 attrC :: b
2837 }
2938 deriving (Generic, Show)
30−
39+
3140instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
3241
3342instance Tupleable Test1T
3443
3544data TestUnnamed1 = TestUnnamed1 Int Double T.Text
3645 deriving (Show,Eq, Generic)
37−
38−instance Tupleable TestUnnamed1
46+
47+instance Tupleable TestUnnamed1
3948
4049data Test7A = Test7AC Integer
4150 deriving (Generic, Show, Eq, Atomable, NFData, Binary)
42−
43−
44−data Test7T = Test7C Test7A
51+
52+
53+data Test7T = Test7C Test7A
4554 deriving (Generic, Show, Eq)
4655
4756instance Tupleable Test7T
@@ -52,36 +61,72 @@ toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName ->
5261toInsertExpr vals rvName = do
5362 let attrs = toAttributes (Proxy :: Proxy a)
5463 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
55− let rel = MakeStaticRelation attrs tuples
64+ let rel = MakeStaticRelation attrs tuples
5665 pure (Insert rvName rel)
57−
66+
5867-- | 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'.
5968toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
6069toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
61− where
70+ where
6271 attrs = toAttributes (Proxy :: Proxy a)
6372
73+tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
74+tupleAssocsEqualityPredicate pairs =
75+ foldr1 AndPredicate $
76+ map
77+ (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
78+ pairs
79+
80+partitionByAttributes ::
81+ Tupleable a
82+ => [AttributeName]
83+ -> a
84+ -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
85+partitionByAttributes attrs =
86+ partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
87+
88+-- | Convert a list of key attributes and a 'Tupleable' value to an 'Update'
89+-- expression. This expression flushes the non-key attributes of the value to
90+-- a tuple with the matching key attributes.
91+toUpdateExpr ::
92+ Tupleable a => RelVarName -> [AttributeName] -> a -> DatabaseContextExpr
93+toUpdateExpr rvName keyAttrs a = Update rvName updateMap keyRestriction
94+ where
95+ (keyPairs, updatePairs) = partitionByAttributes keyAttrs a
96+ updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs
97+ keyRestriction = tupleAssocsEqualityPredicate keyPairs
98+
99+-- | Convert a list of key attributes and a 'Tupleable' value to a 'Delete'
100+-- expression. This expression deletes tuples matching the key attributes from
101+-- the value.
102+toDeleteExpr ::
103+ Tupleable a => RelVarName -> [AttributeName] -> a -> DatabaseContextExpr
104+toDeleteExpr rvName keyAttrs a = Delete rvName keyRestriction
105+ where
106+ keyPairs = fst $ partitionByAttributes keyAttrs a
107+ keyRestriction = tupleAssocsEqualityPredicate keyPairs
108+
64109class Tupleable a where
65110 toTuple :: a -> RelationTuple
66−
111+
67112 fromTuple :: RelationTuple -> Either RelationalError a
68−
113+
69114 toAttributes :: proxy a -> Attributes
70115
71116 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
72117 toTuple v = toTupleG (from v)
73−
118+
74119 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
75120 fromTuple tup = to <$> fromTupleG tup
76−
121+
77122 default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes
78123 toAttributes _ = toAttributesG (from (undefined :: a))
79−
80−class TupleableG g where
124+
125+class TupleableG g where
81126 toTupleG :: g a -> RelationTuple
82127 toAttributesG :: g a -> Attributes
83128 fromTupleG :: RelationTuple -> Either RelationalError (g a)
84−
129+
85130--data type metadata
86131instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
87132 toTupleG (M1 v) = toTupleG v
@@ -94,14 +139,14 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe
94139 where
95140 attrsToCheck = toAttributesG v
96141 counter = V.generate (V.length attrsToCheck) id
97− attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
98− Attribute ("attr" <> T.pack (show (num + 1))) typ
142+ attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
143+ Attribute ("attr" <> T.pack (show (num + 1))) typ
99144 else
100− attr) counter attrsToCheck
145+ attr) counter attrsToCheck
101146 atoms = V.fromList (toAtomsG v)
102147 toAttributesG (M1 v) = toAttributesG v
103148 fromTupleG tup = M1 <$> fromTupleG tup
104−
149+
105150-- product types
106151instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
107152 toTupleG = error "toTupleG"
@@ -123,17 +168,17 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
123168 pure (M1 val)
124169 where
125170 expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))
126− atomv atom = maybe (Left (AtomTypeMismatchError
171+ atomv atom = maybe (Left (AtomTypeMismatchError
127172 expectedAtomType
128173 (atomTypeForAtom atom)
129174 )) Right (fromAtomG atom [atom])
130175 name = selName (undefined :: M1 S c a x)
131176
132−--constructors with no arguments
177+--constructors with no arguments
133178--basically useless but orthoganal to relationTrue
134179instance TupleableG U1 where
135180 toTupleG _= emptyTuple
136181 toAttributesG _ = emptyAttributes
137182 fromTupleG _ = pure U1
138−
139−
183+
184+