63affe5 · project-m36 · git.iko.soy

git.iko.soy/project-m36

add round-trip marshaling to OutOfTheTarpit example

adjust type fromTuple :: Either RelationalError a

commit63affe50cc7cc1162a5fcea3b8b7b4869bac0bc3 authorAgentM <agentm@themactionfaction.com> dateThu 24 Aug 2017, 11:39 (9 years ago) parent103bcac

3 files changed+37−16

compare with master

unifiedsplit

examples/out_of_the_tarpit.hs+10−1 src/lib/ProjectM36/Relation.hs+7 src/lib/ProjectM36/Tupleable.hs+20−15

examples/out_of_the_tarpit.hs+10−1

@@ -3,6 +3,7 @@

33import ProjectM36.Client

44import ProjectM36.DataTypes.Primitive

55import ProjectM36.Tupleable

6+import ProjectM36.Relation

67import ProjectM36.Error

78import Data.Either

89import GHC.Generics

@@ -53,7 +54,7 @@ data Property = Property {

5354 photo :: T.Text,

5455 dateRegistered :: Day

5556 }

56− deriving (Generic, Eq)

57+ deriving (Generic, Eq, Show)

5758

5859instance Tupleable Property

5960

@@ -168,6 +169,7 @@ createSchema sessionId conn = do

168169 putStrLn "load atom functions"

169170 _ <- handleIOErrors $ mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs

170171

172+ --insert a bunch of records

171173 putStrLn "load data"

172174 let properties = [Property { address = "123 Main St.",

173175 price = 200000,

@@ -227,6 +229,13 @@ createSchema sessionId conn = do

227229 commission = 10000 }]

228230 insertCommissionsExpr <- handleError $ toInsertExpr commissions "commission"

229231 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

230239

231240handleError :: Either RelationalError a -> IO a

232241handleError eErr = case eErr of

src/lib/ProjectM36/Relation.hs+7

@@ -253,6 +253,13 @@ relMogrify mapper newAttributes (Relation _ tupSet) = do

253253relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

254254relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)

255255

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+

256263--image relation as defined by CJ Date

257264--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

258265

src/lib/ProjectM36/Tupleable.hs+20−15

@@ -1,17 +1,18 @@

11{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-}

2+{-# LANGUAGE DeriveGeneric #-}

23module ProjectM36.Tupleable where

34import ProjectM36.Base

45import ProjectM36.Error

56import ProjectM36.Tuple

67import ProjectM36.TupleSet

78import ProjectM36.Atomable

9+import ProjectM36.DataTypes.Primitive

810import ProjectM36.Attribute hiding (null)

911import GHC.Generics

1012import qualified Data.Vector as V

1113import qualified Data.Text as T

1214import Data.Monoid

1315import Data.Foldable

14−import Data.Maybe

1516

1617{-

1718data Test1T = Test1C {

@@ -46,15 +47,15 @@ toInsertExpr vals rvName = do

4647class Tupleable a where

4748 toTuple :: a -> RelationTuple

4849

49− fromTuple :: RelationTuple -> a

50+ fromTuple :: RelationTuple -> Either RelationalError a

5051

5152 toAttributes :: a -> Attributes

5253

5354 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple

5455 toTuple v = toTupleG (from v)

5556

56− default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> a

57− fromTuple tup = to (fromTupleG tup)

57+ default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a

58+ fromTuple tup = to <$> fromTupleG tup

5859

5960 default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes

6061 toAttributes v = toAttributesG (from v)

@@ -62,13 +63,13 @@ class Tupleable a where

6263class TupleableG g where

6364 toTupleG :: g a -> RelationTuple

6465 toAttributesG :: g a -> Attributes

65− fromTupleG :: RelationTuple -> g a

66+ fromTupleG :: RelationTuple -> Either RelationalError (g a)

6667

6768--data type metadata

6869instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where

6970 toTupleG (M1 v) = toTupleG v

7071 toAttributesG (M1 v) = toAttributesG v

71− fromTupleG v = M1 (fromTupleG v)

72+ fromTupleG v = M1 <$> fromTupleG v

7273

7374--constructor metadata

7475instance (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

8283 attr) counter attrsToCheck

8384 atoms = V.fromList (toAtomsG v)

8485 toAttributesG (M1 v) = toAttributesG v

85− fromTupleG tup = M1 (fromTupleG tup)

86+ fromTupleG tup = M1 <$> fromTupleG tup

8687

8788-- product types

8889instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

8990 toTupleG = error "toTupleG"

9091 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)

9293

9394--selector/record

9495instance (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

9899 name = T.pack (selName m)

99100 aType = toAtomTypeG v

100101 fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item

101− M1 (atomv (V.head (tupleAtoms tup)))

102− else

103− case atomForAttributeName (T.pack name) tup of

104− Left _ -> error ("no such record name: " ++ name)

105− Right atom -> M1 (atomv atom)

102+ M1 <$> atomv (V.head (tupleAtoms tup))

103+ else do

104+ atom <- atomForAttributeName (T.pack name) tup

105+ val <- atomv atom

106+ pure (M1 val)

106107 where

107− atomv atom = fromMaybe (error "no such atom conversion") (fromAtomG atom [atom])

108+ expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))

109+ atomv atom = maybe (Left (AtomTypeMismatchError

110+ expectedAtomType

111+ (atomTypeForAtom atom)

112+ )) Right (fromAtomG atom [atom])

108113 name = selName (undefined :: M1 S c a x)

109114

110115--constructors with no arguments

@@ -112,6 +117,6 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

112117instance TupleableG U1 where

113118 toTupleG _= emptyTuple

114119 toAttributesG _ = emptyAttributes

115− fromTupleG _ = U1

120+ fromTupleG _ = pure U1

116121

117122