git.iko.soy/project-m36
on f843252 help sign in
project-m36/src/lib/ProjectM36/Tupleable.hs
286 lines 11 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
10 ( toInsertExpr
11 , toDefineExpr
12 , tupleAssocsEqualityPredicate
13 , partitionByAttributes
14 , toUpdateExpr
15 , toDeleteExpr
16 , validateAttributes
17 , Tupleable(..)
19 -- * Generics
20 , genericToTuple
21 , genericFromTuple
22 , genericToAttributes
23 , TupleableG(..)
24 -- ** Options
25 , defaultTupleableOptions
26 , TupleableOptions()
27 , fieldModifier
28 ) where
30import Data.Foldable
31import Data.List (partition)
32import qualified Data.Map as Map
33#if __GLASGOW_HASKELL__ < 804
34import Data.Monoid
35#endif
36import Data.Proxy
37import qualified Data.Text as T
38import qualified Data.Vector as V
39import GHC.Generics
40import ProjectM36.Atomable
41import ProjectM36.Attribute hiding (null)
42import ProjectM36.Base
43import ProjectM36.DataTypes.Primitive
44import ProjectM36.Error
45import ProjectM36.Tuple
46import ProjectM36.TupleSet
47import qualified Data.Set as S
49{-import Data.Binary
50import Control.DeepSeq
52data Test1T = Test1C {
53 attrA :: Int
54 }
55 deriving (Generic, Show)
57data Test2T a b = Test2C {
58 attrB :: a,
59 attrC :: b
60 }
61 deriving (Generic, Show)
63instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
65instance Tupleable Test1T
67data TestUnnamed1 = TestUnnamed1 Int Double T.Text
68 deriving (Show,Eq, Generic)
70instance Tupleable TestUnnamed1
72data Test7A = Test7AC Integer
73 deriving (Generic, Show, Eq, Atomable, NFData, Binary)
76data Test7T = Test7C Test7A
77 deriving (Generic, Show, Eq)
79instance Tupleable Test7T
80-}
82-- | 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.
83toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr
84toInsertExpr vals rvName = do
85 let attrs = toAttributes (Proxy :: Proxy a)
86 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
87 let rel = MakeStaticRelation attrs tuples
88 pure (Insert rvName rel)
90-- | 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'.
91toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr
92toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
93 where
94 attrs = toAttributes (Proxy :: Proxy a)
96tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr
97tupleAssocsEqualityPredicate [] = TruePredicate
98tupleAssocsEqualityPredicate pairs =
99 foldr1 AndPredicate $
100 map
101 (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom))
102 pairs
104partitionByAttributes ::
105 Tupleable a
106 => [AttributeName]
107 -> a
108 -> ([(AttributeName, Atom)], [(AttributeName, Atom)])
109partitionByAttributes attrs =
110 partition ((`elem` attrs) . fst) . tupleAssocs . toTuple
112-- | Convert a list of key attributes and a 'Tupleable' value to an 'Update'
113-- expression. This expression flushes the non-key attributes of the value to
114-- a tuple with the matching key attributes.
115toUpdateExpr ::
116 forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
117toUpdateExpr rvName keyAttrs a = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Update rvName updateMap keyRestriction)
118 where
119 (keyPairs, updatePairs) = partitionByAttributes keyAttrs a
120 updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs
121 keyRestriction = tupleAssocsEqualityPredicate keyPairs
122 expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
124-- | Convert a list of key attributes and a 'Tupleable' value to a 'Delete'
125-- expression. This expression deletes tuples matching the key attributes from
126-- the value.
127toDeleteExpr ::
128 forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr
129toDeleteExpr rvName keyAttrs val = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Delete rvName keyRestriction)
130 where
131 keyPairs = fst $ partitionByAttributes keyAttrs val
132 keyRestriction = tupleAssocsEqualityPredicate keyPairs
133 expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a))
135validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a
136validateAttributes actualAttrs expectedAttrs val
137 | S.null actualAttrs = Left EmptyAttributesError
138 | not (S.null nonMatchingAttrs) = Left (NoSuchAttributeNamesError nonMatchingAttrs)
139 | otherwise = Right val
140 where
141 nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs
143-- | Types that can be converted to and from 'RelationTuple'.
144--
145-- deriving without customization:
146--
147-- > data Example = Example
148-- > { foo :: Integer
149-- > , bar :: Text
150-- > }
151-- > deriving (Generic)
152-- >
153-- > instance Tupleable Example
154--
155-- deriving with customization using "ProjectM36.Tupleable.Deriving":
156--
157-- > data Example = Example
158-- > { exampleFoo :: Integer
159-- > , exampleBar :: Text
160-- > }
161-- > deriving stock (Generic)
162-- > deriving (Tupleable)
163-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example
164class Tupleable a where
165 toTuple :: a -> RelationTuple
167 fromTuple :: RelationTuple -> Either RelationalError a
169 toAttributes :: Proxy a -> Attributes
171 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
172 toTuple = genericToTuple defaultTupleableOptions
174 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
175 fromTuple = genericFromTuple defaultTupleableOptions
177 default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes
178 toAttributes = genericToAttributes defaultTupleableOptions
180-- | Options that influence deriving behavior.
181newtype TupleableOptions = TupleableOptions {
182 -- | A function that translates record field names into attribute names.
183 fieldModifier :: T.Text -> T.Text
184 }
186-- | The default options for deriving Tupleable instances.
187--
188-- These options can be customized by using record update syntax. For example,
189--
190-- > defaultTupleableOptions
191-- > { fieldModifier = \fieldName ->
192-- > case Data.Text.stripPrefix "example" fieldName of
193-- > Nothing -> fieldName
194-- > Just attributeName -> attributeName
195-- > }
196--
197-- will result in record field names being translated into attribute names by
198-- removing the prefix "example" from the field names.
199defaultTupleableOptions :: TupleableOptions
200defaultTupleableOptions = TupleableOptions {
201 fieldModifier = id
202 }
204genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple
205genericToTuple opts v = toTupleG opts (from v)
207genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a
208genericFromTuple opts tup = to <$> fromTupleG opts tup
210genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes
211genericToAttributes opts _ = toAttributesG opts (from (undefined :: a))
213class TupleableG g where
214 toTupleG :: TupleableOptions -> g a -> RelationTuple
215 toAttributesG :: TupleableOptions -> g a -> Attributes
216 fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (g a)
217 isRecordTypeG :: g a -> Bool
219--data type metadata
220instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
221 toTupleG opts (M1 v) = toTupleG opts v
222 toAttributesG opts (M1 v) = toAttributesG opts v
223 fromTupleG opts v = M1 <$> fromTupleG opts v
224 isRecordTypeG (M1 v) = isRecordTypeG v
226--constructor metadata
227instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
228 toTupleG opts (M1 v) = RelationTuple attrs atoms
229 where
230 attrsToCheck = toAttributesG opts v
231 counter = V.generate (V.length attrsToCheck) id
232 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
233 Attribute ("attr" <> T.pack (show (num + 1))) typ
234 else
235 attr) counter attrsToCheck
236 atoms = V.fromList (toAtomsG v)
237 toAttributesG opts (M1 v) = toAttributesG opts v
238 fromTupleG opts tup = M1 <$> fromTupleG opts tup
239 isRecordTypeG (M1 v) = isRecordTypeG v
241-- product types
242instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
243 toTupleG = error "toTupleG"
244 toAttributesG opts ~(x :*: y) = toAttributesG opts x V.++ toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception
245 fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple
246 where
247 processedTuple = if isRecordTypeG (undefined :: a x) then
248 tup
249 else
250 trimTuple 1 tup
251 isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y
253--selector/record
254instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
255 toTupleG = error "toTupleG"
256 toAttributesG opts m@(M1 v) = V.singleton (Attribute modifiedName aType)
257 where
258 name = T.pack (selName m)
259 modifiedName = if T.null name then
260 name
261 else
262 fieldModifier opts name
263 aType = toAtomTypeG v
264 fromTupleG opts tup = if null name then -- non-record type, just pull off the first tuple item
265 M1 <$> atomv (V.head (tupleAtoms tup))
266 else do
267 atom <- atomForAttributeName (fieldModifier opts (T.pack name)) tup
268 val <- atomv atom
269 pure (M1 val)
270 where
271 expectedAtomType = atomType (V.head (toAttributesG opts (undefined :: M1 S c a x)))
272 atomv atom = maybe (Left (AtomTypeMismatchError
273 expectedAtomType
274 (atomTypeForAtom atom)
275 )) Right (fromAtomG atom [atom])
276 name = selName (undefined :: M1 S c a x)
277 isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x)))
279--constructors with no arguments
280--basically useless but orthoganal to relationTrue
281instance TupleableG U1 where
282 toTupleG _ _ = emptyTuple
283 toAttributesG _ _ = emptyAttributes
284 fromTupleG _ _ = pure U1
285 isRecordTypeG _ = False