bb4f1c6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch 'master' into simple_client

Conflicts: project-m36.cabal src/lib/ProjectM36/Client.hs

commitbb4f1c6b09def2cb04a688b9360a30876beec79e authorAgentM <agentm@themactionfaction.com> dateThu 14 Sep 2017, 17:12 (9 years ago) parent6bb5e92 a7ce5cf

22 files changed+720−169

compare with master

unifiedsplit

.travis.yml+1−1

@@ -53,6 +53,6 @@ script:

5353 - cabal sdist

5454 - cabal new-build -w ${HC} -j1

5555 - cabal new-test -w ${HC}

56− - curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s lint src test examples --cpp-define PROJECTM36_VERSION=HLINT

56+ - curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s lint src test examples --cpp-define VERSION_project_m36=HLINT

5757

5858# EOF

docs/new_datatypes.markdown+5−3

@@ -8,6 +8,8 @@ In addition, the Project:M36 runtime supports algebraic data types in the same v

99Project:M36 makes it easy to add any Haskell data type to the database. Any type which includes instances for a set of typeclasses can be supported.

1010

11+For storing Haskell record types as database tuples, see "[Converting data types to tuples](/docs/tupleable.markdown)."

12+

1113## Support for Runtime Types

1214

1315Use the ```tutd``` interpreter to create new type and data constructors with essentially the same syntax as in Haskell:

@@ -59,7 +61,7 @@ Note that the ```Atomable``` instance can also be derived.

5961After setting up the connection (which we elide here), the database context is loaded with the expression to define the data type.

6062

6163```haskell

62−executeDatabaseContextExpr sessionId conn (toDatabaseContextExpr (undefined :: Hair))

64+executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair))

6365```

6466

6567Using a ```Proxy``` would also be acceptable, but the result would be the same.

@@ -102,8 +104,8 @@ The essential ```Atomable``` typeclass functions are:

102104| ```toAtom :: a -> Atom``` | convert a Haskell data type to a database atom |

103105| ```fromAtom :: Atom -> a``` | convert a database atom to a Haskell data type |

104106| ```toAtomType :: a -> AtomType``` | generate a database AtomType for a Haskell datatype |

105−| ```toDatabaseContextExpr :: a -> DatabaseContextExpr``` | generate a ```DatabaseContextExpr``` which can be executed against a database context in order to add the new type |

107+| ```toAddTypeExpr :: a -> DatabaseContextExpr``` | generate a ```DatabaseContextExpr``` which can be executed against a database context in order to add the new type |

106108

107−In addition, basic Haskell data types like ```Int```, ```Double```, ```Text```, ```Day```, ```Bool```, ```UTCTime```, and ```ByteString``` already have Atomable instances ready-to-go. In addition, an ```Atomable``` instance is available for lists: ```Atomable a => [a]```, though one should be very careful not to use this in a common anti-pattern. Typically, it makes more sense to store one-to-many relationships as discrete relation variables; when storing them as lists, one gives up the various query capabilities and optimizations of the relational algebra.

109+In addition, basic Haskell data types like ```Int```, ```Double```, ```Text```, ```Day```, ```Bool```, ```UTCTime```, and l```ByteString``` already have Atomable instances ready-to-go. In addition, an ```Atomable``` instance is available for lists: ```Atomable a => [a]```, though one should be very careful not to use this in a common anti-pattern. Typically, it makes more sense to store one-to-many relationships as discrete relation variables; when storing them as lists, one gives up the various query capabilities and optimizations of the relational algebra.

108110

109111To be clear, these data types are not black boxes once stored in the database. These new types can be scanned and manipulated by Haskell scripts which can be created at runtime. For more information, read about [```AtomFunction```s](/docs/atomfunctions.markdown).

docs/tupleable.markdownnew file+45

@@ -0,0 +1,45 @@

1+# Marshaling Haskell Data Types to Database Tuples

3+## Introduction

5+Typical ORMs map certain data types to tuples within a relation variable. Because Project:M36 supports Haskell data types natively, any record data type which derives the ```Generic``` typeclass can be marshaled to a database tuple using the ```Tupleable``` typeclass. These marshaled database values can be operated on within the database using Haskell as well.

7+## Setup

9+Let's imagine we have a Haskell record type "Person" which we wish to map to a tuple in a relation variable called "person". Using ```GHC.Generics```, creating this mapping is trivial. Any record fields which are ```Atomable```, including algebraic data types, are supported.

10+

11+```haskell

12+import ProjectM36.Tupleable

13+

14+data Person = Person {

15+ name :: Text,

16+ employeeNumber :: Int,

17+ likesHorses :: Bool

18+}

19+deriving Generic

20+

21+instance Tupleable Person

22+```

23+

24+Now, ```Person``` values can be marshaled between the database and the client. The attribute names appearing in the Haskell data type will appear identically in the server with the same types.

25+

26+## Usage

27+

28+The ```Tupleable``` module includes the following functions:

29+

30+ * ```toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr```

31+ * creates an ```Insert``` expression which can be used to insert a set of ```Tupleable``` values into the relation variable named by the ```RelVarName```

32+ * ```toAttributes :: a -> Attributes```

33+ * generates ```Attributes``` from a ```Tupleable``` value- can be used with ```undefined```, so an actual value is not necessary

34+ * ```toTuple :: a -> RelationTuple```

35+ * converts a ```Tupleable``` value to a tuple for use in queries

36+ * ```fromTuple :: RelationTuple -> Either RelationalError a```

37+ * converts a tuple to ```Tupleable``` value, unless there is an error such as a missing attribute

38+

39+For example usage, see the [Out of the Tarpit example](/examples/out_of_the_tarpit.hs).

40+

41+## Comparison to Other DBMSes

42+

43+The most annoying misfeature of the so-called object-relational model (ORM) is the data type impedance mismatch. This is especially egregious for Haskell clients which must contend with down-sampling the quality of Haskell data structures. For example, most DBMSes don't support algebraic data types, so the ORM can't represent them or it must represent them as binary or JSON blobs in the database which precludes such types from database-level type safety, constraints, and value queries.

44+

45+Project:M36 solves this mismatch by supporting algebraic data types as database-level values, Haskell scripting of database- and value-level server-side functions, and automatic and lossless marshaling of Haskell algebraic data types to values and tuples. Because the mapping between client data types and database-level data types is one-to-one, the mismatch is eliminated- any expression which could be evaluated against the data type on the client side can also be evaluated server-side.

examples/blog.hsnew file+103

@@ -0,0 +1,103 @@

1+-- a simple example of a blog schema

2+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}

4+import ProjectM36.Client

5+import ProjectM36.Relation

6+import ProjectM36.Tupleable

8+import Data.Either

9+import GHC.Generics

10+import Data.Binary

11+import qualified Data.Text as T

12+import Data.Time.Clock

13+import Data.Time.Calendar

14+import Control.DeepSeq

15+

16+--define your data types

17+data Blog = Blog {

18+ title :: T.Text,

19+ stamp :: UTCTime,

20+ category :: Category --note that this type is an algebraic data type

21+ }

22+ deriving (Generic, Show) --derive Generic so that Tupleable can use default instances

23+

24+--instantiate default Tupleable instances

25+instance Tupleable Blog

26+

27+data Comment = Comment {

28+ blogTitle :: T.Text,

29+ commentTime :: UTCTime,

30+ contents :: T.Text

31+ } deriving (Generic, Show)

32+

33+instance Tupleable Comment

34+

35+data Category = Food | Cats | Photos | Other T.Text -- note that this data type could not be represented by an "enumeration" as found in SQL databases

