@@ -1,18 +1,28 @@
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
25+import qualified Data.Set as S
1626
1727{-import Data.Binary
1828import Control.DeepSeq
@@ -21,27 +31,27 @@ data Test1T = Test1C {
2131 attrA :: Int
2232 }
2333 deriving (Generic, Show)
24−
34+
2535data Test2T a b = Test2C {
2636 attrB :: a,
2737 attrC :: b
2838 }
2939 deriving (Generic, Show)
30−
40+
3141instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
3242
3343instance Tupleable Test1T
3444
3545data TestUnnamed1 = TestUnnamed1 Int Double T.Text
3646 deriving (Show,Eq, Generic)
37−
38−instance Tupleable TestUnnamed1
47+
48+instance Tupleable TestUnnamed1
3949
4050data Test7A = Test7AC Integer
4151 deriving (Generic, Show, Eq, Atomable, NFData, Binary)
42−
43−
44−data Test7T = Test7C Test7A
52+
53+
54+data Test7T = Test7C Test7A
4555 deriving (Generic, Show, Eq)
4656
4757instance Tupleable Test7T
@@ -52,36 +62,84 @@ toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName ->
5262toInsertExpr vals rvName = do
5363 let attrs = toAttributes (Proxy :: Proxy a)
5464 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
55− let rel = MakeStaticRelation attrs tuples
65+ let rel = MakeStaticRelation attrs tuples
5666 pure (Insert rvName rel)
57−
67+
5868-- | 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'.
5969toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
6070toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
61− where
71+ where
6272 attrs = toAttributes (Proxy :: Proxy a)
6373
74+tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
75+tupleAssocsEqualityPredicate [] = TruePredicate
76+tupleAssocsEqualityPredicate pairs =
77+ foldr1 AndPredicate $
78+ map
79+ (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
80+ pairs
81+
82+partitionByAttributes ::
83+ Tupleable a
84+ => [AttributeName]
85+ -> a
86+ -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
87+partitionByAttributes attrs =
88+ partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
89+
90+-- | Convert a list of key attributes and a 'Tupleable' value to an 'Update'
91+-- expression. This expression flushes the non-key attributes of the value to
92+-- a tuple with the matching key attributes.
93+toUpdateExpr ::
94+ forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
95+toUpdateExpr rvName keyAttrs a = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Update rvName updateMap keyRestriction)
96+ where
97+ (keyPairs, updatePairs) = partitionByAttributes keyAttrs a
98+ updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs
99+ keyRestriction = tupleAssocsEqualityPredicate keyPairs
100+ expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
101+
102+-- | Convert a list of key attributes and a 'Tupleable' value to a 'Delete'
103+-- expression. This expression deletes tuples matching the key attributes from
104+-- the value.
105+toDeleteExpr ::
106+ forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
107+toDeleteExpr rvName keyAttrs val = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Delete rvName keyRestriction)
108+ where
109+ keyPairs = fst $ partitionByAttributes keyAttrs val
110+ keyRestriction = tupleAssocsEqualityPredicate keyPairs
111+ expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
112+
113+validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
114+validateAttributes actualAttrs expectedAttrs val
115+ | S.null actualAttrs = Left EmptyAttributesError
116+ | not (S.null nonMatchingAttrs) = Left (NoSuchAttributeNamesError nonMatchingAttrs)
117+ | otherwise = Right val
118+ where
119+ nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs
120+
121+
64122class Tupleable a where
65123 toTuple :: a -> RelationTuple
66−
124+
67125 fromTuple :: RelationTuple -> Either RelationalError a
68−
126+
69127 toAttributes :: proxy a -> Attributes
70128
71129 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
72130 toTuple v = toTupleG (from v)
73−
131+
74132 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
75133 fromTuple tup = to <$> fromTupleG tup
76−
134+
77135 default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes
78136 toAttributes _ = toAttributesG (from (undefined :: a))
79−
80−class TupleableG g where
137+
138+class TupleableG g where
81139 toTupleG :: g a -> RelationTuple
82140 toAttributesG :: g a -> Attributes
83141 fromTupleG :: RelationTuple -> Either RelationalError (g a)
84−
142+
85143--data type metadata
86144instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
87145 toTupleG (M1 v) = toTupleG v
@@ -94,14 +152,14 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe
94152 where
95153 attrsToCheck = toAttributesG v
96154 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
155+ attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
156+ Attribute ("attr" <> T.pack (show (num + 1))) typ
99157 else
100− attr) counter attrsToCheck
158+ attr) counter attrsToCheck
101159 atoms = V.fromList (toAtomsG v)
102160 toAttributesG (M1 v) = toAttributesG v
103161 fromTupleG tup = M1 <$> fromTupleG tup
104−
162+
105163-- product types
106164instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
107165 toTupleG = error "toTupleG"
@@ -123,17 +181,17 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
123181 pure (M1 val)
124182 where
125183 expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))
126− atomv atom = maybe (Left (AtomTypeMismatchError
184+ atomv atom = maybe (Left (AtomTypeMismatchError
127185 expectedAtomType
128186 (atomTypeForAtom atom)
129187 )) Right (fromAtomG atom [atom])
130188 name = selName (undefined :: M1 S c a x)
131189
132−--constructors with no arguments
190+--constructors with no arguments
133191--basically useless but orthoganal to relationTrue
134192instance TupleableG U1 where
135193 toTupleG _= emptyTuple
136194 toAttributesG _ = emptyAttributes
137195 fromTupleG _ = pure U1
138−
139−
196+
197+