git.iko.soy/project-m36
on 0ff751e help sign in
project-m36/src/lib/ProjectM36/Tupleable.hs
210 lines 8.5 kB history raw
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE UndecidableInstances #-}
7{-# LANGUAGE CPP #-}
9module ProjectM36.Tupleable where
11import Data.Foldable
12import Data.List (partition)
13import qualified Data.Map as Map
14#if __GLASGOW_HASKELL__ < 804
15import Data.Monoid
16#endif
17import Data.Proxy
18import qualified Data.Text as T
19import qualified Data.Vector as V
20import GHC.Generics
21import ProjectM36.Atomable
22import ProjectM36.Attribute hiding (null)
23import ProjectM36.Base
24import ProjectM36.DataTypes.Primitive
25import ProjectM36.Error
26import ProjectM36.Tuple
27import ProjectM36.TupleSet
28import qualified Data.Set as S
30{-import Data.Binary
31import Control.DeepSeq
33data Test1T = Test1C {
34 attrA :: Int
35 }
36 deriving (Generic, Show)
38data Test2T a b = Test2C {
39 attrB :: a,
40 attrC :: b
41 }
42 deriving (Generic, Show)
44instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
46instance Tupleable Test1T
48data TestUnnamed1 = TestUnnamed1 Int Double T.Text
49 deriving (Show,Eq, Generic)
51instance Tupleable TestUnnamed1
53data Test7A = Test7AC Integer
54 deriving (Generic, Show, Eq, Atomable, NFData, Binary)
57data Test7T = Test7C Test7A
58 deriving (Generic, Show, Eq)
60instance Tupleable Test7T
61-}
63-- | 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.
64toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr
65toInsertExpr vals rvName = do
66 let attrs = toAttributes (Proxy :: Proxy a)
67 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
68 let rel = MakeStaticRelation attrs tuples
69 pure (Insert rvName rel)
71-- | 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'.
72toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
73toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
74 where
75 attrs = toAttributes (Proxy :: Proxy a)
77tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
78tupleAssocsEqualityPredicate [] = TruePredicate
79tupleAssocsEqualityPredicate pairs =
80 foldr1 AndPredicate $
81 map
82 (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
83 pairs
85partitionByAttributes ::
86 Tupleable a
87 => [AttributeName]
88 -> a
89 -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
90partitionByAttributes attrs =
91 partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
93-- | Convert a list of key attributes and a 'Tupleable' value to an 'Update'
94-- expression. This expression flushes the non-key attributes of the value to
95-- a tuple with the matching key attributes.
96toUpdateExpr ::
97 forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
98toUpdateExpr rvName keyAttrs a = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Update rvName updateMap keyRestriction)
99 where
100 (keyPairs, updatePairs) = partitionByAttributes keyAttrs a
101 updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs
102 keyRestriction = tupleAssocsEqualityPredicate keyPairs
103 expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
105-- | Convert a list of key attributes and a 'Tupleable' value to a 'Delete'
106-- expression. This expression deletes tuples matching the key attributes from
107-- the value.
108toDeleteExpr ::
109 forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
110toDeleteExpr rvName keyAttrs val = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Delete rvName keyRestriction)
111 where
112 keyPairs = fst $ partitionByAttributes keyAttrs val
113 keyRestriction = tupleAssocsEqualityPredicate keyPairs
114 expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
116validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
117validateAttributes actualAttrs expectedAttrs val
118 | S.null actualAttrs = Left EmptyAttributesError
119 | not (S.null nonMatchingAttrs) = Left (NoSuchAttributeNamesError nonMatchingAttrs)
120 | otherwise = Right val
121 where
122 nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs
125class Tupleable a where
126 toTuple :: a -> RelationTuple
128 fromTuple :: RelationTuple -> Either RelationalError a
130 toAttributes :: proxy a -> Attributes
132 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
133 toTuple v = toTupleG (from v)
135 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
136 fromTuple tup = to <$> fromTupleG tup
138 default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes
139 toAttributes _ = toAttributesG (from (undefined :: a))
141class TupleableG g where
142 toTupleG :: g a -> RelationTuple
143 toAttributesG :: g a -> Attributes
144 fromTupleG :: RelationTuple -> Either RelationalError (g a)
145 isRecordTypeG :: g a -> Bool
147--data type metadata
148instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
149 toTupleG (M1 v) = toTupleG v
150 toAttributesG (M1 v) = toAttributesG v
151 fromTupleG v = M1 <$> fromTupleG v
152 isRecordTypeG (M1 v) = isRecordTypeG v
154--constructor metadata
155instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
156 toTupleG (M1 v) = RelationTuple attrs atoms
157 where
158 attrsToCheck = toAttributesG v
159 counter = V.generate (V.length attrsToCheck) id
160 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
161 Attribute ("attr" <> T.pack (show (num + 1))) typ
162 else
163 attr) counter attrsToCheck
164 atoms = V.fromList (toAtomsG v)
165 toAttributesG (M1 v) = toAttributesG v
166 fromTupleG tup = M1 <$> fromTupleG tup
167 isRecordTypeG (M1 v) = isRecordTypeG v
169-- product types
170instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
171 toTupleG = error "toTupleG"
172 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
173 fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple
174 where
175 processedTuple = if isRecordTypeG (undefined :: a x) then
176 tup
177 else
178 trimTuple 1 tup
179 isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y
181--selector/record
182instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
183 toTupleG = error "toTupleG"
184 toAttributesG m@(M1 v) = V.singleton (Attribute name aType)
185 where
186 name = T.pack (selName m)
187 aType = toAtomTypeG v
188 fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item
189 M1 <$> atomv (V.head (tupleAtoms tup))
190 else do
191 atom <- atomForAttributeName (T.pack name) tup
192 val <- atomv atom
193 pure (M1 val)
194 where
195 expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))
196 atomv atom = maybe (Left (AtomTypeMismatchError
197 expectedAtomType
198 (atomTypeForAtom atom)
199 )) Right (fromAtomG atom [atom])
200 name = selName (undefined :: M1 S c a x)
201 isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x)))
203--constructors with no arguments
204--basically useless but orthoganal to relationTrue
205instance TupleableG U1 where
206 toTupleG _= emptyTuple
207 toAttributesG _ = emptyAttributes
208 fromTupleG _ = pure U1
209 isRecordTypeG _ = False