36+ deriving (Atomable, Eq, Show, NFData, Binary, Generic) -- derive Atomable so that values of this type can be stored as a database value

37+

38+-- add some short-hand error handling- your application should have proper handling

39+handleIOError :: Show e => IO (Either e a) -> IO a

40+handleIOError m = do

41+ v <- m

42+ handleError v

43+

44+handleError :: Show e => Either e a -> IO a

45+handleError eErr = case eErr of

46+ Left err -> print err >> error "Died due to errors."

47+ Right v -> pure v

48+

49+handleIOErrors :: Show e => IO [Either e a] -> IO [a]

50+handleIOErrors m = do

51+ eErrs <- m

52+ case lefts eErrs of

53+ [] -> pure (rights eErrs)

54+ err:_ -> handleError (Left err)

55+

56+main :: IO ()

57+main = do

58+ --connect to the database

59+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []

60+ conn <- handleIOError $ connectProjectM36 connInfo

61+

62+ sessionId <- handleIOError $ createSessionAtHead conn "master"

63+

64+ createSchema sessionId conn

65+ insertSampleData sessionId conn

66+ executeSampleQueries sessionId conn

67+

68+--define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them

69+createSchema :: SessionId -> Connection -> IO ()

70+createSchema sessionId conn = do

71+ _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [

72+ toAddTypeExpr (undefined :: Category),

73+ toDefineExpr (undefined :: Blog) "blog",

74+ toDefineExpr (undefined :: Comment) "comment",

75+ databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]) ]

76+ pure ()

77+

78+--create some sample values and insert them into the database's relation variables

79+insertSampleData :: SessionId -> Connection -> IO ()

80+insertSampleData sessionId conn = do

81+ let blogs = [Blog { title = "Eat More Tofu",

82+ stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),

83+ category = Food },

84+ Blog { title = "Cat Falls Off Table",

85+ stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),

86+ category = Cats }

87+ ]

88+ comments = [Comment { blogTitle = "Cat Falls Off Table",

89+ commentTime = UTCTime (fromGregorian 2017 7 8) (secondsToDiffTime 3000),

90+ contents = "more cats please" }]

91+ insertBlogsExpr <- handleError $ toInsertExpr blogs "blog"

92+ handleIOError $ executeDatabaseContextExpr sessionId conn insertBlogsExpr

93+

94+ insertCommentsExpr <- handleError $ toInsertExpr comments "comment"

95+ handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr

96+

97+--issue a query and marshal the data back to the original data value

98+executeSampleQueries :: SessionId -> Connection -> IO ()

99+executeSampleQueries sessionId conn = do

100+ commentsRelation <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "comment" ())

101+

102+ comments <- toList commentsRelation >>= mapM (handleError . fromTuple) :: IO [Comment]

103+ print comments

examples/hair.hs+1−1

@@ -26,7 +26,7 @@ main = do

2626 sessionId <- eCheck $ createSessionAtHead conn "master"

2727

2828 --create the data type in the database context

29− eCheck $ executeDatabaseContextExpr sessionId conn (toDatabaseContextExpr (undefined :: Hair))

29+ eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair))

3030

3131 --create a relation with the new Hair AtomType

3232 let blond = NakedAtomExpr (toAtom Blond)

examples/out_of_the_tarpit.hs+188−79

@@ -2,50 +2,35 @@

22{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}

33import ProjectM36.Client

44import ProjectM36.DataTypes.Primitive

5−import qualified Data.Map as M

5+import ProjectM36.Tupleable

6+import ProjectM36.Relation

7+import ProjectM36.Error

68import Data.Either

7−import Control.Monad

89import GHC.Generics

910import Data.Binary

1011import Control.DeepSeq

12+import qualified Data.Text as T

13+import Data.Time.Calendar

1114

1215--create various database value (atom) types

13−addressAtomType :: AtomType

14−addressAtomType = TextAtomType

16+type Price = Double

1517

16−nameAtomType :: AtomType

17−nameAtomType = TextAtomType

18+type Name = T.Text

1819

19−priceAtomType :: AtomType

20−priceAtomType = DoubleAtomType

20+type Address = T.Text

2121

22−fileNameAtomType :: AtomType

23−fileNameAtomType = TextAtomType

24−

25−data Room = Kitchen | Bathroom | LivingRoom

22+data RoomType = Kitchen | Bathroom | LivingRoom

2623 deriving (Generic, Atomable, Eq, Show, Binary, NFData)

2724

28−roomAtomType :: AtomType

29−roomAtomType = toAtomType (undefined :: Room)

30−

3125data PriceBand = Low | Medium | High | Premium

3226 deriving (Generic, Atomable, Eq, Show, Binary, NFData)

3327

34−priceBandAtomType :: AtomType

35−priceBandAtomType = toAtomType (undefined :: PriceBand)

36−

3728data AreaCode = City | Suburban | Rural

3829 deriving (Generic, Atomable, Eq, Show, Binary, NFData)

3930

40−areaCodeAtomType :: AtomType

41−areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty

42−

4331data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand

4432 deriving (Generic, Atomable, Eq, Show, Binary, NFData)

4533

46−speedBandAtomType :: AtomType

47−speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty

48−

4934main :: IO ()

5035main = do

5136 --connect to the database

@@ -61,77 +46,113 @@ main = do

6146 let sessionId = check eSessionId

6247

6348 createSchema sessionId conn

49+ insertSampleData sessionId conn

6450

51+data Property = Property {

52+ address :: T.Text,

53+ price :: Price,

54+ photo :: T.Text,

55+ dateRegistered :: Day

56+ }

57+ deriving (Generic, Eq, Show)

58+

59+instance Tupleable Property

60+

61+data Offer = Offer {

62+ offerAddress :: Address,

63+ offerPrice :: Price,

64+ offerDate :: Day,

65+ bidderName :: Name,

66+ bidderAddress :: Address,

67+ decisionDate :: Day,

68+ accepted :: Bool

69+ }

70+ deriving (Generic, Eq)

71+

72+instance Tupleable Offer

73+

74+data Decision = Decision {

75+ decAddress :: Address,

76+ decOfferDate :: Day, --the dec prefix is needed until OverloadedRecordFields is available

77+ decBidderName :: Name,

78+ decBidderAddress :: Address,

79+ decDecisionDate :: Day,

80+ decAccepted :: Bool

81+ }

82+ deriving (Generic, Eq)

83+

84+instance Tupleable Decision

85+

86+data Room = Room {

87+ roomAddress :: Address,

88+ roomName :: Name,

89+ width :: Double,

90+ breadth :: Double,

91+ roomType :: RoomType

92+ }

93+ deriving (Generic, Eq)

94+

95+instance Tupleable Room

96+

97+data Floor = Floor {

98+ floorAddress :: Address,

99+ floorRoomName :: Name,

100+ floorNum :: Int

101+ }

102+ deriving (Generic, Eq)

103+

104+instance Tupleable Floor

105+

106+data Commission = Commission {

107+ priceBand :: PriceBand,

108+ areaCode :: AreaCode,

109+ saleSpeed :: SpeedBand,

110+ commission :: Price

111+ } deriving (Generic, Eq)

112+

113+instance Tupleable Commission

114+

65115createSchema :: SessionId -> Connection -> IO ()

66116createSchema sessionId conn = do

67117 --create attributes for relvars

68− let propertyAttrs = [Attribute "address" addressAtomType,

69− Attribute "price" priceAtomType,

70− Attribute "photo" fileNameAtomType,

71− Attribute "dateRegistered" DayAtomType]

