git.iko.soy/project-m36
on master help sign in
increase laziness in pattern matching of product types in Atomable generics
fc8ceccAgentM
src/lib/ProjectM36/Atomable.hs+28−28
compare with master
unifiedsplit
@@ -56,7 +56,7 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where
56 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.
56 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.
57 toAddTypeExpr :: proxy a -> DatabaseContextExpr
57 toAddTypeExpr :: proxy a -> DatabaseContextExpr
58 default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr
58 default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr
59− toAddTypeExpr _ = toAddTypeExprG (from (undefined :: a)) (toAtomType (Proxy :: Proxy a))
59+ toAddTypeExpr _ = toAddTypeExprG (from (error "insufficient laziness" :: a)) (toAtomType (Proxy :: Proxy a))
60
60
61instance Atomable Integer where
61instance Atomable Integer where
62 toAtom = IntegerAtom
62 toAtom = IntegerAtom
@@ -184,17 +184,17 @@ class AtomableG g where
184instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where
184instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where
185 toAtomG (M1 v) = toAtomG v
185 toAtomG (M1 v) = toAtomG v
186 fromAtomG atom args = M1 <$> fromAtomG atom args
186 fromAtomG atom args = M1 <$> fromAtomG atom args
187− toAtomsG = undefined
187+ toAtomsG = error "invalid toAtomsG in M1 D"
188 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?
188 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?
189 where
189 where
190 typeName = datatypeName (undefined :: M1 D c a x)
190 typeName = datatypeName (undefined :: M1 D c a x)
191− toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors
191+ toAddTypeExprG ~(M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors
192 where
192 where
193 tcDef = ADTypeConstructorDef tcName []
193 tcDef = ADTypeConstructorDef tcName []
194 dataConstructors = getConstructorsG v
194 dataConstructors = getConstructorsG v
195 toAddTypeExprG _ _ = NoOperation
195 toAddTypeExprG _ _ = NoOperation
196− getConstructorsG (M1 v) = getConstructorsG v
196+ getConstructorsG ~(M1 v) = getConstructorsG v
197− getConstructorArgsG = undefined
197+ getConstructorArgsG = error "invalid getConstructorArgsG in M1 D"
198
198
199--constructor metadata
199--constructor metadata
200instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
200instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
@@ -209,11 +209,11 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
209 Nothing
209 Nothing
210 where
210 where
211 dName = T.pack (conName (undefined :: M1 C c a x))
211 dName = T.pack (conName (undefined :: M1 C c a x))
212− fromAtomG _ _ = error "unsupported generic traversal"
212+ fromAtomG _ _ = error "invalid fromAtomG in M1 C"
213− toAtomsG = undefined
213+ toAtomsG = error "invalid toAtomsG in M1 C"
214− toAtomTypeG = undefined
214+ toAtomTypeG = error "invalid toAtomTypeG in M1 C"
215− toAddTypeExprG = undefined
215+ toAddTypeExprG = error "invalid toAddTypeExprG in M1 C"
216− getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]
216+ getConstructorsG ~(M1 v) = [DataConstructorDef (T.pack dName) dArgs]
217 where
217 where
218 dName = conName (undefined :: M1 C c a x)
218 dName = conName (undefined :: M1 C c a x)
219 dArgs = getConstructorArgsG v
219 dArgs = getConstructorArgsG v
@@ -225,9 +225,9 @@ instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
225 fromAtomG atom args = M1 <$> fromAtomG atom args
225 fromAtomG atom args = M1 <$> fromAtomG atom args
226 toAtomsG (M1 v) = toAtomsG v
226 toAtomsG (M1 v) = toAtomsG v
227 toAtomTypeG (M1 v) = toAtomTypeG v
227 toAtomTypeG (M1 v) = toAtomTypeG v
228− toAddTypeExprG _ _ = undefined
228+ toAddTypeExprG = error "invalid toAddTypeExprG in M1 S"
229− getConstructorsG = undefined
229+ getConstructorsG = error "invalid getConstructorsG in M1 S"
230− getConstructorArgsG (M1 v) = getConstructorArgsG v
230+ getConstructorArgsG ~(M1 v) = getConstructorArgsG v
231
231
232-- field data metadata
232-- field data metadata
233instance (Atomable a) => AtomableG (K1 c a) where
233instance (Atomable a) => AtomableG (K1 c a) where
@@ -237,9 +237,9 @@ instance (Atomable a) => AtomableG (K1 c a) where
237 headatom [] = error "no more atoms for constructor!"
237 headatom [] = error "no more atoms for constructor!"
238 toAtomsG (K1 v) = [toAtom v]
238 toAtomsG (K1 v) = [toAtom v]
239 toAtomTypeG _ = toAtomType (Proxy :: Proxy a)
239 toAtomTypeG _ = toAtomType (Proxy :: Proxy a)
240− toAddTypeExprG _ _ = undefined
240+ toAddTypeExprG = error "invalid toAddTypeExprG in K1"
241− getConstructorsG = undefined
241+ getConstructorsG = error "invalid getConstructorsG in K1"
242− getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]
242+ getConstructorArgsG ~(K1 _) = [DataConstructorDefTypeConstructorArg tCons]
243 where
243 where
244 tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a)
244 tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a)
245
245
@@ -261,39 +261,39 @@ typeToTypeConstructor (ConstructedAtomType tcName tvMap)
261typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName
261typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName
262
262
263instance AtomableG U1 where
263instance AtomableG U1 where
264− toAtomG = undefined
264+ toAtomG = error "invalid toAtomG in U1"
265 fromAtomG _ _ = pure U1
265 fromAtomG _ _ = pure U1
266 toAtomsG _ = []
266 toAtomsG _ = []
267− toAtomTypeG = undefined
267+ toAtomTypeG = error "invalid toAtomTypeG in U1"
268− toAddTypeExprG = undefined
268+ toAddTypeExprG = error "invalid toAddTypeExprG in U1"
269− getConstructorsG = undefined
269+ getConstructorsG = error "invalid getConstructorsG in U1"
270 getConstructorArgsG _ = []
270 getConstructorArgsG _ = []
271
271
272-- product types
272-- product types
273instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
273instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
274− toAtomG = undefined
274+ toAtomG = error "invalid toAtomG in :*:"
275 fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args)
275 fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args)
276 where headatom (x:_) = x
276 where headatom (x:_) = x
277 headatom [] = error "no more atoms in head for product!"
277 headatom [] = error "no more atoms in head for product!"
278 tailatoms (_:xs) = xs
278 tailatoms (_:xs) = xs
279 tailatoms [] = error "no more atoms in tail for product!"
279 tailatoms [] = error "no more atoms in tail for product!"
280− toAtomTypeG = undefined
280+ toAtomTypeG = error "invalid toAtomTypeG in :*:"
281 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y
281 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y
282− toAddTypeExprG _ _ = undefined
282+ toAddTypeExprG = error "invalid toAddTypeExprG in :*:"
283− getConstructorsG = undefined
283+ getConstructorsG = error "invalid getConstructorsG in :*:"
284− getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y
284+ getConstructorArgsG ~(x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y
285
285
286-- sum types
286-- sum types
287instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
287instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
288 toAtomG (L1 x) = toAtomG x
288 toAtomG (L1 x) = toAtomG x
289 toAtomG (R1 x) = toAtomG x
289 toAtomG (R1 x) = toAtomG x
290 fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args)
290 fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args)
291− toAtomTypeG = undefined
291+ toAtomTypeG = error "invalid toAtomTypeG in :+:"
292 toAtomsG (L1 x) = toAtomsG x
292 toAtomsG (L1 x) = toAtomsG x
293 toAtomsG (R1 x) = toAtomsG x
293 toAtomsG (R1 x) = toAtomsG x
294− toAddTypeExprG _ _ = undefined
294+ toAddTypeExprG = error "invalid toAddTypeExprG in :+:"
295 getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)
295 getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)
296− getConstructorArgsG = undefined
296+ getConstructorArgsG = error "invalid getConstructorArgsG in :+:"
297
297
298--this represents the unimplemented generics traversals which should never be called
298--this represents the unimplemented generics traversals which should never be called
299{-
299{-
test/Relation/Atomable.hs+16−2
@@ -47,6 +47,11 @@ data Test7T = Test7C (Either Integer Integer)
47
47
48data Test8T = Test8C Test1T
48data Test8T = Test8C Test1T
49 deriving (Show, Generic, Eq, Binary, NFData, Atomable)
49 deriving (Show, Generic, Eq, Binary, NFData, Atomable)
50+
51+data User = User
52+ { userFirstName :: Text
53+ , userLastName :: Text
54+ } deriving (Eq, Ord, Show, Generic, NFData, Binary, Atomable)
50
55
51main :: IO ()
56main :: IO ()
52main = do
57main = do
@@ -54,8 +59,7 @@ main = do
54 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
59 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
55
60
56testList :: Test
61testList :: Test
57−testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues]
62+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testRecordType]
58−
59
63
60-- test some basic data types like int, day, etc.
64-- test some basic data types like int, day, etc.
61testBasicMarshaling :: Test
65testBasicMarshaling :: Test
@@ -149,3 +153,13 @@ testNonPrimitiveValues :: Test
149testNonPrimitiveValues = TestCase $ do
153testNonPrimitiveValues = TestCase $ do
150 let example = Test8C (Test1C 3)
154 let example = Test8C (Test1C 3)
151 assertEqual "non-primitive values" example (fromAtom (toAtom example))
155 assertEqual "non-primitive values" example (fromAtom (toAtom example))
156+
157+testRecordType :: Test
158+testRecordType = TestCase $ do
159+ let example = User { userFirstName = "Bob"
160+ ,userLastName = "Smith"
161+ }
162+ assertEqual "User record" example (fromAtom (toAtom example))
163+ let expected = AddTypeConstructor (ADTypeConstructorDef "User" []) [DataConstructorDef "User" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType),DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType)]]
164+
165+ assertEqual "User record to database context expr" expected (toAddTypeExpr (Proxy :: Proxy User))