git.iko.soy/project-m36
on master help sign in
add round-trip marshaling to OutOfTheTarpit example
63affe5AgentM
examples/out_of_the_tarpit.hs+10−1
compare with master
unifiedsplit
@@ -3,6 +3,7 @@
3import ProjectM36.Client
3import ProjectM36.Client
4import ProjectM36.DataTypes.Primitive
4import ProjectM36.DataTypes.Primitive
5import ProjectM36.Tupleable
5import ProjectM36.Tupleable
6+import ProjectM36.Relation
6import ProjectM36.Error
7import ProjectM36.Error
7import Data.Either
8import Data.Either
8import GHC.Generics
9import GHC.Generics
@@ -53,7 +54,7 @@ data Property = Property {
53 photo :: T.Text,
54 photo :: T.Text,
54 dateRegistered :: Day
55 dateRegistered :: Day
55 }
56 }
56− deriving (Generic, Eq)
57+ deriving (Generic, Eq, Show)
57
58
58instance Tupleable Property
59instance Tupleable Property
59
60
@@ -168,6 +169,7 @@ createSchema sessionId conn = do
168 putStrLn "load atom functions"
169 putStrLn "load atom functions"
169 _ <- handleIOErrors $ mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
170 _ <- handleIOErrors $ mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
170
171
172+ --insert a bunch of records
171 putStrLn "load data"
173 putStrLn "load data"
172 let properties = [Property { address = "123 Main St.",
174 let properties = [Property { address = "123 Main St.",
173 price = 200000,
175 price = 200000,
@@ -227,6 +229,13 @@ createSchema sessionId conn = do
227 commission = 10000 }]
229 commission = 10000 }]
228 insertCommissionsExpr <- handleError $ toInsertExpr commissions "commission"
230 insertCommissionsExpr <- handleError $ toInsertExpr commissions "commission"
229 handleIOError $ executeDatabaseContextExpr sessionId conn insertCommissionsExpr
231 handleIOError $ executeDatabaseContextExpr sessionId conn insertCommissionsExpr
232+
233+ --query some records, marshal them back to Haskell
234+
235+ properties' <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "property" ())
236+
237+ props <- toList properties' >>= mapM (handleError . fromTuple) :: IO [Property]
238+ print props
230
239
231handleError :: Either RelationalError a -> IO a
240handleError :: Either RelationalError a -> IO a
232handleError eErr = case eErr of
241handleError eErr = case eErr of
src/lib/ProjectM36/Relation.hs+7
@@ -253,6 +253,13 @@ relMogrify mapper newAttributes (Relation _ tupSet) = do
253relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
253relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
254relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)
254relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)
255
255
256+-- | Generate a randomly-ordered list of tuples from the relation.
257+toList :: Relation -> IO [RelationTuple]
258+toList rel = do
259+ gen <- newStdGen
260+ let rel' = evalRand (randomizeTupleOrder rel) gen
261+ pure (relFold (\tup l -> tup : l) [] rel')
262+
256--image relation as defined by CJ Date
263--image relation as defined by CJ Date
257--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value
264--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value
258
265
src/lib/ProjectM36/Tupleable.hs+20−15
@@ -1,17 +1,18 @@
1{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-}
1{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-}
2+{-# LANGUAGE DeriveGeneric #-}
2module ProjectM36.Tupleable where
3module ProjectM36.Tupleable where
3import ProjectM36.Base
4import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Error
5import ProjectM36.Tuple
6import ProjectM36.Tuple
6import ProjectM36.TupleSet
7import ProjectM36.TupleSet
7import ProjectM36.Atomable
8import ProjectM36.Atomable
9+import ProjectM36.DataTypes.Primitive
8import ProjectM36.Attribute hiding (null)
10import ProjectM36.Attribute hiding (null)
9import GHC.Generics
11import GHC.Generics
10import qualified Data.Vector as V
12import qualified Data.Vector as V
11import qualified Data.Text as T
13import qualified Data.Text as T
12import Data.Monoid
14import Data.Monoid
13import Data.Foldable
15import Data.Foldable
14−import Data.Maybe
15
16
16{-
17{-
17data Test1T = Test1C {
18data Test1T = Test1C {
@@ -46,15 +47,15 @@ toInsertExpr vals rvName = do
46class Tupleable a where
47class Tupleable a where
47 toTuple :: a -> RelationTuple
48 toTuple :: a -> RelationTuple
48
49
49− fromTuple :: RelationTuple -> a
50+ fromTuple :: RelationTuple -> Either RelationalError a
50
51
51 toAttributes :: a -> Attributes
52 toAttributes :: a -> Attributes
52
53
53 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
54 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
54 toTuple v = toTupleG (from v)
55 toTuple v = toTupleG (from v)
55
56
56− default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> a
57+ default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
57− fromTuple tup = to (fromTupleG tup)
58+ fromTuple tup = to <$> fromTupleG tup
58
59
59 default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes
60 default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes
60 toAttributes v = toAttributesG (from v)
61 toAttributes v = toAttributesG (from v)
@@ -62,13 +63,13 @@ class Tupleable a where
62class TupleableG g where
63class TupleableG g where
63 toTupleG :: g a -> RelationTuple
64 toTupleG :: g a -> RelationTuple
64 toAttributesG :: g a -> Attributes
65 toAttributesG :: g a -> Attributes
65− fromTupleG :: RelationTuple -> g a
66+ fromTupleG :: RelationTuple -> Either RelationalError (g a)
66
67
67--data type metadata
68--data type metadata
68instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
69instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
69 toTupleG (M1 v) = toTupleG v
70 toTupleG (M1 v) = toTupleG v
70 toAttributesG (M1 v) = toAttributesG v
71 toAttributesG (M1 v) = toAttributesG v
71− fromTupleG v = M1 (fromTupleG v)
72+ fromTupleG v = M1 <$> fromTupleG v
72
73
73--constructor metadata
74--constructor metadata
74instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
75instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
@@ -82,13 +83,13 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe
82 attr) counter attrsToCheck
83 attr) counter attrsToCheck
83 atoms = V.fromList (toAtomsG v)
84 atoms = V.fromList (toAtomsG v)
84 toAttributesG (M1 v) = toAttributesG v
85 toAttributesG (M1 v) = toAttributesG v
85− fromTupleG tup = M1 (fromTupleG tup)
86+ fromTupleG tup = M1 <$> fromTupleG tup
86
87
87-- product types
88-- product types
88instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
89instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
89 toTupleG = error "toTupleG"
90 toTupleG = error "toTupleG"
90 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
91 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
91− fromTupleG tup = fromTupleG tup :*: fromTupleG (trimTuple 1 tup)
92+ fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG (trimTuple 1 tup)
92
93
93--selector/record
94--selector/record
94instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
95instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
@@ -98,13 +99,17 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
98 name = T.pack (selName m)
99 name = T.pack (selName m)
99 aType = toAtomTypeG v
100 aType = toAtomTypeG v
100 fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item
101 fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item
101− M1 (atomv (V.head (tupleAtoms tup)))
102+ M1 <$> atomv (V.head (tupleAtoms tup))
102− else
103+ else do
103− case atomForAttributeName (T.pack name) tup of
104+ atom <- atomForAttributeName (T.pack name) tup
104− Left _ -> error ("no such record name: " ++ name)
105+ val <- atomv atom
105− Right atom -> M1 (atomv atom)
106+ pure (M1 val)
106 where
107 where
108+ expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))
109+ atomv atom = maybe (Left (AtomTypeMismatchError
110+ expectedAtomType
111+ (atomTypeForAtom atom)
107− atomv atom = fromMaybe (error "no such atom conversion") (fromAtomG atom [atom])
112+ )) Right (fromAtomG atom [atom])
108 name = selName (undefined :: M1 S c a x)
113 name = selName (undefined :: M1 S c a x)
109
114
110--constructors with no arguments
115--constructors with no arguments
@@ -112,6 +117,6 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
112instance TupleableG U1 where
117instance TupleableG U1 where
113 toTupleG _= emptyTuple
118 toTupleG _= emptyTuple
114 toAttributesG _ = emptyAttributes
119 toAttributesG _ = emptyAttributes
115− fromTupleG _ = U1
120+ fromTupleG _ = pure U1
116
121
117
122