72− offerAttrs = [Attribute "address" addressAtomType,

73− Attribute "offerPrice" priceAtomType,

74− Attribute "offerDate" DayAtomType,

75− Attribute "bidderName" nameAtomType,

76− Attribute "bidderAddress" addressAtomType,

77− Attribute "decisionDate" DayAtomType,

78− Attribute "accepted" BoolAtomType]

79− decisionAttrs = [Attribute "address" addressAtomType,

80− Attribute "offerDate" DayAtomType,

81− Attribute "bidderName" nameAtomType,

82− Attribute "bidderAddress" addressAtomType,

83− Attribute "decisionDate" DayAtomType,

84− Attribute "accepted" BoolAtomType]

85− roomAttrs = [Attribute "address" addressAtomType,

86− Attribute "roomName" TextAtomType,

87− Attribute "width" DoubleAtomType,

88− Attribute "breadth" DoubleAtomType,

89− Attribute "type" roomAtomType]

90− floorAttrs = [Attribute "address" addressAtomType,

91− Attribute "roomName" TextAtomType,

92− Attribute "floor" IntAtomType]

93− commissionAttrs = [Attribute "priceBand" priceBandAtomType,

94− Attribute "areaCode" areaCodeAtomType,

95− Attribute "saleSpeed" speedBandAtomType,

96− Attribute "commission" DoubleAtomType]

118+ let

97119 --create uniqueness constraints

98120 incDepKeys = map (uncurry databaseContextExprForUniqueKey)

99121 [("property", ["address"]),

100− ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]),

101− ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),

102− ("room", ["address", "roomName"]),

103− ("floor", ["address", "roomName"]),

122+ ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"]),

123+ ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]),

124+ ("room", ["roomAddress", "roomName"]),

125+ ("floor", ["floorAddress", "floorRoomName"]),

104126 --"commision" misspelled in OotT

105127 ("commission", ["priceBand", "areaCode", "saleSpeed"])

106128 ]

107129 --create foreign key constraints

108130 foreignKeys = [("offer_property_fk",

109− ("offer", ["address"]),

131+ ("offer", ["offerAddress"]),

110132 ("property", ["address"])),

111133 ("decision_offer_fk",

112− ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),

113− ("offer", ["address", "offerDate", "bidderName", "bidderAddress"])),

134+ ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]),

135+ ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"])),

114136 ("room_property_fk",

115− ("room", ["address"]),

137+ ("room", ["roomAddress"]),

116138 ("property", ["address"])),

117139 ("floor_property_fk",

118− ("floor", ["address"]),

140+ ("floor", ["floorAddress"]),

119141 ("property", ["address"]))

120142 ]

121143 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys

122144 --define the relvars

123− relvarMap = [("property", propertyAttrs),

124− ("offer", offerAttrs),

125− ("decision", decisionAttrs),

126− ("room", roomAttrs),

127− ("floor", floorAttrs),

128− ("commission", commissionAttrs)]

129− rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap

145+ rvExprs = [toDefineExpr (undefined :: Property) "property",

146+ toDefineExpr (undefined :: Offer) "offer",

147+ toDefineExpr (undefined :: Decision) "decision",

148+ toDefineExpr (undefined :: Room) "room",

149+ toDefineExpr (undefined :: Floor) "floor",

150+ toDefineExpr (undefined :: Commission) "commission"]

130151 --create the new algebraic data types

131− new_adts = [toDatabaseContextExpr (undefined :: Room),

132− toDatabaseContextExpr (undefined :: PriceBand),

133− toDatabaseContextExpr (undefined :: AreaCode),

134− toDatabaseContextExpr (undefined :: SpeedBand)]

152+ new_adts = [toAddTypeExpr (undefined :: RoomType),

153+ toAddTypeExpr (undefined :: PriceBand),

154+ toAddTypeExpr (undefined :: AreaCode),

155+ toAddTypeExpr (undefined :: SpeedBand)]

135156 --create the stored atom functions

136157 priceBandScript = "(\\(DoubleAtom price:_) -> do\n let band = if price < 10000.0 then \"Low\" else if price < 20000.0 then \"Medium\" else if price < 30000.0 then \"High\" else \"Premium\"\n let aType = ConstructedAtomType \"PriceBand\" empty\n pure (ConstructedAtom band aType [])) :: [Atom] -> Either AtomFunctionError Atom"

137158 areaCodeScript = "(\\(TextAtom address:_) -> let aType = ConstructedAtomType \"AreaCode\" empty in if address == \"90210\" then pure (ConstructedAtom \"City\" aType []) else pure (ConstructedAtom \"Rural\" aType [])) :: [Atom] -> Either AtomFunctionError Atom"

@@ -141,10 +162,98 @@ createSchema sessionId conn = do

141162 createScriptedAtomFunction "datesToSpeedBand" [dayTypeConstructor, dayTypeConstructor] (ADTypeConstructor "SpeedBand" []) speedBandScript

142163 ]

143164 --gather up and execute all database updates

144− eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)

145− let errs = lefts eErrs

146− unless (null errs) (error (show errs))

165+ putStrLn "load relvars"

166+ _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvExprs ++ incDepKeys ++ incDepForeignKeys)

167+

168+ putStrLn "load atom functions"

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

170+ pure ()

171+

172+insertSampleData :: SessionId -> Connection -> IO ()

173+insertSampleData sessionId conn = do

174+ --insert a bunch of records

175+ putStrLn "load data"

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

177+ price = 200000,

178+ photo = "123_main.jpg",

179+ dateRegistered = fromGregorian 2016 4 3},

180+ Property { address = "456 Main St.",

181+ price = 150000,

182+ photo = "456_main.jpg",

183+ dateRegistered = fromGregorian 2016 5 6}]

184+ insertPropertiesExpr <- handleError $ toInsertExpr properties "property"

185+ handleIOError $ executeDatabaseContextExpr sessionId conn insertPropertiesExpr

186+

187+ let offers = [Offer { offerAddress = "123 Main St.",

188+ offerPrice = 180000,

189+ offerDate = fromGregorian 2017 1 2,

190+ bidderName = "Steve",

191+ bidderAddress = "789 Main St.",

192+ decisionDate = fromGregorian 2017 2 2,

193+ accepted = False }]

147194

148− eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs

149− let errs' = lefts eErrs'

150− unless (null errs') (error (show errs'))

195+ insertOffersExpr <- handleError $ toInsertExpr offers "offer"

196+ handleIOError $ executeDatabaseContextExpr sessionId conn insertOffersExpr

197+

198+ let rooms = [Room { roomAddress = "123 Main St.",

199+ roomName = "Fabulous Kitchen",

200+ width = 10,

201+ breadth = 10,

202+ roomType = Kitchen },

203+ Room { roomAddress = "123 Main St.",

204+ roomName = "Clean Bathroom",

205+ width = 7,

206+ breadth = 5,

207+ roomType = Bathroom }]

208+

209+ insertRoomsExpr <- handleError $ toInsertExpr rooms "room"

210+ handleIOError $ executeDatabaseContextExpr sessionId conn insertRoomsExpr

211+

212+ let decisions = [Decision { decAddress = "123 Main St.",

213+ decOfferDate = fromGregorian 2017 1 2,

214+ decBidderName = "Steve",

215+ decBidderAddress = "789 Main St.",

216+ decDecisionDate = fromGregorian 2017 05 04,

217+ decAccepted = False }]

218+ insertDecisionsExpr <- handleError $ toInsertExpr decisions "decision"

219+ handleIOError $ executeDatabaseContextExpr sessionId conn insertDecisionsExpr

220+

221+ let floors = [Floor { floorAddress = "123 Main St.",

222+ floorRoomName = "Bathroom",

223+ floorNum = 1

224+ }]

225+ insertFloorsExpr <- handleError $ toInsertExpr floors "floor"

