git.iko.soy/project-m36
on cfa7253 help sign in
project-m36/src/lib/ProjectM36/Tupleable.hs
207 lines 8.4 kB history raw
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE UndecidableInstances #-}
8module ProjectM36.Tupleable where
10import Data.Foldable
11import Data.List (partition)
12import qualified Data.Map as Map
13--import Data.Monoid
14import Data.Proxy
15import qualified Data.Text as T
16import qualified Data.Vector as V
17import GHC.Generics
18import ProjectM36.Atomable
19import ProjectM36.Attribute hiding (null)
20import ProjectM36.Base
21import ProjectM36.DataTypes.Primitive
22import ProjectM36.Error
23import ProjectM36.Tuple
24import ProjectM36.TupleSet
25import qualified Data.Set as S
27{-import Data.Binary
28import Control.DeepSeq
30data Test1T = Test1C {
31 attrA :: Int
32 }
33 deriving (Generic, Show)
35data Test2T a b = Test2C {
36 attrB :: a,
37 attrC :: b
38 }
39 deriving (Generic, Show)
41instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
43instance Tupleable Test1T
45data TestUnnamed1 = TestUnnamed1 Int Double T.Text
46 deriving (Show,Eq, Generic)
48instance Tupleable TestUnnamed1
50data Test7A = Test7AC Integer
51 deriving (Generic, Show, Eq, Atomable, NFData, Binary)
54data Test7T = Test7C Test7A
55 deriving (Generic, Show, Eq)
57instance Tupleable Test7T
58-}
60-- | 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.
61toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr
62toInsertExpr vals rvName = do
63 let attrs = toAttributes (Proxy :: Proxy a)
64 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
65 let rel = MakeStaticRelation attrs tuples
66 pure (Insert rvName rel)
68-- | 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'.
69toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
70toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
71 where
72 attrs = toAttributes (Proxy :: Proxy a)
74tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
75tupleAssocsEqualityPredicate [] = TruePredicate
76tupleAssocsEqualityPredicate pairs =
77 foldr1 AndPredicate $
78 map
79 (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
80 pairs
82partitionByAttributes ::
83 Tupleable a
84 => [AttributeName]
85 -> a
86 -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
87partitionByAttributes attrs =
88 partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
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.
93toUpdateExpr ::
94 forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
95toUpdateExpr 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))
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.
105toDeleteExpr ::
106 forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
107toDeleteExpr 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))
113validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
114validateAttributes 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
122class Tupleable a where
123 toTuple :: a -> RelationTuple
125 fromTuple :: RelationTuple -> Either RelationalError a
127 toAttributes :: proxy a -> Attributes
129 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
130 toTuple v = toTupleG (from v)
132 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
133 fromTuple tup = to <$> fromTupleG tup
135 default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes
136 toAttributes _ = toAttributesG (from (undefined :: a))
138class TupleableG g where
139 toTupleG :: g a -> RelationTuple
140 toAttributesG :: g a -> Attributes
141 fromTupleG :: RelationTuple -> Either RelationalError (g a)
142 isRecordTypeG :: g a -> Bool
144--data type metadata
145instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
146 toTupleG (M1 v) = toTupleG v
147 toAttributesG (M1 v) = toAttributesG v
148 fromTupleG v = M1 <$> fromTupleG v
149 isRecordTypeG (M1 v) = isRecordTypeG v
151--constructor metadata
152instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
153 toTupleG (M1 v) = RelationTuple attrs atoms
154 where
155 attrsToCheck = toAttributesG v
156 counter = V.generate (V.length attrsToCheck) id
157 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
158 Attribute ("attr" <> T.pack (show (num + 1))) typ
159 else
160 attr) counter attrsToCheck
161 atoms = V.fromList (toAtomsG v)
162 toAttributesG (M1 v) = toAttributesG v
163 fromTupleG tup = M1 <$> fromTupleG tup
164 isRecordTypeG (M1 v) = isRecordTypeG v
166-- product types
167instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
168 toTupleG = error "toTupleG"
169 toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception
170 fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple
171 where
172 processedTuple = if isRecordTypeG (undefined :: a x) then
173 tup
174 else
175 trimTuple 1 tup
176 isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y
178--selector/record
179instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
180 toTupleG = error "toTupleG"
181 toAttributesG m@(M1 v) = V.singleton (Attribute name aType)
182 where
183 name = T.pack (selName m)
184 aType = toAtomTypeG v
185 fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item
186 M1 <$> atomv (V.head (tupleAtoms tup))
187 else do
188 atom <- atomForAttributeName (T.pack name) tup
189 val <- atomv atom
190 pure (M1 val)
191 where
192 expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))
193 atomv atom = maybe (Left (AtomTypeMismatchError
194 expectedAtomType
195 (atomTypeForAtom atom)
196 )) Right (fromAtomG atom [atom])
197 name = selName (undefined :: M1 S c a x)
198 isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x)))
200--constructors with no arguments
201--basically useless but orthoganal to relationTrue
202instance TupleableG U1 where
203 toTupleG _= emptyTuple
204 toAttributesG _ = emptyAttributes
205 fromTupleG _ = pure U1
206 isRecordTypeG _ = False