226+ handleIOError $ executeDatabaseContextExpr sessionId conn insertFloorsExpr

227+

228+ let commissions = [Commission { priceBand = Medium,

229+ areaCode = City,

230+ saleSpeed = MediumBand,

231+ commission = 10000 }]

232+ insertCommissionsExpr <- handleError $ toInsertExpr commissions "commission"

233+ handleIOError $ executeDatabaseContextExpr sessionId conn insertCommissionsExpr

234+

235+ --query some records, marshal them back to Haskell

236+

237+ properties' <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "property" ())

238+

239+ props <- toList properties' >>= mapM (handleError . fromTuple) :: IO [Property]

240+ print props

241+

242+handleError :: Either RelationalError a -> IO a

243+handleError eErr = case eErr of

244+ Left err -> print err >> error "Died due to errors."

245+ Right v -> pure v

246+

247+handleIOError :: IO (Either RelationalError a) -> IO a

248+handleIOError m = do

249+ e <- m

250+ handleError e

251+

252+handleIOErrors :: IO [Either RelationalError a] -> IO [a]

253+handleIOErrors m = do

254+ eErrs <- m

255+ case lefts eErrs of

256+ [] -> pure (rights eErrs)

257+ errs -> handleError (Left (someErrors errs))

258+

259+

project-m36.cabal+30−27

@@ -1,5 +1,5 @@

11Name: project-m36

2−Version: 0.1

2+Version: 0.2

33License: PublicDomain

44Build-Type: Simple

55Homepage: https://github.com/agentm/project-m36

@@ -34,7 +34,7 @@ Library

3434 ,directory

3535 ,MonadRandom

3636 ,random-shuffle

37− --critical uuid bug in lesser versions https://www.reddit.com/r/haskell/comments/4myot5/psa_make_sure_to_use_uuid_1312/

37+ --critical uuid bug in lesser versions https://www.reddit.com/r/haskell/comments/4myot5/psa_make_sure_to_use_uuid_1312/

3838 ,uuid >= 1.3.12

3939 ,cassava >= 0.4.5.1 && < 0.6

4040 ,text

@@ -61,7 +61,8 @@ Library

6161 ,data-interval

6262 ,extended-reals

6363 ,network-transport

64− ,aeson

64+ -- aeson 1.1 and above includes instances for UUID types

65+ ,aeson >= 1.1

6566 ,path-pieces

6667 ,conduit

6768 ,resourcet

@@ -120,6 +121,7 @@ Library

120121 ProjectM36.AtomFunctions.Basic,

121122 ProjectM36.AtomFunctions.Primitive,

122123 ProjectM36.Atomable,

124+ ProjectM36.Tupleable,

123125 ProjectM36.DataConstructorDef,

124126 ProjectM36.DataTypes.Basic,

125127 ProjectM36.DataTypes.Day,

@@ -189,7 +191,7 @@ Executable tutd

189191 directory,

190192 filepath,

191193 temporary,

192− megaparsec >= 5.2.0 && < 5.3,

194+ megaparsec >= 5.2.0 && < 5.4,

193195 haskeline,

194196 random, MonadRandom,

195197 base64-bytestring,

@@ -216,7 +218,6 @@ Executable tutd

216218 TutorialD.Interpreter.TransGraphRelationalOperator,

217219 TutorialD.Interpreter.SchemaOperator

218220 main-is: TutorialD/tutd.hs

219− CPP-Options: -DPROJECTM36_VERSION="v0.1"

220221 CC-Options: -fPIC

221222 GHC-Options: -Wall

222223 Hs-Source-Dirs: ./src/bin

@@ -262,7 +263,6 @@ Executable project-m36-server

262263 list-t,

263264 base64-bytestring

264265 Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs

265− CPP-Options: -DPROJECTM36_VERSION="v0.1"

266266 GHC-Options: -Wall -threaded -rtsopts

267267 if flag(profiler)

268268 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

@@ -279,7 +279,6 @@ Executable bigrel

279279 TutorialD.Interpreter.Types

280280 main-is: benchmark/bigrel.hs

281281 GHC-Options: -Wall -threaded -rtsopts

282− CPP-Options: -DPROJECTM36_VERSION="v0.1"

283282 HS-Source-Dirs: ./src/bin

284283 if flag(profiler)

285284 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

@@ -293,7 +292,6 @@ Test-Suite test-tutoriald

293292 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

294293 GHC-Options: -Wall

295294 Hs-Source-Dirs: ./src/bin, ., test

296− CPP-Options: -DPROJECTM36_VERSION="v0.1"

297295

298296Test-Suite test-tutoriald-atomfunctionscript

299297 Default-Language: Haskell2010

@@ -304,7 +302,6 @@ Test-Suite test-tutoriald-atomfunctionscript

304302 Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time

305303 GHC-Options: -Wall

306304 Hs-Source-Dirs: ./src/bin, ./test, .

307− CPP-Options: -DPROJECTM36_VERSION="v0.1"

308305

309306Test-Suite test-tutoriald-databasecontextfunctionscript

310307 Default-Language: Haskell2010

@@ -315,7 +312,6 @@ Test-Suite test-tutoriald-databasecontextfunctionscript

315312 Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time

316313 GHC-Options: -Wall

317314 Hs-Source-Dirs: ./src/bin, ./test, .

318− CPP-Options: -DPROJECTM36_VERSION="v0.1"

319315

320316Test-Suite test-relation

321317 Default-Language: Haskell2010

@@ -332,7 +328,6 @@ Test-Suite test-static-optimizer

332328 main-is: test/Relation/StaticOptimizer.hs

333329 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, transformers

334330 GHC-Options: -Wall

335− CPP-Options: -DPROJECTM36_VERSION="v0.1"

336331

337332Test-Suite test-transactiongraph-persist

338333 Default-Language: Haskell2010

@@ -351,7 +346,6 @@ Test-Suite test-relation-import-csv

351346 main-is: test/Relation/Import/CSV.hs

352347 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36

353348 GHC-Options: -Wall

354− CPP-Options: -DPROJECTM36_VERSION="v0.1"

355349

356350Test-Suite test-tutoriald-import-tutoriald

357351 Default-Language: Haskell2010

@@ -410,7 +404,14 @@ Executable Example-OutOfTheTarpit

410404 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36

411405 Main-Is: examples/out_of_the_tarpit.hs

412406 GHC-Options: -Wall

413− CPP-Options: -DPROJECTM36_VERSION="v0.1"

407+

408+Executable Example-Blog

409+ Default-Language: Haskell2010

410+ Default-Extensions: OverloadedStrings

411+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36

412+ Main-Is: examples/blog.hs

413+ GHC-Options: -Wall

414+

414415

415416Executable Example-Hair

416417 Default-Language: Haskell2010

@@ -418,7 +419,6 @@ Executable Example-Hair

418419 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36

419420 Main-Is: examples/hair.hs

420421 GHC-Options: -Wall

421− CPP-Options: -DPROJECTM36_VERSION="v0.1"

422422

423423Test-Suite test-scripts

424424 Default-Language: Haskell2010

@@ -432,11 +432,10 @@ Test-Suite test-scripts

432432

433433Executable project-m36-websocket-server

434434 Default-Language: Haskell2010

435− Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, uuid-aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups

435+ Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups

436436 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

437437 Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

438438 GHC-Options: -Wall

439− CPP-Options: -DPROJECTM36_VERSION="v0.1"

440439 Hs-Source-Dirs: ./src/bin

441440 Default-Extensions: OverloadedStrings

442441

@@ -444,53 +443,57 @@ Test-Suite test-websocket-server

444443 Default-Language: Haskell2010

445444 type: exitcode-stdio-1.0

446445 main-is: test/Server/WebSocket.hs

447− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36, random, MonadRandom, network-transport-tcp, semigroups

446+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, network-transport-tcp, semigroups

448447 Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

449448 Default-Extensions: OverloadedStrings

450449 GHC-Options: -Wall

451450 Hs-Source-Dirs: ./src/bin, .

452− CPP-Options: -DPROJECTM36_VERSION="v0.1"

453451

454452Test-Suite test-isomorphic-schemas

455453 Default-Language: Haskell2010

456454 type: exitcode-stdio-1.0

457455 main-is: test/IsomorphicSchema.hs

458− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36

456+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36

459457 Default-Extensions: OverloadedStrings

460458 GHC-Options: -Wall

461459 Hs-Source-Dirs: ./src/bin, .

462− CPP-Options: -DPROJECTM36_VERSION="v0.1"

463460

464461Test-Suite test-atomable

465462 Default-Language: Haskell2010

466463 type: exitcode-stdio-1.0

467464 main-is: test/Relation/Atomable.hs

468− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36, random, MonadRandom, semigroups

465+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

469466 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types

470467 Default-Extensions: OverloadedStrings

471468 GHC-Options: -Wall

472469 Hs-Source-Dirs: ./src/bin, ., test/

473− CPP-Options: -DPROJECTM36_VERSION="v0.1"

474470

475471Test-Suite test-multiprocess-access

476472 Default-Language: Haskell2010

477473 type: exitcode-stdio-1.0

478474 main-is: test/MultiProcessDatabaseAccess.hs

479− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36, random, MonadRandom

475+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom

480476 Default-Extensions: OverloadedStrings

481477 GHC-Options: -Wall

482478 Hs-Source-Dirs: ./src/bin, ., test/

483− CPP-Options: -DPROJECTM36_VERSION="v0.1"

484479

485480Test-Suite test-transactiongraph-automerge

486481 Default-Language: Haskell2010

487482 type: exitcode-stdio-1.0

488483 main-is: test/TransactionGraph/Automerge.hs

489− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36, random, MonadRandom, semigroups

484+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

485+ Default-Extensions: OverloadedStrings

486+ GHC-Options: -Wall

487+ Hs-Source-Dirs: ./src/bin, ., test/

488+

489+Test-Suite test-tupleable

490+ Default-Language: Haskell2010

491+ type: exitcode-stdio-1.0

492+ main-is: test/Relation/Tupleable.hs

493+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

490494 Default-Extensions: OverloadedStrings

491495 GHC-Options: -Wall

492496 Hs-Source-Dirs: ./src/bin, ., test/

493− CPP-Options: -DPROJECTM36_VERSION="v0.1"

494497

495498Test-Suite test-client-simple

496499 Default-Language: Haskell2010

@@ -500,4 +503,4 @@ Test-Suite test-client-simple

500503 Default-Extensions: OverloadedStrings

501504 GHC-Options: -Wall

502505 Hs-Source-Dirs: ./src/bin, ., test/

503− CPP-Options: -DPROJECTM36_VERSION="v0.1"

506+

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+13−14

@@ -1,17 +1,16 @@

11--create a bunch of orphan instances for use with the websocket server

2−{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

2+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

33{-# OPTIONS_GHC -fno-warn-orphans #-}

44module ProjectM36.Server.RemoteCallTypes.Json where

5−import ProjectM36.Server.RemoteCallTypes

5+import ProjectM36.AtomFunctionError

66import ProjectM36.Base

7−import ProjectM36.Error

7+import ProjectM36.DatabaseContextFunctionError

88import ProjectM36.DataTypes.Primitive

9+import ProjectM36.Error

910import ProjectM36.IsomorphicSchema

10−import ProjectM36.DatabaseContextFunctionError

11−import ProjectM36.AtomFunctionError

11+import ProjectM36.Server.RemoteCallTypes

1212

1313import Data.Aeson

14−import Data.UUID.Aeson ()

1514import Data.ByteString.Base64 as B64

1615import Data.Text.Encoding

1716import Data.Time.Calendar

@@ -64,7 +63,7 @@ instance FromJSON SchemaExpr

6463instance ToJSON SchemaIsomorph

6564instance FromJSON SchemaIsomorph

6665

67−instance ToJSON Atom where

66+instance ToJSON Atom where

6867 toJSON atom@(IntAtom i) = object [ "type" .= atomTypeForAtom atom,

6968 "val" .= i ]

7069 toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom,

@@ -79,9 +78,9 @@ instance ToJSON Atom where

7978 "val" .= decodeUtf8 (B64.encode i) ]

8079 toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom,

8180 "val" .= i ]

82−

81+

8382 toJSON atom@(IntervalAtom b e i1 i2) = object [ "type" .= atomTypeForAtom atom,

84− "val" .= object [

83+ "val" .= object [

8584 "begin" .= toJSON b,

8685 "end" .= toJSON e,

8786 "beginopen" .= i1,

@@ -95,16 +94,16 @@ instance ToJSON Atom where

9594 "type" .= toJSON atomtype,

9695 "atomlist" .= toJSON atomlist

9796 ]

98−

97+

9998instance FromJSON Atom where

10099 parseJSON = withObject "atom" $ \o -> do

101− atype <- o .: "type"

100+ atype <- o .: "type"

102101 case atype of

103102 TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire"

104103 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

105104 RelationAtomType _ -> do

106105 rel <- o .: "val"

107− pure $ RelationAtom rel

106+ pure $ RelationAtom rel

108107 IntAtomType -> IntAtom <$> o .: "val"

109108 DoubleAtomType -> DoubleAtom <$> o .: "val"

110109 TextAtomType -> TextAtom <$> o .: "val"

@@ -118,12 +117,12 @@ instance FromJSON Atom where

118117 Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err)

119118 Right bs -> pure (ByteStringAtom bs)

120119 BoolAtomType -> BoolAtom <$> o .: "val"

121− IntervalAtomType _ -> IntervalAtom <$>

120+ IntervalAtomType _ -> IntervalAtom <$>

122121 ((o .: "val") >>= (.: "begin")) <*>

123122 ((o .: "val") >>= (.: "end")) <*>

124123 ((o .: "val") >>= (.: "beginopen")) <*>

125124 ((o .: "val") >>= (.: "endopen"))

126−

125+

127126

128127instance ToJSON Notification

129128instance FromJSON Notification

src/bin/TutorialD/Interpreter/Base.hs−1

@@ -17,7 +17,6 @@ import System.IO

1717import ProjectM36.Relation.Show.Term

1818import GHC.Generics

1919import Data.Monoid

20−import Control.Monad (void)

2120import qualified Data.UUID as U

2221import Control.Monad.Random

2322import Data.List.NonEmpty as NE

src/bin/TutorialD/Interpreter/InformationOperator.hs+1−1

@@ -21,7 +21,7 @@ getVersionP :: Parser InformationOperator

2121getVersionP = reserved ":version" >> pure GetVersionOperator

2222

2323evalInformationOperator :: InformationOperator -> Either Text Text

24−evalInformationOperator GetVersionOperator = Right ("tutd " `append` PROJECTM36_VERSION)

24+evalInformationOperator GetVersionOperator = Right ("tutd " `append` VERSION_project_m36)

2525-- display generic help

2626evalInformationOperator HelpOperator = Right $ intercalate "\n" help

2727 where

src/bin/TutorialD/tutd.hs+3−3

@@ -71,12 +71,12 @@ ghcPkgPathsForConfig _ = error "Clients cannot configure remote ghc package path

7171errDie :: String -> IO ()

7272errDie err = hPutStrLn stderr err >> exitFailure

7373

74−#ifndef PROJECTM36_VERSION

75−#error PROJECTM36_VERSION is not defined

74+#ifndef VERSION_project_m36

75+#error VERSION_project_m36 is not defined

7676#endif

7777printWelcome :: IO ()

7878printWelcome = do

79− putStrLn $ "Project:M36 TutorialD Interpreter " ++ PROJECTM36_VERSION

79+ putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36

8080 putStrLn "Type \":help\" for more information."

8181 putStrLn "A full tutorial is available at:"

8282 putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"

src/lib/ProjectM36/Atomable.hs+21−21

@@ -50,58 +50,58 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where

5050 toAtomType v = toAtomTypeG (from v)

5151

5252 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.

53− toDatabaseContextExpr :: a -> DatabaseContextExpr

54− default toDatabaseContextExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr

55− toDatabaseContextExpr v = toDatabaseContextExprG (from v) (toAtomType v)

53+ toAddTypeExpr :: a -> DatabaseContextExpr

54+ default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr

55+ toAddTypeExpr v = toAddTypeExprG (from v) (toAtomType v)

5656

5757instance Atomable Int where

5858 toAtom = IntAtom

5959 fromAtom (IntAtom i) = i

6060 fromAtom e = error ("improper fromAtom" ++ show e)

6161 toAtomType _ = IntAtomType

62− toDatabaseContextExpr _ = NoOperation

62+ toAddTypeExpr _ = NoOperation

6363

6464instance Atomable Double where

6565 toAtom = DoubleAtom

6666 fromAtom (DoubleAtom d) = d

6767 fromAtom _ = error "improper fromAtom"

6868 toAtomType _ = DoubleAtomType

69− toDatabaseContextExpr _ = NoOperation

69+ toAddTypeExpr _ = NoOperation

7070

7171instance Atomable T.Text where

7272 toAtom = TextAtom

7373 fromAtom (TextAtom t) = t

7474 fromAtom _ = error "improper fromAtom"

7575 toAtomType _ = TextAtomType

76− toDatabaseContextExpr _ = NoOperation

76+ toAddTypeExpr _ = NoOperation

7777

7878instance Atomable Day where

7979 toAtom = DayAtom

8080 fromAtom (DayAtom d) = d

8181 fromAtom _ = error "improper fromAtom"

8282 toAtomType _ = DayAtomType

83− toDatabaseContextExpr _ = NoOperation

83+ toAddTypeExpr _ = NoOperation

8484

8585instance Atomable UTCTime where

8686 toAtom = DateTimeAtom

8787 fromAtom (DateTimeAtom t) = t

8888 fromAtom _ = error "improper fromAtom"

8989 toAtomType _ = DateTimeAtomType

90− toDatabaseContextExpr _ = NoOperation

90+ toAddTypeExpr _ = NoOperation

9191

9292instance Atomable ByteString where

9393 toAtom = ByteStringAtom

9494 fromAtom (ByteStringAtom b) = b

9595 fromAtom _ = error "improper fromAtom"

9696 toAtomType _ = ByteStringAtomType

97− toDatabaseContextExpr _ = NoOperation

97+ toAddTypeExpr _ = NoOperation

9898

9999instance Atomable Bool where

100100 toAtom = BoolAtom

101101 fromAtom (BoolAtom b) = b

102102 fromAtom _ = error "improper fromAtom"

103103 toAtomType _ = BoolAtomType

104− toDatabaseContextExpr _ = NoOperation

104+ toAddTypeExpr _ = NoOperation

105105

106106instance Atomable Relation where

107107 toAtom = RelationAtom

@@ -109,7 +109,7 @@ instance Atomable Relation where

109109 fromAtom _ = error "improper fromAtom"

110110 --warning: cannot be used with undefined "Relation"

111111 toAtomType rel = RelationAtomType (attributes rel)

112− toDatabaseContextExpr _ = NoOperation

112+ toAddTypeExpr _ = NoOperation

113113

114114--convert to ADT list

115115instance Atomable a => Atomable [a] where

@@ -121,7 +121,7 @@ instance Atomable a => Atomable [a] where

121121 fromAtom _ = error "improper fromAtom [a]"

122122

123123 toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (undefined :: a)))

124− toDatabaseContextExpr _ = NoOperation

124+ toAddTypeExpr _ = NoOperation

125125

126126-- Generics

127127class AtomableG g where

@@ -130,7 +130,7 @@ class AtomableG g where

130130 fromAtomG :: Atom -> [Atom] -> Maybe (g a)

131131 toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType

132132 toAtomsG :: g a -> [Atom]

133− toDatabaseContextExprG :: g a -> AtomType -> DatabaseContextExpr

133+ toAddTypeExprG :: g a -> AtomType -> DatabaseContextExpr

134134 getConstructorsG :: g a -> [DataConstructorDef]

135135 getConstructorArgsG :: g a -> [DataConstructorDefArg]

136136

@@ -142,11 +142,11 @@ instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where

142142 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?

143143 where

144144 typeName = datatypeName (undefined :: M1 D c a x)

145− toDatabaseContextExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors

145+ toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors

146146 where

147147 tcDef = ADTypeConstructorDef tcName []

148148 dataConstructors = getConstructorsG v

149− toDatabaseContextExprG _ _ = NoOperation

149+ toAddTypeExprG _ _ = NoOperation

150150 getConstructorsG (M1 v) = getConstructorsG v

151151 getConstructorArgsG = undefined

152152

@@ -166,7 +166,7 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where

166166 fromAtomG _ _ = error "unsupported generic traversal"

167167 toAtomsG = undefined

168168 toAtomTypeG = undefined

169− toDatabaseContextExprG = undefined

169+ toAddTypeExprG = undefined

170170 getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]

171171 where

172172 dName = conName (undefined :: M1 C c a x)

@@ -179,7 +179,7 @@ instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where

179179 fromAtomG atom args = M1 <$> fromAtomG atom args

180180 toAtomsG (M1 v) = toAtomsG v

181181 toAtomTypeG (M1 v) = toAtomTypeG v

182− toDatabaseContextExprG _ _ = undefined

182+ toAddTypeExprG _ _ = undefined

183183 getConstructorsG = undefined

184184 getConstructorArgsG (M1 v) = getConstructorArgsG v

185185

@@ -191,7 +191,7 @@ instance (Atomable a) => AtomableG (K1 c a) where

191191 headatom [] = error "no more atoms for constructor!"

192192 toAtomsG (K1 v) = [toAtom v]

193193 toAtomTypeG _ = toAtomType (undefined :: a)

194− toDatabaseContextExprG _ _ = undefined

194+ toAddTypeExprG _ _ = undefined

195195 getConstructorsG = undefined

196196 getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]

197197 where

@@ -204,7 +204,7 @@ instance AtomableG U1 where

204204 fromAtomG _ _ = pure U1

205205 toAtomsG _ = []

206206 toAtomTypeG = undefined

207− toDatabaseContextExprG = undefined

207+ toAddTypeExprG = undefined

208208 getConstructorsG = undefined

209209 getConstructorArgsG _ = []

210210

@@ -218,7 +218,7 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where

218218 tailatoms [] = error "no more atoms in tail for product!"

219219 toAtomTypeG = undefined

220220 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

221− toDatabaseContextExprG _ _ = undefined

221+ toAddTypeExprG _ _ = undefined

222222 getConstructorsG = undefined

223223 getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y

224224

@@ -230,7 +230,7 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where

230230 toAtomTypeG = undefined

231231 toAtomsG (L1 x) = toAtomsG x

232232 toAtomsG (R1 x) = toAtomsG x

233− toDatabaseContextExprG _ _ = undefined

233+ toAddTypeExprG _ _ = undefined

234234 getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)

235235 getConstructorArgsG = undefined

236236

src/lib/ProjectM36/Error.hs+2−1

@@ -96,7 +96,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

9696 deriving (Show,Eq,Generic,Binary,Typeable, NFData)

9797

9898data PersistenceError = InvalidDirectoryError FilePath |

99− MissingTransactionError TransactionId

99+ MissingTransactionError TransactionId |

100+ WrongDatabaseFormatVersionError String String

100101 deriving (Show, Eq, Generic, Binary, NFData)

101102

102103--collapse list of errors into normal error- if there is just one, just return one

src/lib/ProjectM36/Key.hs+12−2

@@ -39,6 +39,16 @@ databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvNam

3939

4040-- | Create a foreign key constraint from the first relation variable and attributes to the second.

4141databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr

42−databaseContextExprForForeignKey fkName (rvA, attrsA) (rvB, attrsB) = AddInclusionDependency fkName $ InclusionDependency (Project (attrsL attrsA) (RelationVariable rvA ())) (Project (attrsL attrsB) (RelationVariable rvB ()))

42+databaseContextExprForForeignKey fkName (rvA, attrsA) (rvB, attrsB) =

43+ AddInclusionDependency fkName (InclusionDependency

44+ (renameIfNecessary attrsB attrsA (Project (attrsL attrsA)

45+ (RelationVariable rvA ())))

46+ (Project (attrsL attrsB)

47+ (RelationVariable rvB ())))

4348 where

44− attrsL = AttributeNames . S.fromList

49+ attrsL = AttributeNames . S.fromList

50+ renameIfNecessary attrsExpected attrsExisting expr = foldr folder expr (zip attrsExpected attrsExisting)

51+ folder (attrExpected, attrExisting) expr = if attrExpected == attrExisting then

52+ expr

53+ else

54+ Rename attrExisting attrExpected expr

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 (:) [] 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/TransactionGraph/Persist.hs+34−12

@@ -20,6 +20,7 @@ import Data.Text.Encoding

2020import Control.Monad (foldM)

2121import Data.Either (isRight)

2222import Data.Maybe (fromMaybe)

23+import qualified Data.List as L

2324import Control.Exception.Base

2425import qualified Data.Text.IO as TIO

2526import Data.ByteString (ByteString)

@@ -28,18 +29,25 @@ import qualified Crypto.Hash.SHA256 as SHA256

2829import Control.Arrow

2930import Data.Time.Clock

3031import Data.Text.Read

32+import System.FilePath.Glob

3133

3234type LockFileHash = ByteString

3335

3436{-

35−The "m36v1" file at the top-level of the destination directory contains the the transaction graph as a set of transaction ids referencing their parents (1 or more)

37+The "m36vX" file at the top-level of the destination directory contains the the transaction graph as a set of transaction ids referencing their parents (1 or more)

3638Each Transaction is written to it own directory named by its transaction id. Partially written transactions ids are prefixed with a "." to indicate incompleteness in the graph.

3739

3840Persistence requires a POSIX-compliant, journaled-metadata filesystem.

3941-}

4042

43+expectedVersion :: Int

44+expectedVersion = 2

45+

46+transactionLogFileName :: FilePath

47+transactionLogFileName = "m36v" ++ show expectedVersion

48+

4149transactionLogPath :: FilePath -> FilePath

42−transactionLogPath dbdir = dbdir </> "m36v1"

50+transactionLogPath dbdir = dbdir </> transactionLogFileName

4351

4452headsPath :: FilePath -> FilePath

4553headsPath dbdir = dbdir </> "heads"

@@ -53,18 +61,32 @@ verify that the database directory is valid or bootstrap it

5361- return error or lock file handle which is already locked with a read lock

5462-}

5563

64+checkForOtherVersions :: FilePath -> IO (Either PersistenceError ())

65+checkForOtherVersions dbdir = do

66+ versionMatches <- globDir1 (compile "m36v*") dbdir

67+ let otherVersions = L.delete transactionLogFileName (map takeFileName versionMatches)

68+ if not (null otherVersions) then

69+ pure (Left (WrongDatabaseFormatVersionError transactionLogFileName (head otherVersions)))

70+ else

71+ pure (Right ())

72+

73+

5674setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (Handle, LockFileHash))

5775setupDatabaseDir sync dbdir bootstrapGraph = do

5876 dbdirExists <- doesDirectoryExist dbdir

59− m36exists <- doesFileExist (transactionLogPath dbdir)

60− if dbdirExists && m36exists then do

61− --no directories to write, just

62− lockFileH <- openLockFile dbdir

63− gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir)

64− pure (Right (lockFileH, gDigest))

65− else if not m36exists then do

66− locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph

67− pure (Right locks)

77+ eWrongVersion <- checkForOtherVersions dbdir

78+ case eWrongVersion of

79+ Left err -> pure (Left err)

80+ Right () -> do

81+ m36exists <- doesFileExist (transactionLogPath dbdir)

82+ if dbdirExists && m36exists then do

83+ --no directories to write, just

84+ lockFileH <- openLockFile dbdir

85+ gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir)

86+ pure (Right (lockFileH, gDigest))

87+ else if not m36exists then do

88+ locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph

89+ pure (Right locks)

6890 else

6991 pure (Left (InvalidDirectoryError dbdir))

7092{-

@@ -172,7 +194,7 @@ readTransactionIfNecessary dbdir transId mScriptSession graphIn =

172194writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash

173195writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = writeFileSync sync graphFile uuidInfo >> pure digest

174196 where

175− graphFile = destDirectory </> "m36v1"

197+ graphFile = transactionLogPath destDirectory

176198 uuidInfo = T.intercalate "\n" graphLines

177199 digest = SHA256.hash (encodeUtf8 uuidInfo)

178200 graphLines = S.toList $ S.map graphLine transSet

src/lib/ProjectM36/Tuple.hs+3

@@ -209,3 +209,6 @@ reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

209209 Left _ -> error "logic failure in reorderTuple"

210210 Right atom -> atom

211211

212+--used in Generics derivation for ADTs without named attributes

213+trimTuple :: Int -> RelationTuple -> RelationTuple

214+trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)

src/lib/ProjectM36/Tupleable.hsnew file+129

@@ -0,0 +1,129 @@

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

2+module ProjectM36.Tupleable where

3+import ProjectM36.Base

4+import ProjectM36.Error

5+import ProjectM36.Tuple

6+import ProjectM36.TupleSet

7+import ProjectM36.Atomable

8+import ProjectM36.DataTypes.Primitive

9+import ProjectM36.Attribute hiding (null)

10+import GHC.Generics

11+import qualified Data.Vector as V

12+import qualified Data.Text as T

13+import Data.Monoid

14+import Data.Foldable

15+

16+{-

17+data Test1T = Test1C {

18+ attrA :: Int

19+ }

20+ deriving (Generic, Show)

21+

22+data Test2T a b = Test2C {

23+ attrB :: a,

24+ attrC :: b

25+ }

26+ deriving (Generic, Show)

27+

28+instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)

29+

30+instance Tupleable Test1T

31+

32+data TestUnnamed1 = TestUnnamed1 Int Double T.Text

33+ deriving (Show,Eq, Generic)

34+

35+instance Tupleable TestUnnamed1

36+-}

37+

38+-- | 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.

39+toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr

40+toInsertExpr vals rvName = do

41+ let attrs = toAttributes (head (toList vals))

42+ tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)

43+ let rel = MakeStaticRelation attrs tuples

44+ pure (Insert rvName rel)

45+

46+-- | 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 'undefined'.

47+toDefineExpr :: Tupleable a => a -> RelVarName -> DatabaseContextExpr

48+toDefineExpr val rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))

49+ where

50+ attrs = toAttributes val

51+

52+

53+

54+class Tupleable a where

55+ toTuple :: a -> RelationTuple

56+

57+ fromTuple :: RelationTuple -> Either RelationalError a

58+

59+ toAttributes :: a -> Attributes

60+

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

62+ toTuple v = toTupleG (from v)

63+

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

65+ fromTuple tup = to <$> fromTupleG tup

66+

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

68+ toAttributes v = toAttributesG (from v)

69+

70+class TupleableG g where

71+ toTupleG :: g a -> RelationTuple

72+ toAttributesG :: g a -> Attributes

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

74+

75+--data type metadata

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

77+ toTupleG (M1 v) = toTupleG v

78+ toAttributesG (M1 v) = toAttributesG v

79+ fromTupleG v = M1 <$> fromTupleG v

80+

81+--constructor metadata

82+instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where

83+ toTupleG (M1 v) = RelationTuple attrs atoms

84+ where

85+ attrsToCheck = toAttributesG v

86+ counter = V.generate (V.length attrsToCheck) id

87+ attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

88+ Attribute ("attr" <> T.pack (show (num + 1))) typ

89+ else

90+ attr) counter attrsToCheck

91+ atoms = V.fromList (toAtomsG v)

92+ toAttributesG (M1 v) = toAttributesG v

93+ fromTupleG tup = M1 <$> fromTupleG tup

94+

95+-- product types

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

97+ toTupleG = error "toTupleG"

98+ 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

99+ fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG (trimTuple 1 tup)

100+

101+--selector/record

102+instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

103+ toTupleG = error "toTupleG"

104+ toAttributesG m@(M1 v) = V.singleton (Attribute name aType)

105+ where

106+ name = T.pack (selName m)

107+ aType = toAtomTypeG v

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

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

110+ else do

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

112+ val <- atomv atom

113+ pure (M1 val)

114+ where

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

116+ atomv atom = maybe (Left (AtomTypeMismatchError

117+ expectedAtomType

118+ (atomTypeForAtom atom)

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

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

121+

122+--constructors with no arguments

123+--basically useless but orthoganal to relationTrue

124+instance TupleableG U1 where

125+ toTupleG _= emptyTuple

126+ toAttributesG _ = emptyAttributes

127+ fromTupleG _ = pure U1

128+

129+

test/Relation/Atomable.hs+1−1

@@ -61,7 +61,7 @@ testHaskell2DB :: Test

6161testHaskell2DB = TestCase $ do

6262 --validate generated database context expression

6363 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

64− let test1TExpr = toDatabaseContextExpr (undefined :: Test1T)

64+ let test1TExpr = toAddTypeExpr (undefined :: Test1T)

6565 expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" IntAtomType)]]

6666 assertEqual "simple ADT1" expectedTest1TExpr test1TExpr

6767 checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr

test/Relation/Tupleable.hsnew file+118

@@ -0,0 +1,118 @@

1+{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, TypeOperators, DeriveAnyClass #-}

2+import Test.HUnit

3+import ProjectM36.Tupleable

4+import ProjectM36.Atomable

5+import ProjectM36.Attribute

6+import Data.Binary

7+import ProjectM36.Base

8+import Control.DeepSeq (NFData)

9+import GHC.Generics

10+import qualified Data.Vector as V

11+import qualified Data.Map as M

12+import qualified Data.Text as T

13+import System.Exit

14+

15+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

16+

17+data Test1T = Test1C {

18+ attrA :: Int

19+ }

20+ deriving (Generic, Eq, Show)

21+

22+data Test2T = Test2C {

23+ attrB :: Int,

24+ attrC :: Int

25+ }

26+ deriving (Generic, Eq, Show)

27+

28+data Test3T = Test3C Int

29+ deriving (Generic, Eq, Show)

30+

31+data Test4T = Test4C

32+ deriving (Generic, Eq, Show)

33+

34+data Test5T = Test5C1 Int |

35+ Test5C2 Int

36+ deriving (Generic, Eq, Show)

37+

38+data Test6T = Test6C T.Text Int Double

39+ deriving (Generic, Eq, Show)

40+

41+data Test7A = Test7AC Int

42+ deriving (Generic, Show, Eq, Binary, NFData, Atomable)

43+

44+

45+data Test7T = Test7C Test7A

46+ deriving (Generic, Show, Eq)

47+

48+data Test8T = Test8C

49+ deriving (Generic, Show, Eq)

50+

51+instance Tupleable Test1T

52+

53+instance Tupleable Test2T

54+

55+instance Tupleable Test3T

56+

57+instance Tupleable Test4T

58+

59+--instance Tupleable Test5T -- should fail at compile time- sum types not supported

60+

61+instance Tupleable Test6T

62+

63+instance Tupleable Test7T

64+

65+instance Tupleable Test8T

66+

67+main :: IO ()

68+main = do

69+ tcounts <- runTestTT testList

70+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

71+

72+testList :: Test

73+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8]

74+

75+testADT1 :: Test

76+testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))

77+ where

78+ example = Test1C {attrA = 3}

79+

80+

81+testADT2 :: Test

82+testADT2 = TestCase $ do

83+ let example = Test2C { attrB = 4, attrC = 6 }

84+ assertEqual "two record constructor" (Right example) (fromTuple (toTuple example))

85+ --this was a tricky case that was throwing the undefined exception because of insufficient laziness in the :*: matching- see ProjectM36.Tupleable

86+ let expectedAttributes = attributesFromList [Attribute "attrB" IntAtomType,

87+ Attribute "attrC" IntAtomType]

88+ assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (undefined :: Test2T))

89+

90+

91+testADT3 :: Test

92+testADT3 = TestCase $ assertEqual "one arg constructor" (Right example) (fromTuple (toTuple example))

93+ where

94+ example = Test3C 4

95+

96+testADT4 :: Test

97+testADT4 = TestCase $ assertEqual "zero arg constructor" (Right example) (fromTuple (toTuple example))

98+ where

99+ example = Test4C

100+

101+--testADT5 should not compile

102+

103+testADT6 :: Test

104+testADT6 = TestCase $ assertEqual "mixed types" (Right example) (fromTuple (toTuple example))

105+ where

106+ example = Test6C "testo" 3 4.0

107+

108+testADT7 :: Test

109+testADT7 = TestCase $ do

110+ let example = Test7C (Test7AC 3)

111+ assertEqual "atom type" (Right example) (fromTuple (toTuple example))

112+ let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

113+ assertEqual "adt atomtype" expectedAttrs (toAttributes (undefined :: Test7T))

114+

115+testADT8 :: Test

116+testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example))

117+ where

118+ example = Test8C

test/TransactionGraph/Automerge.hs+1−1

@@ -25,7 +25,7 @@ checkEither :: IO (Either RelationalError a) -> IO a

2525checkEither io = do

2626 ret <- io

2727 case ret of

28− Left err -> assertFailure (show err)

28+ Left err -> assertFailure (show err) >> undefined

2929 Right a -> pure a

3030

3131testAutomergeSuccess :: Test

test/TutorialD/Interpreter.hs+2−1

@@ -27,7 +27,8 @@ import Control.Concurrent

2727import qualified Data.Set as S

2828import Data.Text hiding (map)

2929import qualified Data.Text as T

30−import Data.Time.Clock.POSIX

30+import Data.Time.Clock.POSIX hiding (getCurrentTime)

31+import Data.Time.Clock (getCurrentTime)

3132

3233main :: IO ()

3334main = do