e4f6b64 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP: much refactoring for Atom existential quantification change

commite4f6b64aed4506d4904d2918bc486f2e798cdacb authorAgentM <agentm@themactionfaction.com> dateFri 9 Oct 2015, 17:32 (11 years ago) parent3db5717

13 files changed+427−413

compare with master

unifiedsplit

Database/Persist/ProjectM36.hs+98−96 ProjectM36/Atom.hs+20−36 ProjectM36/Attribute.hs−4 ProjectM36/Base.hs+12−3 ProjectM36/ConcreteTypeRep.hs−1 ProjectM36/Relation.hs+52−43 ProjectM36/Relation/Parse/CSV.hs+4−2 ProjectM36/Relation/Show/CSV.hs+12−15 ProjectM36/Relation/Show/Gnuplot.hs+21−20 ProjectM36/Relation/Show/HTML.hs+4−9 ProjectM36/Relation/Show/Term.hs+18−22 ProjectM36/RelationalExpression.hs+150−127 ProjectM36/TransactionGraph.hs+36−35

Database/Persist/ProjectM36.hs+98−96

@@ -29,9 +29,11 @@ import Control.Monad.Trans.Either

2929import qualified Database.Persist.Types as DPT

3030import qualified Data.Set as S

3131import qualified Data.Conduit.List as CL

32+import Data.Typeable (cast)

33+import ProjectM36.RelationalExpression (unsafeCast)

34+

35+type ProjectM36Backend = C.Connection

3236

33−type ProjectM36Backend = C.Connection

34−

3537--convert a PersistEntity to a RelationTuple

3638recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)

3739 => Maybe U.UUID -> record -> Either RelationalError RelationTuple

@@ -42,43 +44,43 @@ recordAsTuple uuid record = do -- if the uuid is passed in, set the idDBName att

4244 attrVec <- recordAttributes entInfo record

4345 atomVec <- recordAsAtoms uuid attrVec record

4446 return $ RelationTuple attrVec atomVec

45−

47+

4648recordAttributes :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)

4749 => [(EmbedFieldDef, PersistValue)] -> record -> Either RelationalError Attributes

4850recordAttributes entInfo record = do

4951 let convertAttr = uncurry fieldDefAsAttribute

5052 idDBName = unDBName $ fieldDB $ entityId (entityDef $ Just record)

5153 attrList <- mapM convertAttr entInfo

52− return $ V.fromList ([Attribute idDBName StringAtomType] ++ attrList)

53−

54+ return $ V.fromList ([Attribute idDBName stringAtomType] ++ attrList)

55+

5456fieldDefAsAttribute :: EmbedFieldDef -> PersistValue -> Either RelationalError Attribute

5557fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of

5658 Nothing -> Left $ AtomTypeNotSupported attrName

5759 Just fType -> Right $ Attribute attrName fType

58− where

60+ where

5961 attrName = unDBName $ emFieldDB fieldDef

60−

61−persistValueAtomType :: PersistValue -> Maybe AtomType

62+

63+persistValueAtomType :: PersistValue -> Maybe AtomType

6264persistValueAtomType val = do

6365 atom <- persistValueAtom val

6466 return $ atomTypeForAtom atom

65−

67+

6668persistValueAtom :: PersistValue -> Maybe Atom

6769persistValueAtom val = case val of

68− PersistText v -> return $ StringAtom v

69− PersistInt64 v -> return $ IntAtom (fromIntegral v)

70− PersistBool v -> return $ BoolAtom v

71− PersistDay v -> return $ DateAtom v

70+ PersistText v -> return $ Atom v

71+ PersistInt64 v -> return $ Atom ((fromIntegral v)::Int)

72+ PersistBool v -> return $ Atom v

73+ PersistDay v -> return $ Atom v

7274 _ -> Nothing

73−

74−atomAsPersistValue :: Atom -> PersistValue

75−atomAsPersistValue a = case a of

76− StringAtom v -> PersistText v

77− IntAtom v -> PersistInt64 (fromIntegral v)

78− BoolAtom v -> PersistBool v

79− DateAtom v -> PersistDay v

75+

76+atomAsPersistValue :: Atom -> PersistValue

77+atomAsPersistValue atom = case atomTypeForAtom atom of

78+ stringAtomType -> PersistText (unsafeCast atom)

79+ intAtomType -> PersistInt64 (fromIntegral ((unsafeCast atom)::Int))

80+ boolAtomType -> PersistBool (unsafeCast atom)

81+ dateAtomType -> PersistDay (unsafeCast atom)

8082 _ -> error "missing conversion"

81−

83+

8284recordAsAtoms :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)

8385 => Maybe U.UUID -> Attributes -> record -> Either RelationalError (V.Vector Atom)

8486recordAsAtoms freshUUID _ record = do

@@ -87,37 +89,37 @@ recordAsAtoms freshUUID _ record = do

8789 Nothing -> Left $ AtomTypeNotSupported ""

8890 Just atom -> Right atom

8991 atoms <- mapM valAtom pValues

90− return $ V.fromList $ case freshUUID of

92+ return $ V.fromList $ case freshUUID of

9193 Nothing -> atoms

92− Just uuid -> [StringAtom $ T.pack (U.toString uuid)] ++ atoms

93−

94+ Just uuid -> [Atom $ T.pack (U.toString uuid)] ++ atoms

95+

9496--used by insert operations

95−recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection) =>

97+recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection) =>

9698 [(Maybe U.UUID, record)] -> Either RelationalError Relation

9799recordsAsRelation [] = Left EmptyTuplesError

98100recordsAsRelation recordZips = do

99101 tupleList <- mapM (uncurry recordAsTuple) recordZips

100102 let oneTuple = head tupleList

101103 mkRelation (tupleAttributes oneTuple) (RelationTupleSet tupleList)

102−

103−keyFromValuesOrDie :: (Trans.MonadIO m,

104− PersistEntity record,

104+

105+keyFromValuesOrDie :: (Trans.MonadIO m,

106+ PersistEntity record,

105107 PersistEntityBackend record ~ C.Connection

106108 ) => [PersistValue] -> m (Key record)

107109keyFromValuesOrDie val = case keyFromValues val of

108110 Right k -> return k

109111 Left _ -> Trans.liftIO $ throwIO $ PersistError "key pooped"

110−

112+

111113insertNewRecords :: (Trans.MonadIO m,

112114 PersistEntity record,

113115 PersistEntityBackend record ~ C.Connection) =>

114116 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]

115117insertNewRecords uuids records = do

116− let recordsZip = zip (map Just uuids) records

117− insertExpr = Insert (relVarNameFromRecord $ head records)

118+ let recordsZip = zip (map Just uuids) records

119+ insertExpr = Insert (relVarNameFromRecord $ head records)

118120 case recordsAsRelation recordsZip of

119121 Left err -> throw $ PersistError (T.pack $ show err)

120− Right rel -> do

122+ Right rel -> do

121123 conn <- ask

122124 Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))

123125 mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids

@@ -126,8 +128,8 @@ throwIOPersistError :: (Trans.MonadIO m) => String -> m a

126128throwIOPersistError msg = Trans.liftIO $ throwIO $ PersistError (T.pack msg)

127129

128130lookupByKey :: forall record m.

129− (Trans.MonadIO m,

130− PersistEntity record,

131+ (Trans.MonadIO m,

132+ PersistEntity record,

131133 PersistEntityBackend record ~ C.Connection)

132134 => Key record -> ReaderT C.Connection m (Maybe (Entity record))

133135lookupByKey key = do

@@ -139,13 +141,13 @@ lookupByKey key = do

139141 Left err -> throwIOPersistError ("executeRelationExpr error: " ++ show err)

140142 Right resultRel' -> case singletonTuple resultRel' of

141143 Nothing -> return Nothing --no match on key

142− Just tuple -> do

143− let entityInfo = entityDefFromKey key

144+ Just tuple -> do

145+ let entityInfo = entityDefFromKey key

144146 entity <- fromPersistValuesThrow entityInfo tuple --correct, one match

145147 return $ Just entity

146−

147−fromPersistValuesThrow :: (Trans.MonadIO m,

148− PersistEntity record,

148+

149+fromPersistValuesThrow :: (Trans.MonadIO m,

150+ PersistEntity record,

149151 PersistEntityBackend record ~ C.Connection) => EntityDef -> RelationTuple -> m (Entity record)

150152fromPersistValuesThrow entDef tuple = do

151153 let body = fromPersistValues $ map getValue (entityFields entDef)

@@ -160,17 +162,17 @@ fromPersistValuesThrow entDef tuple = do

160162 Right key -> case body of

161163 Left err -> throwIOPersistError (show err)

162164 Right body' -> return $ Entity key body'

163−

165+

164166commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)

165−commonKeyQueryProperties key = do

167+commonKeyQueryProperties key = do

166168 let matchUUID = keyToUUID key

167169 keyAttributeName = unDBName (fieldDB $ entityId entityInfo)

168− relVarName = unDBName $ entityDB entityInfo

170+ relVarName = unDBName $ entityDB entityInfo

169171 matchUUIDText = T.pack $ U.toString matchUUID

170− entityInfo = entityDefFromKey key

171− restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (StringAtom matchUUIDText))

172+ entityInfo = entityDefFromKey key

173+ restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (Atom matchUUIDText))

172174 return (relVarName, restrictionPredicate)

173−

175+

174176deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (Bool)

175177deleteByKey key = do

176178 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

@@ -178,15 +180,15 @@ deleteByKey key = do

178180 conn <- ask

179181 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query

180182 return $ isJust maybeErr

181−

182−--convert persistent update list to ProjectM36 Update map

183−updatesToUpdateMap :: (Trans.MonadIO m,

183+

184+--convert persistent update list to ProjectM36 Update map

185+updatesToUpdateMap :: (Trans.MonadIO m,

184186 PersistEntityBackend val ~ C.Connection,

185187 PersistEntity val) =>

186188 [DP.Update val] -> ReaderT C.Connection m (M.Map AttributeName Atom)

187−updatesToUpdateMap updates = do

189+updatesToUpdateMap updates = do

188190 let convertMap upd = case updateUpdate upd of

189− DP.Assign -> let attrName = unDBName $ fieldDB $ updateFieldDef upd

191+ DP.Assign -> let attrName = unDBName $ fieldDB $ updateFieldDef upd

190192 newAttrValue = persistValueAtom (updatePersistValue upd) in

191193 case newAttrValue of

192194 Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"

@@ -194,8 +196,8 @@ updatesToUpdateMap updates = do

194196 _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"

195197 updateAtomList <- mapM convertMap updates

196198 return $ M.fromList updateAtomList

197−

198−updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()

199+

200+updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()

199201updateByKey key updates = do

200202 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

201203 updateMap <- updatesToUpdateMap updates

@@ -205,22 +207,22 @@ updateByKey key updates = do

205207 case maybeErr of

206208 Just err -> throwIOPersistError ("executeDatabaseExpr error" ++ show err)

207209 Nothing -> return ()

208−

209−--set the truth unconditionally

210+

211+--set the truth unconditionally

210212repsertByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()

211213repsertByKey key val = do

212214 _ <- delete key

213215 insertKey key val

214−

215−replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()

216+

217+replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()

216218replaceByKey key val = do

217219 deletionSuccess <- deleteByKey key

218220 when (not deletionSuccess) (Trans.liftIO $ throwIO $ PersistError "entity missing during replace")

219221 insertKey key val

220−

222+

221223entityDefFromKey :: PersistEntity record => Key record -> EntityDef

222224entityDefFromKey = entityDef . Just . recordTypeFromKey

223−

225+

224226dummyFromKey :: Key record -> Maybe record

225227dummyFromKey = Just . recordTypeFromKey

226228

@@ -245,7 +247,7 @@ keyToUUID key = case keyToValues key of

245247 Nothing -> error "error reading uuid from text in key construction"

246248 Just uuid -> uuid

247249 _ -> error "unexpected persist value in key construction"

248−

250+

249251instance PersistStore C.Connection where

250252 newtype BackendKey C.Connection = ProjectM36Key { unPM36Key :: U.UUID }

251253 deriving (Show, Read, Eq, Ord, PersistField)

@@ -254,19 +256,19 @@ instance PersistStore C.Connection where

254256 insertMany records = do

255257 freshUUIDs <- Trans.liftIO $ mapM (\_-> nextRandom) records

256258 insertNewRecords freshUUIDs records

257−

259+

258260 insert record = do

259261 keys <- insertMany [record]

260262 return $ head keys

261−

263+

262264 --insertEntityMany [] = return []

263− --insertKey :: (Trans.MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT backend m ()

265+ --insertKey :: (Trans.MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT backend m ()

264266 insertKey key record = do

265267 let uuid = keyToUUID key

266− _ <- insertNewRecords [uuid] [record]

268+ _ <- insertNewRecords [uuid] [record]

267269 return ()

268−

269− --get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val)

270+

271+ --get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val)

270272 get key = do

271273 ent <- lookupByKey key

272274 case ent of

@@ -275,37 +277,37 @@ instance PersistStore C.Connection where

275277

276278 repsert = repsertByKey

277279 --delete followed by insert "set the record as the truth

278−

280+

279281 delete key = deleteByKey key >> return ()

280−

282+

281283 replace = replaceByKey

282−

283− --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()

284+

285+ --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()

284286 update = updateByKey

285−

286−instance FromJSON (BackendKey C.Connection) where

287+

288+instance FromJSON (BackendKey C.Connection) where

287289 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))

288−

290+

289291instance ToJSON (BackendKey C.Connection) where

290292 toJSON (ProjectM36Key uuid) = toJSON $ U.toString uuid

291−

292−--wrapped version which throws exceptions

293+

294+--wrapped version which throws exceptions

293295executeDatabaseContextExpr :: C.Connection -> DatabaseExpr -> IO ()

294296executeDatabaseContextExpr conn expr = do

295297 res <- C.executeDatabaseContextExpr conn expr

296298 case res of

297299 Nothing -> return ()

298300 Just err -> throwIO (PersistError $ T.pack (show err))

299−

301+

300302relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)

301303 => record -> RelVarName

302304relVarNameFromRecord = unDBName . entityDB . entityDef . Just

303−

305+

304306{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}

305307updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef

306308updateFieldDef (DP.Update f _ _) = persistFieldDef f

307309updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"

308−

310+

309311updatePersistValue :: DP.Update v -> PersistValue

310312updatePersistValue (DP.Update _ v _) = toPersistValue v

311313updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"

@@ -315,18 +317,18 @@ instance PersistField U.UUID where

315317 fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of

316318 Nothing -> Left "uuid text read failure"

317319 Just uuid -> Right uuid

318− fromPersistValue _ = Left $ T.pack "expected PersistObjectId"

320+ fromPersistValue _ = Left $ T.pack "expected PersistObjectId"

319321

320322instance FromJSON C.ConnectionInfo where

321323 parseJSON v = modifyFailure ("Persistent: error loading ProjectM36 conf: " ++) $

322324 flip (withObject "ProjectM36Conf") v $ \o -> do

323325 ctype <- parseJSON =<< ( o .: "connectionType")

324326 return ctype

325−

327+

326328instance PersistConfig C.ConnectionInfo where

327329 type PersistConfigBackend C.ConnectionInfo = ReaderT C.Connection

328330 type PersistConfigPool C.ConnectionInfo = C.Connection

329−

331+

330332 loadConfig = parseJSON

331333 applyEnv = return -- no environment variables are used

332334 createPoolConfig conf = do

@@ -336,7 +338,7 @@ instance PersistConfig C.ConnectionInfo where

336338 Right conn -> return conn

337339 --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a

338340 runPool _ r = runReaderT r

339−

341+

340342withProjectM36Conn :: (Monad m, Trans.MonadIO m) => C.ConnectionInfo -> (C.Connection -> m a) -> m a

341343withProjectM36Conn conf connReader = do

342344 conn <- Trans.liftIO $ createPoolConfig conf

@@ -361,17 +363,17 @@ persistUniqueToRestrictionPredicate :: PersistEntity record => Unique record ->

361363persistUniqueToRestrictionPredicate unique = do

362364 atoms <- mapM (\v -> maybe (Left $ AtomTypeNotSupported "") Right $ persistValueAtom v) $ persistUniqueToValues unique

363365 let attrNames = map (unDBName . snd) $ persistUniqueToFieldNames unique

364− andify [] = TruePredicate

366+ andify [] = TruePredicate

365367 andify ((attrName, atom):xs) = AndPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom)) $ andify xs

366368 return $ andify (zip attrNames atoms)

367−

369+

368370instance PersistUnique C.Connection where

369371 getBy unique = do

370372 conn <- ask

371373 let predicate = persistUniqueToRestrictionPredicate unique

372374 relVarName = unDBName $ entityDB entDef

373375 entDef = entityDef $ dummyFromUnique unique

374− throwRelErr err = Trans.liftIO $ throwIO (PersistError (T.pack $ show err))

376+ throwRelErr err = Trans.liftIO $ throwIO (PersistError (T.pack $ show err))

375377 case predicate of

376378 Left err -> throwRelErr err

377379 Right predicate' -> do

@@ -408,8 +410,8 @@ instance PersistUnique C.Connection where

408410multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr

409411multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate

410412multiFilterAsRestrictionPredicate andOr (x:xs) = do

411− let predicate = if andOr then AndPredicate else OrPredicate

412− filtHead <- filterAsRestrictionPredicate x

413+ let predicate = if andOr then AndPredicate else OrPredicate

414+ filtHead <- filterAsRestrictionPredicate x

413415 filtTail <- multiFilterAsRestrictionPredicate andOr xs

414416 return $ predicate filtHead filtTail

415417

@@ -451,8 +453,8 @@ selectionFromRestriction filters = do

451453 let entDef = entityDef $ dummyFromFilters filters

452454 relVarName = unDBName $ entityDB entDef

453455 right $ Restrict restrictionPredicate (RelationVariable relVarName)

454−

455−

456+

457+

456458instance PersistQuery C.Connection where

457459 updateWhere _ [] = return ()

458460 updateWhere filters updates = do

@@ -465,7 +467,7 @@ instance PersistQuery C.Connection where

465467 relVarName = unDBName $ entityDB entDef

466468 updateExpr = Update relVarName updateMap restrictionPredicate

467469 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn updateExpr

468− case maybeErr of

470+ case maybeErr of

469471 Just err -> left err

470472 Nothing -> right ()

471473 case e of

@@ -473,14 +475,14 @@ instance PersistQuery C.Connection where

473475 Right () -> return ()

474476

475477 deleteWhere filters = do

476− conn <- ask

478+ conn <- ask

477479 e <- runEitherT $ do

478480 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters

479− let entDef = entityDef $ dummyFromFilters filters

481+ let entDef = entityDef $ dummyFromFilters filters

480482 relVarName = unDBName $ entityDB entDef

481483 deleteExpr = Delete relVarName restrictionPredicate

482484 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn deleteExpr

483− case maybeErr of

485+ case maybeErr of

484486 Just err -> left err

485487 Nothing -> right ()

486488 case e of

@@ -491,7 +493,7 @@ instance PersistQuery C.Connection where

491493 conn <- ask

492494 e <- runEitherT $ do

493495 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters

494− let entDef = entityDef $ dummyFromFilters filters

496+ let entDef = entityDef $ dummyFromFilters filters

495497 relVarName = unDBName $ entityDB entDef

496498 allAttrNamesList = map (unDBName . fieldDB) (entityFields entDef) ++ [unDBName (fieldDB (entityId entDef))]

497499 allAttrNames = AttributeNames $ S.fromList allAttrNamesList

@@ -499,12 +501,12 @@ instance PersistQuery C.Connection where

499501 tupleExpr = AttributeTupleExpr "persistcount" (FunctionAtomExpr "count" [AttributeAtomExpr "persistcountrel"])

500502 countExpr = Extend tupleExpr groupExpr

501503 rel <- Trans.liftIO $ C.executeRelationalExpr conn countExpr

502− case rel of

504+ case rel of

503505 Left err -> left err

504506 Right rel' -> case singletonTuple rel' of

505507 Nothing -> Trans.liftIO $ throwIO $ PersistError "failed to get count tuple"

506508 Just tuple -> case atomForAttributeName "persistcount" tuple of

507− (Right (IntAtom c)) -> (Trans.liftIO $ putStrLn (show c)) >> return c

509+ (Right c) -> return (castInt c)

508510 Right _ -> Trans.liftIO $ throwIO $ PersistError "count returned wrong data type"

509511 Left err -> left err

510512 case e of

@@ -546,4 +548,4 @@ instance PersistQuery C.Connection where

546548 case keys of

547549 Left err -> throwIOPersistError ("keyFromValues failure2: " ++ show err)

548550 Right keys' -> return $ return (CL.sourceList keys')

549−

551+

ProjectM36/Atom.hs+20−36

@@ -2,44 +2,28 @@

22module ProjectM36.Atom where

33import ProjectM36.Base

44import ProjectM36.Error

5−import qualified Data.Text as T

6−import Text.Read (readMaybe)

7−import Data.Time.Format

5+import Data.Typeable

6+import ProjectM36.ConcreteTypeRep

98relationForAtom :: Atom -> Either RelationalError Relation

10−relationForAtom (RelationAtom rel) = Right rel

11−relationForAtom _ = Left $ AttributeIsNotRelationValuedError ""

9+relationForAtom (Atom atom) = case cast atom of

10+ Just rel@(Relation _ _) -> Right rel

11+ Nothing -> Left $ AttributeIsNotRelationValuedError ""

1212

1313atomTypeForAtom :: Atom -> AtomType

14−atomTypeForAtom (StringAtom _) = StringAtomType

15−atomTypeForAtom (IntAtom _) = IntAtomType

16−atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes

17−atomTypeForAtom (BoolAtom _) = BoolAtomType

18−atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

19−atomTypeForAtom (DateAtom _) = DateAtomType

20−atomTypeForAtom (DoubleAtom _) = DoubleAtomType

14+atomTypeForAtom (Atom atom) = case cast atom of

15+ Just (Relation attrs _) -> RelationAtomType attrs

16+ Nothing -> AtomType $ CTR (typeOf atom)

2117

22−{- a generic string constructor for atoms

23−used by CSV relation generation

24−-}

25−atomFromString :: AtomType -> String -> Either RelationalError Atom

26−atomFromString StringAtomType strIn = Right $ StringAtom (T.pack strIn)

27−atomFromString IntAtomType strIn = case readMaybe strIn of

28− Just i -> Right $ IntAtom i

29− Nothing -> Left (ParseError "Failed to parse integer")

30−atomFromString BoolAtomType strIn = case strIn of

31− "true" -> Right $ BoolAtom True

32− "false" -> Right $ BoolAtom False

33− _ -> Left (ParseError "Failed to parse boolean")

34−atomFromString (RelationAtomType _) _ = Left $ ParseError "Nested relation parsing not supported"

35−atomFromString DateTimeAtomType strIn =

36− case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" strIn of

37− Just utctime -> Right $ DateTimeAtom utctime

38− Nothing -> Left $ ParseError "Failed to parse datetime"

39−atomFromString DoubleAtomType strIn = case readMaybe strIn of

40− Just d -> Right $ DoubleAtom d

41− Nothing -> Left (ParseError "Failed to parse double")

42−atomFromString DateAtomType strIn = case parseTimeM False defaultTimeLocale "%Y-%m-%d" strIn of

43− Just date -> Right $ DateAtom date

44− Nothing -> Left $ ParseError "Failed to parse datetime"

45−atomFromString AnyAtomType _ = Left $ ParseError "Parsing AnyAtomType is not supported"

18+atomTypeForProxy :: (Atomable a) => Proxy a -> AtomType

19+atomTypeForProxy prox = AtomType $ CTR (typeRep prox)

20+

21+--some convenience functions

22+stringAtomType :: AtomType

23+stringAtomType = atomTypeForProxy (Proxy :: Proxy StringType)

24+

25+intAtomType :: AtomType

26+intAtomType = atomTypeForProxy (Proxy :: Proxy Int)

27+

28+boolAtomType :: AtomType

29+boolAtomType = atomTypeForProxy (Proxy :: Proxy Bool)

ProjectM36/Attribute.hs−4

@@ -28,10 +28,6 @@ atomType (Attribute _ atype) = atype

2828atomTypes :: Attributes -> V.Vector AtomType

2929atomTypes attrs = V.map atomType attrs

3030

31−isRelationAtomType :: AtomType -> Bool

32−isRelationAtomType (RelationAtomType _) = True

33−isRelationAtomType _ = False

34−

3531--hm- no error-checking here

3632addAttribute :: Attribute -> Attributes -> Attributes

3733addAttribute attr attrs = attrs `V.snoc` attr

ProjectM36/Base.hs+12−3

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

1−{-# LANGUAGE ExistentialQuantification,BangPatterns,GADTs,DeriveGeneric,GeneralizedNewtypeDeriving #-}

1+{-# LANGUAGE ExistentialQuantification,BangPatterns,GADTs,DeriveGeneric,DeriveAnyClass #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

23module ProjectM36.Base where

34import qualified Data.Map as M

45import qualified Data.HashSet as HS

@@ -83,7 +84,14 @@ instance Binary Day where

8384 (y,m,d) <- get :: Get (Integer, Int, Int)

8485 return $ fromGregorian y m d

8586

86−type AtomType = ConcreteTypeRep

87+data AtomType = AtomType ConcreteTypeRep |

88+ RelationAtomType Attributes |

89+ AnyAtomType --wildcard used in Atom Functions

90+ deriving (Eq,Show,NFData,Generic,Binary)

91+

92+isRelationAtomType :: AtomType -> Bool

93+isRelationAtomType (RelationAtomType _) = True

94+isRelationAtomType _ = False

8795

8896type AttributeName = StringType

8997

@@ -143,7 +151,7 @@ instance Eq RelationTuple where

143151

144152instance NFData RelationTuple where rnf = genericRnf

145153

146−data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic)

154+data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)

147155

148156instance Eq Relation where

149157 Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2

@@ -322,3 +330,4 @@ data PersistenceStrategy = NoPersistence | --no filesystem persistence/memory-on

322330 --CrashSafePersistence FilePath --full fsync- not yet implemented

323331 deriving (Show, Read)

324332

333+

ProjectM36/ConcreteTypeRep.hs−1

@@ -10,7 +10,6 @@ newtype ConcreteTypeRep = CTR { unCTR :: TypeRep } deriving (Eq, Typeable, Show,

1010

1111newtype SerialRep = SR (TyConRep, [SerialRep]) deriving(Binary)

1212

13−

1413type TyConRep = (String, String, String)

1514toTyConRep :: TyCon -> TyConRep

1615toTyConRep (TyCon _ pack modul name) = (pack, modul, name)

ProjectM36/Relation.hs+52−43

@@ -4,7 +4,8 @@ import qualified Data.Set as S

44import qualified Data.HashSet as HS

55import Control.Monad

66import qualified Data.Vector as V

7−

7+import ProjectM36.Atom

8+import Data.Typeable (cast)

89import ProjectM36.Base

910import ProjectM36.Tuple

1011import qualified ProjectM36.Attribute as A

@@ -25,10 +26,10 @@ attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs

2526

2627attributesForNames :: S.Set AttributeName -> Relation -> Attributes

2728attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs

28−

29+

2930atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

3031atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

31−

32+

3233mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation

3334mkRelationFromList attrs atomMatrix = do

3435 tupSet <- mkTupleSetFromList attrs atomMatrix

@@ -38,7 +39,7 @@ mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation

3839mkRelation attrs tupleSet = do

3940 --check that all tuples have the same keys

4041 --check that all tuples have keys (1-N) where N is the attribute count

41− case verifyTupleSet attrs tupleSet of

42+ case verifyTupleSet attrs tupleSet of

4243 Left err -> Left err

4344 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet

4445

@@ -61,8 +62,8 @@ singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Countable 1 the

6162 Nothing

6263

6364union :: Relation -> Relation -> Either RelationalError Relation

64−union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

65− if not (A.attributesEqual attrs1 attrs2)

65+union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

66+ if not (A.attributesEqual attrs1 attrs2)

6667 then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))

6768 else

6869 Right $ Relation attrs1 newtuples

@@ -70,7 +71,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

7071 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ (asList tupSet1) ++ (map (reorderTuple attrs1) (asList tupSet2))

7172

7273project :: AttributeNames -> Relation -> Either RelationalError Relation

73−project projectionAttrNames rel =

74+project projectionAttrNames rel =

7475 case AS.projectionAttributesForAttributeNames (attributes rel) projectionAttrNames of

7576 Left err -> Left err

7677 Right newAttrs -> relFold (folder newAttrs) (Right $ Relation newAttrs emptyTupleSet) rel

@@ -78,7 +79,7 @@ project projectionAttrNames rel =

7879 folder newAttrs tupleToProject acc = case acc of

7980 Left err -> Left err

8081 Right acc2 -> union acc2 (Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]))

81−

82+

8283rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

8384rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =

8485 if not attributeValid

@@ -93,7 +94,7 @@ rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =

9394 newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs

9495 newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)

9596 tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple

96−

97+

9798--the algebra should return a relation of one attribute and one row with the arity

9899arity :: Relation -> Int

99100arity (Relation attrs _) = A.arity attrs

@@ -113,7 +114,7 @@ cardinality (Relation _ tupSet) = Countable (length (asList tupSet))

113114{-

114115group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

115116group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do

116− nonGroupProjection <- project nonGroupAttrNames rel

117+ nonGroupProjection <- project nonGroupAttrNames rel

117118 relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection

118119 where

119120 newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr

@@ -121,35 +122,35 @@ group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do

121122 nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames

122123 --map the projection to add the additional new attribute

123124 --create the new attribute (a new relation) by filtering and projecting the tupleSet

124− folder tupleFromProjection acc = case acc of

125+ folder tupleFromProjection acc = case acc of

125126 Left err -> Left err

126127 Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))

127128-}

128−

129+

129130--algorithm: self-join with image relation

130131group :: AttributeNames -> AttributeName -> Relation -> Either RelationalError Relation

131132group groupAttrNames newAttrName rel = do

132133 let nonGroupAttrNames = AS.invertAttributeNames groupAttrNames

133− nonGroupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) nonGroupAttrNames

134+ nonGroupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) nonGroupAttrNames

134135 groupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) groupAttrNames

135136 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)

136137 matchingRelTuple tupIn = case imageRelationFor tupIn rel of

137− Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))

138+ Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (Atom rel2))

138139 Left _ -> undefined

139140 mogrifier tupIn = tupleExtend tupIn (matchingRelTuple tupIn)

140141 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes

141142 nonGroupProjection <- project nonGroupAttrNames rel

142143 relMogrify mogrifier newAttrs nonGroupProjection

143144

144−

145+

145146--help restriction function

146−--returns a subrelation of

147+--returns a subrelation of

147148restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation

148149restrictEq tuple rel = restrict rfilter rel

149150 where

150151 rfilter :: RelationTuple -> Bool

151152 rfilter tupleIn = tupleIntersection tuple tupleIn == tuple

152−

153+

153154-- unwrap relation-valued attribute

154155-- return error if relval attrs and nongroup attrs overlap

155156ungroup :: AttributeName -> Relation -> Either RelationalError Relation

@@ -165,8 +166,8 @@ ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of

165166 Right accRel -> do

166167 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn

167168 union accRel ungrouped

168−

169−--take an relval attribute name and a tuple and ungroup the relval

169+

170+--take an relval attribute name and a tuple and ungroup the relval

170171tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation

171172tupleUngroup relvalAttrName newAttrs tuple = do

172173 relvalRelation <- relationForAttributeName relvalAttrName tuple

@@ -177,17 +178,17 @@ tupleUngroup relvalAttrName newAttrs tuple = do

177178 folder tupleIn acc = case acc of

178179 Left err -> Left err

179180 Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])

180−

181+

181182attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes

182−attributesForRelval relvalAttrName (Relation attrs _) = do

183+attributesForRelval relvalAttrName (Relation attrs _) = do

183184 atomType <- A.atomTypeForAttributeName relvalAttrName attrs

184− case atomType of

185+ case atomType of

185186 (RelationAtomType relAttrs) -> Right relAttrs

186187 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

187188

188189restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation

189190--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset

190−restrict rfilter (Relation attrs tupset) = Right $ Relation attrs processedTupSet

191+restrict rfilter (Relation attrs tupset) = Right $ Relation attrs processedTupSet

191192 where

192193 processedTupSet = RelationTupleSet ((filter rfilter (asList tupset)) `P.using` (P.parListChunk 1000 P.rdeepseq))

193194

@@ -199,7 +200,7 @@ join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do

199200 newAttrs <- A.joinAttributes attrs1 attrs2

200201 let tupleSetJoiner accumulator tuple1 = do

201202 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2

202− return $ joinedTupSet ++ accumulator

203+ return $ joinedTupSet ++ accumulator

203204 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)

204205 newTupSet <- mkTupleSet newAttrs newTupSetList

205206 return $ Relation newAttrs newTupSet

@@ -213,10 +214,10 @@ relMap mapper (Relation attrs tupleSet) = do

213214 where

214215 typeMapCheck tupleIn = do

215216 let remappedTuple = mapper tupleIn

216− if tupleAttributes remappedTuple == tupleAttributes tupleIn

217− then Right remappedTuple

218− else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)

219−

217+ if tupleAttributes remappedTuple == tupleAttributes tupleIn

218+ then Right remappedTuple

219+ else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)

220+

220221relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

221222relMogrify mapper newAttributes (Relation _ tupSet) = do

222223 mkRelationFromTuples newAttributes newTuples

@@ -227,7 +228,7 @@ relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

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

228229

229230--image relation as defined by CJ Date

230−--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

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

231232

232233--check that matching attribute names have the same types

233234imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation

@@ -235,9 +236,9 @@ imageRelationFor matchTuple rel = do

235236 restricted <- restrictEq matchTuple rel --restrict across matching tuples

236237 let projectionAttrNames = AttributeNames $ A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)

237238 project projectionAttrNames restricted --project across attributes not in rel

238−

239+

239240--returns a relation-valued attribute image relation for each tuple in rel1

240−--algorithm:

241+--algorithm:

241242 {-

242243imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation

243244imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do

@@ -245,34 +246,42 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe

245246 where

246247 matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2

247248 newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2

248−

249+

249250 tupleSetJoiner tup1 acc = undefined

250251-}

251−

252+

252253-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long

253254-- this is useful for performance and resource usage testing

254255matrixRelation :: Int -> Int -> Either RelationalError Relation

255256matrixRelation attributeCount tupleCount = do

256− let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]

257− tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))

257+ let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) intAtomType) [0 .. attributeCount-1]

258+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> Atom tupleX))

258259 tuples = map (\c -> tuple c) [0 .. tupleCount]

259260 mkRelationFromTuples attrs tuples

260261

262+

263+castInt :: Atom -> Int

264+castInt (Atom atom) = case cast atom of

265+ Just i -> i

266+ Nothing -> error "int cast failure" -- the type checker must ensure this can never occur

267+

261268--used by sum atom function

262269relationSum :: Relation -> Atom

263−relationSum relIn = IntAtom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

270+relationSum relIn = Atom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

264271 where

265− newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0

272+ --extract Int from Atom

273+ newVal :: RelationTuple -> Int

274+ newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0

266275

267276relationCount :: Relation -> Atom

268−relationCount relIn = IntAtom $ relFold (\_ acc -> acc + 1) 0 relIn

277+relationCount relIn = Atom $ relFold (\_ acc -> acc + 1) (0::Int) relIn

269278

270279relationMax :: Relation -> Atom

271−relationMax relIn = IntAtom $ relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn

280+relationMax relIn = Atom $ relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn

272281 where

273− newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0

274−

282+ newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0

283+

275284relationMin :: Relation -> Atom

276−relationMin relIn = IntAtom $ relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn

285+relationMin relIn = Atom $ relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn

277286 where

278− newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0

287+ newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0

ProjectM36/Relation/Parse/CSV.hs+4−2

@@ -1,3 +1,4 @@

1+{-# LANGUAGE OverloadedStrings #-}

12module ProjectM36.Relation.Parse.CSV where

23--parse Relations from CSV

34import Data.Csv.Parser

@@ -15,6 +16,7 @@ import Data.HashMap.Lazy as HM

1516import qualified Data.List as L

1617import qualified Data.Text as T

1718import Data.Attoparsec.ByteString.Lazy

19+import Text.Read (readMaybe)

1820

1921data CsvImportError = CsvParseError String |

2022 AttributeMappingError RelationalError |

@@ -36,8 +38,8 @@ csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inStr

3638 headerSet = S.fromList (V.toList strHeader)

3739 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]

3840 makeTupleList tupMap = V.toList $ V.map (\attr -> makeAtom (A.atomType attr) (tupMap HM.! (A.attributeName attr))) attrs

39− makeAtom aType strIn = case atomFromString aType strIn of

40− Left err -> Left $ AttributeMappingError err

41+ makeAtom aType strIn = case readMaybe strIn of

42+ Nothing -> Left $ AttributeMappingError (ParseError

4143 Right atom -> Right atom

4244 case attrNameSet == headerSet of

4345 False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)

ProjectM36/Relation/Show/CSV.hs+12−15

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

12module ProjectM36.Relation.Show.CSV where

23import ProjectM36.Base

34import ProjectM36.Attribute

@@ -7,7 +8,8 @@ import qualified Data.ByteString.Lazy as BS

78import qualified Data.Vector as V

89import ProjectM36.Error

910import qualified Data.Text.Encoding as TE

10−{-# OPTIONS_GHC -fno-warn-orphans #-}

11+

12+

1113

1214--spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes

1315relationAsCSV :: Relation -> Either RelationalError BS.ByteString

@@ -20,25 +22,20 @@ relationAsCSV (Relation attrs tupleSet) = if relValAttrs /= [] then --check for

2022 where

2123 relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs

2224 bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs

23−

25+

2426{-

2527instance ToRecord RelationTuple where

2628 toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)

2729-}

2830

29−instance ToNamedRecord RelationTuple where

31+instance ToNamedRecord RelationTuple where

3032 toNamedRecord tuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= v) (tupleAssocs tuple)

31−

32−instance DefaultOrdered RelationTuple where

33+

34+instance DefaultOrdered RelationTuple where

3335 headerOrder tuple = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple)

34−

36+

3537instance ToField Atom where

36− toField (BoolAtom atom) = toField (if atom then "t" else "f")

37− toField (StringAtom atom) = toField atom

38− toField (IntAtom atom) = toField atom

39− toField (DateTimeAtom atom) = toField (show atom)

40− toField (DateAtom atom) = toField (show atom)

41− toField (DoubleAtom atom) = toField atom

42− toField (RelationAtom _) = error "Relation atoms cannot be used in CSV."

43−

44−

38+ toField (Atom val) = (TE.encodeUtf8 . toText) val

39+

40+

41+

ProjectM36/Relation/Show/Gnuplot.hs+21−20

@@ -3,6 +3,7 @@ module ProjectM36.Relation.Show.Gnuplot where

33import ProjectM36.Base

44import ProjectM36.Relation

55import ProjectM36.Tuple

6+import ProjectM36.Atom

67import qualified ProjectM36.Attribute as A

78import qualified Data.Vector as V

@@ -18,20 +19,20 @@ import qualified Graphics.Gnuplot.Advanced as GPA

1819--nested relations?

1920

2021data PlotError = InvalidAttributeCountError |

21− InvalidAttributeTypeError

22+ InvalidAttributeTypeError

2223 deriving (Show)

23−

24−--plotRelation :: Relation -> Either PlotError

24+

25+--plotRelation :: Relation -> Either PlotError

2526

2627intFromAtomIndex :: Int -> RelationTuple -> Int

27−intFromAtomIndex index tup = (\(IntAtom i) -> i) $ (tupleAtoms tup) V.! index

28+intFromAtomIndex index tup = (\i -> castInt i) $ (tupleAtoms tup) V.! index

2829

2930graph1DRelation :: Relation -> Plot2D.T Int Int

3031graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel

31−

32+

3233points1DRelation :: Relation -> [Int]

3334points1DRelation rel = relFold folder [] rel

34− where

35+ where

3536 folder tup acc = intFromAtomIndex 0 tup : acc

3637

3738graph2DRelation :: Relation -> Plot2D.T Int Int

@@ -45,8 +46,8 @@ points2DRelation rel = relFold folder [] rel

4546graph3DRelation :: Relation -> Plot3D.T Int Int Int

4647graph3DRelation rel = do

4748 Plot3D.cloud Graph3D.points $ points3DRelation rel

48−

49−points3DRelation :: Relation -> [(Int, Int, Int)]

49+

50+points3DRelation :: Relation -> [(Int, Int, Int)]

5051points3DRelation rel = relFold folder [] rel

5152 where

5253 folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup, intFromAtomIndex 2 tup) : acc

@@ -55,21 +56,21 @@ points3DRelation rel = relFold folder [] rel

5556sample1DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType]) [[IntAtom 2], [IntAtom 3]] of

5657 Right rel -> rel

5758 Left _ -> undefined

58−

59−sample2DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 2, IntAtom 3],

60− [IntAtom 2, IntAtom 4]] of

59+

60+sample2DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 2, IntAtom 3],

61+ [IntAtom 2, IntAtom 4]] of

6162 Right rel -> rel

6263 Left _ -> undefined

63−

64−sample3DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType, Attribute "z" IntAtomType]) [[IntAtom 2, IntAtom 3, IntAtom 3],

65− [IntAtom 2, IntAtom 4, IntAtom 4]] of

64+

65+sample3DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType, Attribute "z" IntAtomType]) [[IntAtom 2, IntAtom 3, IntAtom 3],

66+ [IntAtom 2, IntAtom 4, IntAtom 4]] of

6667 Right rel -> rel

6768 Left _ -> undefined

6869

6970-}

70−

71+

7172plotRelation :: Relation -> IO (Maybe PlotError)

72−plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in

73+plotRelation rel = let attrTypes = V.replicate (arity rel) intAtomType in

7374 if attrTypes /= A.atomTypes (attributes rel) then

7475 return $ Just InvalidAttributeTypeError

7576 else do

@@ -78,14 +79,14 @@ plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in

7879 2 -> (GPA.plotDefault $ graph2DRelation rel) >> return Nothing

7980 3 -> (GPA.plotDefault $ graph3DRelation rel) >> return Nothing

8081 _ -> return $ Just InvalidAttributeCountError

81−

82−

82+

83+

8384{-

8485--PNG

8586savePlottedRelation :: String -> Relation -> IO ()

86−savePlottedRelation path rel = case plotRelation rel of

87+savePlottedRelation path rel = case plotRelation rel of

8788 Left err -> putStrLn (show err)

8889 Right (Left g2d) -> plot' [] (PNG path) g2d >> return ()

8990 Right (Right g3d) -> plot' [] (PNG path) g3d >> return ()

90−-}

91+-}

9192

ProjectM36/Relation/Show/HTML.hs+4−9

@@ -3,7 +3,6 @@ module ProjectM36.Relation.Show.HTML where

33import ProjectM36.Base

44import ProjectM36.Relation

55import ProjectM36.Tuple

6−import qualified Data.HashSet as HS

76import qualified Data.List as L

87import ProjectM36.Attribute

98import Data.Text (append, Text, pack)

@@ -12,7 +11,7 @@ import qualified Data.Text.IO as TIO

1211

1312attributesAsHTML :: Attributes -> Text

1413attributesAsHTML attrs = "<tr>" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "</tr>"

15− where

14+ where

1615 oneAttrHTML attrName = "<th>" `append` attrName `append` "</th>"

1716 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

1817

@@ -25,14 +24,10 @@ writeHTML :: Text -> IO ()

2524writeHTML = TIO.writeFile "/home/agentm/rel.html"

2625

2726writeRel :: Relation -> IO ()

28−writeRel = writeHTML . relationAsHTML

27+writeRel = writeHTML . relationAsHTML

2928

3029atomAsHTML :: Atom -> Text

31−atomAsHTML (StringAtom atom) = atom

32−atomAsHTML (IntAtom int) = pack (show int)

33−atomAsHTML (RelationAtom rel) = relationAsHTML rel

34−atomAsHTML (BoolAtom bool) = pack (show bool)

35−atomAsHTML (DateTimeAtom dt) = pack (show dt)

30+atomAsHTML (Atom atom) = toText atom

3631

3732tupleAsHTML :: RelationTuple -> Text

3833tupleAsHTML tuple = "<tr>" `append` T.concat (L.map tupleFrag (tupleSortedAssocs tuple)) `append` "</tr>"

@@ -40,6 +35,6 @@ tupleAsHTML tuple = "<tr>" `append` T.concat (L.map tupleFrag (tupleSortedAssocs

4035 tupleFrag tup = "<td>" `append` atomAsHTML (snd tup) `append` "</td>"

4136

4237tupleSetAsHTML :: RelationTupleSet -> Text

43−tupleSetAsHTML tupSet = HS.foldr folder "" tupSet

38+tupleSetAsHTML tupSet = foldr folder "" (asList tupSet)

4439 where

4540 folder tuple acc = acc `append` tupleAsHTML tuple

ProjectM36/Relation/Show/Term.hs+18−22

@@ -5,9 +5,9 @@ import ProjectM36.Base

55import ProjectM36.Tuple

66import ProjectM36.Relation

77import qualified Data.Set as S

8−import qualified Data.HashSet as HS

98import qualified Data.List as L

109import qualified Data.Text as T

10+import Data.Typeable (cast)

1111

1212boxV :: StringType

1313boxV = "│"

@@ -44,15 +44,15 @@ dboxR = "╡"

4444

4545class TermSize a where

4646 termLength :: a -> Int

47−

48−--represent a relation as a table similar to those drawn by Date

47+

48+--represent a relation as a table similar to those drawn by Date

4949type Cell = StringType

5050type Table = ([Cell], [[Cell]]) --header, body

5151

5252addRow :: [Cell] -> Table -> Table

5353addRow cells (header,body) = (header, body ++ [cells])

5454

55−--calculate maximum per-row and per-column sizes

55+--calculate maximum per-row and per-column sizes

5656

5757cellLocations :: Table -> ([Int],[Int]) --column size, row size

5858cellLocations tab@(header, _) = (maxWidths, maxHeights)

@@ -63,18 +63,18 @@ cellLocations tab@(header, _) = (maxWidths, maxHeights)

6363 rowHeights = map snd cellSizeMatrix

6464 maxHeights = map (\l -> if length l == 0 then 0 else L.maximumBy compare l) rowHeights

6565 mergeMax a b = map (\(c,d) -> max c d) (zip a b)

66−

66+

6767--the normal "lines" function returns an empty list for an empty string which is not what we want

6868breakLines :: StringType -> [StringType]

6969breakLines "" = [""]

7070breakLines x = T.lines x

71−

72−cellSizes :: Table -> [([Int], [Int])]

71+

72+cellSizes :: Table -> [([Int], [Int])]

7373cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows

7474 where

7575 maxRowWidth row = if length (lengths row) == 0 then

7676 0

77− else

77+ else

7878 L.maximumBy compare (lengths row)

7979 lengths row = map T.length (breakLines row)

8080 allRows = [header] ++ body

@@ -90,21 +90,17 @@ relationAsTable rel@(Relation _ tupleSet) = (header, body)

9090 Left _ -> "?"

9191 Right atom -> showAtom atom

9292 ) oAttrs]

93−

94−showAtom :: Atom -> StringType

95−showAtom (StringAtom atom) = atom

96−showAtom (IntAtom atom) = T.pack $ show atom

97−showAtom (RelationAtom rel) = renderTable $ relationAsTable rel

98−showAtom (BoolAtom bool) = T.pack $ if bool then "t" else "f"

99−showAtom (DateTimeAtom dt) = T.pack $ show dt

100−showAtom (DateAtom d) = T.pack $ show d

101−showAtom (DoubleAtom d) = T.pack $ show d

93+

94+showAtom :: Atom -> StringType

95+showAtom (Atom atom) = case cast atom of

96+ Just rel -> renderTable $ relationAsTable rel

97+ Nothing -> T.pack $ show atom

10298

10399renderTable :: Table -> StringType

104100renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs

105101 where

106− cellLocs = cellLocations table

107−

102+ cellLocs = cellLocations table

103+

108104renderHeader :: Table -> [Int] -> StringType

109105renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar

110106 where

@@ -112,7 +108,7 @@ renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHead

112108 renderHeaderNames = renderRow header columnLocations 1 boxV

113109 renderBottomBar = if length body == 0 then ""

114110 else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n"

115−

111+

116112renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType

117113renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end

118114

@@ -123,7 +119,7 @@ leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then

123119 paddedLines !! lineNum

124120 where

125121 paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)

126−

122+

127123renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType

128124renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]

129125 where

@@ -140,7 +136,7 @@ renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar

140136

141137orderedAttributeNames :: Relation -> [AttributeName]

142138orderedAttributeNames = S.toAscList . attributeNames

143−

139+

144140repeatString :: Int -> StringType -> StringType

145141repeatString c s = T.concat (take c (repeat s))

146142

ProjectM36/RelationalExpression.hs+150−127

@@ -15,6 +15,8 @@ import qualified Data.Set as S

1515import Control.Monad.State hiding (join)

1616import Data.Maybe

1717import Data.Either

18+import Data.Typeable (cast)

19+import qualified Data.Text as T

1820

1921--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

2022evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

@@ -22,11 +24,11 @@ evalRelationalExpr (RelationVariable name) = do

2224 relvarTable <- liftM relationVariables get

2325 return $ case M.lookup name relvarTable of

2426 Just res -> Right res

25− Nothing -> Left $ RelVarNotDefinedError name

27+ Nothing -> Left $ RelVarNotDefinedError name

2628

2729evalRelationalExpr (Project attrNames expr) = do

2830 rel <- evalRelationalExpr expr

29− case rel of

31+ case rel of

3032 Right rel2 -> return $ project attrNames rel2

3133 Left err -> return $ Left err

3234

@@ -47,71 +49,71 @@ evalRelationalExpr (Join exprA exprB) = do

4749 Right relA2 -> case relB of

4850 Left err -> return $ Left err

4951 Right relB2 -> return $ join relA2 relB2

50−

52+

5153evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

5254 case mkRelation attributeSet tupleSet of

5355 Right rel -> return $ Right rel

5456 Left err -> return $ Left err

55−

57+

5658evalRelationalExpr (ExistingRelation rel) = return (Right rel)

57−

59+

5860evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

5961 evald <- evalRelationalExpr relExpr

6062 case evald of

6163 Right rel -> return $ rename oldAttrName newAttrName rel

6264 Left err -> return $ Left err

63−

65+

6466evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do

6567 evald <- evalRelationalExpr relExpr

66− case evald of

68+ case evald of

6769 Right rel -> return $ group oldAttrNameSet newAttrName rel

6870 Left err -> return $ Left err

69−

71+

7072evalRelationalExpr (Ungroup attrName relExpr) = do

7173 evald <- evalRelationalExpr relExpr

7274 case evald of

7375 Right rel -> return $ ungroup attrName rel

7476 Left err -> return $ Left err

75−

77+

7678evalRelationalExpr (Restrict predicateExpr relExpr) = do

7779 evald <- evalRelationalExpr relExpr

7880 context <- get

79− case evald of

81+ case evald of

8082 Left err -> return $ Left err

8183 Right rel -> case predicateRestrictionFilter context (attributes rel) predicateExpr of

8284 Left err -> return $ Left err

8385 Right filterfunc -> return $ restrict filterfunc rel

84−

86+

8587evalRelationalExpr (Equals relExprA relExprB) = do

8688 evaldA <- evalRelationalExpr relExprA

8789 evaldB <- evalRelationalExpr relExprB

8890 case evaldA of

8991 Left err -> return $ Left err

90− Right relA -> case evaldB of

92+ Right relA -> case evaldB of

9193 Left err -> return $ Left err

9294 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse

93−

95+

9496--warning: copy-pasta from above- refactor

9597evalRelationalExpr (NotEquals relExprA relExprB) = do

9698 evaldA <- evalRelationalExpr relExprA

9799 evaldB <- evalRelationalExpr relExprB

98100 case evaldA of

99101 Left err -> return $ Left err

100− Right relA -> case evaldB of

102+ Right relA -> case evaldB of

101103 Left err -> return $ Left err

102104 Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse

103−

104−-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

105−evalRelationalExpr (Extend tupleExpression relExpr) = do

105+

106+-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

107+evalRelationalExpr (Extend tupleExpression relExpr) = do

106108 evald <- evalRelationalExpr relExpr

107109 context <- get

108− case evald of

110+ case evald of

109111 Left err -> return $ Left err

110112 Right rel -> do

111113 case tupleExpressionProcessor rel tupleExpression context of

112114 Left err -> return $ Left err

113115 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel

114−

116+

115117emptyDatabaseContext :: DatabaseContext

116118emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

117119 relationVariables = M.empty,

@@ -126,8 +128,8 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

126128 }

127129

128130dateExamples :: DatabaseContext

129−dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

130− relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

131+dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

132+ relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

131133 atomFunctions = basicAtomFunctions}

132134 where

133135 dateRelVars = M.fromList [("S", suppliers),

@@ -141,77 +143,85 @@ dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

141143 ("SP_pkey", simplePKey ["S#", "P#"] "SP")

142144 ]

143145 simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)

144−

145−suppliersRel :: Relation

146+

147+--textAtom shortcut

148+tAtom :: T.Text -> Atom

149+tAtom t = Atom t

150+

151+--intAtom shortcut

152+iAtom ::Int -> Atom

153+iAtom i = Atom i

154+

155+suppliersRel :: Relation

146156suppliersRel = case mkRelationFromList attrs atomMatrix of

147157 Left _ -> undefined

148158 Right rel -> rel

149159 where

150− attrs = A.attributesFromList [Attribute "S#" StringAtomType,

151− Attribute "SNAME" StringAtomType,

152− Attribute "STATUS" IntAtomType,

153− Attribute "CITY" StringAtomType]

160+ attrs = A.attributesFromList [Attribute "S#" stringAtomType,

161+ Attribute "SNAME" stringAtomType,

162+ Attribute "STATUS" intAtomType,

163+ Attribute "CITY" stringAtomType]

154164 atomMatrix = [

155− [StringAtom "S1", StringAtom "Smith", IntAtom 20, StringAtom "London"],

156− [StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"],

157− [StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],

158− [StringAtom "S4", StringAtom "Clark", IntAtom 20, StringAtom "London"],

159− [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]

160−

165+ [tAtom "S1", tAtom "Smith", iAtom 20, tAtom "London"],

166+ [tAtom "S2", tAtom "Jones", iAtom 10, tAtom "Paris"],

167+ [tAtom "S3", tAtom "Blake", iAtom 30, tAtom "Paris"],

168+ [tAtom "S4", tAtom "Clark", iAtom 20, tAtom "London"],

169+ [tAtom "S5", tAtom "Adams", iAtom 30, tAtom "Athens"]]

170+

161171supplierProductsRel :: Relation

162172supplierProductsRel = case mkRelationFromList attrs matrix of

163173 Left _ -> undefined

164174 Right rel -> rel

165175 where

166− attrs = A.attributesFromList [Attribute "S#" StringAtomType,

167− Attribute "P#" StringAtomType,

168− Attribute "QTY" IntAtomType]

176+ attrs = A.attributesFromList [Attribute "S#" stringAtomType,

177+ Attribute "P#" stringAtomType,

178+ Attribute "QTY" intAtomType]

169179 matrix = [

170− [StringAtom "S1", StringAtom "P1", IntAtom 300],

171− [StringAtom "S1", StringAtom "P2", IntAtom 200],

172− [StringAtom "S1", StringAtom "P3", IntAtom 400],

173− [StringAtom "S1", StringAtom "P4", IntAtom 200],

174− [StringAtom "S1", StringAtom "P5", IntAtom 100],

175− [StringAtom "S1", StringAtom "P6", IntAtom 100],

176− [StringAtom "S2", StringAtom "P1", IntAtom 300],

177− [StringAtom "S2", StringAtom "P2", IntAtom 400],

178− [StringAtom "S3", StringAtom "P2", IntAtom 200],

179− [StringAtom "S4", StringAtom "P2", IntAtom 200],

180− [StringAtom "S4", StringAtom "P4", IntAtom 300],

181− [StringAtom "S4", StringAtom "P5", IntAtom 400]

180+ [tAtom "S1", tAtom "P1", iAtom 300],

181+ [tAtom "S1", tAtom "P2", iAtom 200],

182+ [tAtom "S1", tAtom "P3", iAtom 400],

183+ [tAtom "S1", tAtom "P4", iAtom 200],

184+ [tAtom "S1", tAtom "P5", iAtom 100],

185+ [tAtom "S1", tAtom "P6", iAtom 100],

186+ [tAtom "S2", tAtom "P1", iAtom 300],

187+ [tAtom "S2", tAtom "P2", iAtom 400],

188+ [tAtom "S3", tAtom "P2", iAtom 200],

189+ [tAtom "S4", tAtom "P2", iAtom 200],

190+ [tAtom "S4", tAtom "P4", iAtom 300],

191+ [tAtom "S4", tAtom "P5", iAtom 400]

182192 ]

183−

184−productsRel :: Relation

193+

194+productsRel :: Relation

185195productsRel = case mkRelationFromList attrs matrix of

186196 Left _ -> undefined

187197 Right rel -> rel

188198 where

189− attrs = A.attributesFromList [Attribute "P#" StringAtomType,

190− Attribute "PNAME" StringAtomType,

191− Attribute "COLOR" StringAtomType,

192− Attribute "WEIGHT" IntAtomType,

193− Attribute "CITY" StringAtomType]

194− matrix = [

195− [StringAtom "P1", StringAtom "Nut", StringAtom "Red", IntAtom 12, StringAtom "London"],

196− [StringAtom "P2", StringAtom "Bolt", StringAtom "Green", IntAtom 17, StringAtom "Paris"],

197− [StringAtom "P3", StringAtom "Screw", StringAtom "Blue", IntAtom 17, StringAtom "Oslo"],

198− [StringAtom "P4", StringAtom "Screw", StringAtom "Red", IntAtom 14, StringAtom "London"],

199− [StringAtom "P5", StringAtom "Cam", StringAtom "Blue", IntAtom 12, StringAtom "Paris"],

200− [StringAtom "P6", StringAtom "Cog", StringAtom "Red", IntAtom 19, StringAtom "London"]

199+ attrs = A.attributesFromList [Attribute "P#" stringAtomType,

200+ Attribute "PNAME" stringAtomType,

201+ Attribute "COLOR" stringAtomType,

202+ Attribute "WEIGHT" intAtomType,

203+ Attribute "CITY" stringAtomType]

204+ matrix = [

205+ [tAtom "P1", tAtom "Nut", tAtom "Red", iAtom 12, tAtom "London"],

206+ [tAtom "P2", tAtom "Bolt", tAtom "Green", iAtom 17, tAtom "Paris"],

207+ [tAtom "P3", tAtom "Screw", tAtom "Blue", iAtom 17, tAtom "Oslo"],

208+ [tAtom "P4", tAtom "Screw", tAtom "Red", iAtom 14, tAtom "London"],

209+ [tAtom "P5", tAtom "Cam", tAtom "Blue", iAtom 12, tAtom "Paris"],

210+ [tAtom "P6", tAtom "Cog", tAtom "Red", iAtom 19, tAtom "London"]

201211 ]

202−

203−--helper function to process relation variable creation/assignment

212+

213+--helper function to process relation variable creation/assignment

204214setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

205−setRelVar relVarName rel = do

215+setRelVar relVarName rel = do

206216 currentContext <- get

207217 let newRelVars = M.insert relVarName rel $ relationVariables currentContext

208218 let potentialContext = DatabaseContext (inclusionDependencies currentContext) newRelVars (atomFunctions currentContext)

209219 case checkConstraints potentialContext of

210220 Just err -> return $ Just err

211− Nothing -> do

221+ Nothing -> do

212222 put potentialContext

213223 return Nothing

214−

224+

215225-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation

216226deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)

217227deleteRelVar relVarName = do

@@ -223,31 +233,31 @@ deleteRelVar relVarName = do

223233evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)

224234evalContextExpr (Define relVarName attrs) = do

225235 relvars <- liftM relationVariables get

226− case M.member relVarName relvars of

236+ case M.member relVarName relvars of

227237 True -> return (Just (RelVarAlreadyDefinedError relVarName))

228238 False -> setRelVar relVarName emptyRelation

229239 where

230240 emptyRelation = Relation attrs emptyTupleSet

231−

241+

232242evalContextExpr (Undefine relVarName) = do

233243 deleteRelVar relVarName

234−

244+

235245evalContextExpr (Assign relVarName expr) = do

236246 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it

237247 relVarTable <- liftM relationVariables get

238248 let existingRelVar = M.lookup relVarName relVarTable

239− value <- evalRelationalExpr expr

240− case value of

249+ value <- evalRelationalExpr expr

250+ case value of

241251 Left err -> return $ Just err

242− Right rel -> case existingRelVar of

252+ Right rel -> case existingRelVar of

243253 Nothing -> setRelVar relVarName rel

244254 Just existingRel -> let expectedAttributes = attributes existingRel

245255 foundAttributes = attributes rel in

246− if A.attributesEqual expectedAttributes foundAttributes then

256+ if A.attributesEqual expectedAttributes foundAttributes then

247257 setRelVar relVarName rel

248258 else

249259 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)

250−

260+

251261evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName))

252262

253263--assign empty rel until restriction is implemented

@@ -256,16 +266,16 @@ evalContextExpr (Delete relVarName predicate) = do

256266 case updatedRel of

257267 Left err -> return $ Just err

258268 Right rel -> setRelVar relVarName rel

259−

269+

260270--union of restricted+updated portion and the unrestricted+unupdated portion

261271evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do

262272 currstate <- get

263− let relVarTable = relationVariables currstate

273+ let relVarTable = relationVariables currstate

264274 case M.lookup relVarName relVarTable of

265275 Nothing -> return $ Just (RelVarNotDefinedError relVarName)

266276 Just rel -> case predicateRestrictionFilter currstate (attributes rel) restrictionPredicateExpr of

267277 Left err -> return $ Just err

268− Right predicateFunc -> do

278+ Right predicateFunc -> do

269279 case makeUpdatedRel rel of

270280 Left err -> return $ Just err

271281 Right updatedRel -> setRelVar relVarName updatedRel

@@ -289,8 +299,8 @@ evalContextExpr (AddInclusionDependency newDepName newDep) = do

289299 Nothing -> do

290300 put potentialContext

291301 return Nothing

292−

293−evalContextExpr (RemoveInclusionDependency depName) = do

302+

303+evalContextExpr (RemoveInclusionDependency depName) = do

294304 currContext <- get

295305 let currDeps = inclusionDependencies currContext

296306 newDeps = M.delete depName currDeps

@@ -307,13 +317,13 @@ evalContextExpr (MultipleExpr exprs) = do

307317 case catMaybes evald of

308318 [] -> return $ Nothing

309319 err:_ -> return $ Just err

310−

311−-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples

320+

321+-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples

312322--evalRelVarExpr (Update relVarName updateMap) = do

313323

314324--run verification on all constraints

315325checkConstraints :: DatabaseContext -> Maybe RelationalError

316−checkConstraints context = case failures of

326+checkConstraints context = case failures of

317327 [] -> Nothing

318328 l:_ -> Just l

319329 where

@@ -321,13 +331,13 @@ checkConstraints context = case failures of

321331 deps = inclusionDependencies context

322332 eval expr = runState (evalRelationalExpr expr) context

323333 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = case evaldSub of

324− (Left err, _) -> Just err

334+ (Left err, _) -> Just err

325335 (Right relSub, _) -> case evaldSuper of

326336 (Left err, _) -> Just err

327337 (Right relSuper, _) -> case union relSub relSuper of

328338 Left err -> Just err

329− Right resultRel -> if resultRel == relSuper then

330− Nothing

339+ Right resultRel -> if resultRel == relSuper then

340+ Nothing

331341 else

332342 Just $ InclusionDependencyCheckError depName

333343 where

@@ -339,32 +349,32 @@ checkConstraint :: InclusionDependency -> DatabaseState (Maybe RelationalError)

339349checkConstraint (InclusionDependency name subDep superDep) = do

340350 evalSub <- evalRelationalExpr subDep

341351 evalSuper <- evalRelationalExpr superDep

342− case evalSub of

352+ case evalSub of

343353 Left err -> Just err

344− Right relSub

354+ Right relSub

345355 result <- liftM2 union evalSub evalSuper

346356 return $ Nothing

347357-}

348−

358+

349359-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing

350360-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation

351−

361+

352362typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

353363typeForRelationalExpr expr = do

354364 currstate <- get

355365 --replace the relationVariables context element with a cloned set of relation devoid of tuples

356366 put $ contextWithEmptyTupleSets currstate

357367 evalRelationalExpr expr

358−

359−--returns a database context with all tuples removed

368+

369+--returns a database context with all tuples removed

360370--this is useful for type checking and optimization

361371contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

362372contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs

363373 where

364− incDeps = inclusionDependencies contextIn

374+ incDeps = inclusionDependencies contextIn

365375 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)

366376 funcs = atomFunctions contextIn

367−

377+

368378{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

369379predicateRestrictionFilter :: DatabaseContext -> Attributes -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)

370380predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do

@@ -376,9 +386,9 @@ predicateRestrictionFilter context attrs (OrPredicate expr1 expr2) = do

376386 expr1v <- predicateRestrictionFilter context attrs expr1

377387 expr2v <- predicateRestrictionFilter context attrs expr2

378388 return $ \x -> expr1v x || expr2v x

379−

389+

380390predicateRestrictionFilter _ _ TruePredicate = Right $ \_ -> True

381−

391+

382392predicateRestrictionFilter context attrs (NotPredicate expr) = do

383393 exprv <- predicateRestrictionFilter context attrs expr

384394 return $ \x -> not (exprv x)

@@ -386,12 +396,12 @@ predicateRestrictionFilter context attrs (NotPredicate expr) = do

386396predicateRestrictionFilter context _ (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of

387397 (Left err, _) -> Left err

388398 (Right rel, _) -> if rel == relationTrue then

389− Right $ \_ -> True

399+ Right $ \_ -> True

390400 else if rel == relationFalse then

391− Right $ \_ -> False

401+ Right $ \_ -> False

392402 else

393403 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"

394−

404+

395405predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName atomExpr) = do

396406 attr <- A.attributeForName attrName attrs

397407 atomExprType <- typeFromAtomExpr attrs context atomExpr

@@ -400,20 +410,20 @@ predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName at

400410 else

401411 Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of

402412 Left _ -> False

403− Right atomIn ->

413+ Right atomIn ->

404414 case evalAtomExpr tupleIn context atomExpr of

405415 Left _ -> False

406416 Right atomCmp -> atomCmp == atomIn

407−

408−-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

409−predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do

417+

418+-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

419+predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do

410420 aType <- typeFromAtomExpr attrs context atomExpr

411− if aType /= BoolAtomType then

412− Left $ AtomTypeMismatchError aType BoolAtomType

421+ if aType /= boolAtomType then

422+ Left $ AtomTypeMismatchError aType boolAtomType

413423 else

414424 Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of

415425 Left _ -> False

416− Right boolAtomValue -> boolAtomValue == BoolAtom True)

426+ Right boolAtomValue -> boolAtomValue == Atom True)

417427

418428tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

419429tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then

@@ -422,7 +432,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName

422432 Right rel

423433

424434tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)

425−tupleExpressionProcessor relIn

435+tupleExpressionProcessor relIn

426436 (AttributeTupleExpr newAttrName atomExpr) context = do

427437 _ <- tupleExprCheckNewAttrName newAttrName relIn

428438 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr

@@ -445,12 +455,12 @@ evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

445455 return $ (atomFunc func) evaldArgs

446456evalAtomExpr _ context (RelationAtomExpr relExpr) = do

447457 relAtom <- evalState (evalRelationalExpr relExpr) context

448− return $ RelationAtom relAtom

458+ return $ Atom relAtom

449459

450460typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType

451461typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs

452462typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)

453−typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do

463+typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do

454464 let funcs = atomFunctions context

455465 func <- atomFunctionForName funcName funcs

456466 return $ last (atomFuncType func)

@@ -481,49 +491,62 @@ verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do

481491 (Left err, _) -> Left err

482492 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))

483493

494+--not safe to use without upfront type-checking

495+castRelation :: Atom -> Relation

496+castRelation (Atom atom) = case cast atom of

497+ Just rel -> rel

498+ Nothing -> error "castRelation failure"

499+

500+unsafeCast :: (Atomable a) => Atom -> a

501+unsafeCast (Atom atom) = case cast atom of

502+ Just x -> x

503+ Nothing -> error "unsafeCast failed"

504+

484505basicAtomFunctions :: AtomFunctions

485506basicAtomFunctions = HS.fromList [

486507 --match on any relation type

487− AtomFunction "add" [IntAtomType, IntAtomType, IntAtomType] (\(i1:i2:_) -> (\(IntAtom a) (IntAtom b) -> IntAtom (a + b)) i1 i2),

508+ AtomFunction { atomFuncName = "add",

509+ atomFuncType = [intAtomType, intAtomType, intAtomType],

510+ atomFunc = (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},

488511 AtomFunction { atomFuncName = "id",

489512 atomFuncType = [AnyAtomType, AnyAtomType],

490513 atomFunc = (\(x:_) -> x)},

491514 AtomFunction { atomFuncName = "sum",

492− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

493− atomFunc = (\((RelationAtom relIn):_) -> relationSum relIn)},

515+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

516+ atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},

494517 AtomFunction { atomFuncName = "count",

495− atomFuncType = foldAtomFuncType AnyAtomType IntAtomType,

496− atomFunc = (\((RelationAtom relIn):_) -> relationCount relIn)},

518+ atomFuncType = foldAtomFuncType AnyAtomType intAtomType,

519+ atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},

497520 AtomFunction { atomFuncName = "max",

498− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

499− atomFunc = (\((RelationAtom relIn):_) -> relationMax relIn)},

521+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

522+ atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},

500523 AtomFunction { atomFuncName = "min",

501− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

502− atomFunc = (\((RelationAtom relIn):_) -> relationMin relIn)},

524+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

525+ atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},

503526 AtomFunction { atomFuncName = "lt",

504− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

527+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

505528 atomFunc = intAtomFuncLessThan False},

506529 AtomFunction { atomFuncName = "lte",

507− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

530+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

508531 atomFunc = intAtomFuncLessThan True},

509532 AtomFunction { atomFuncName = "gte",

510− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

533+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

511534 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},

512535 AtomFunction { atomFuncName = "gt",

513− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

536+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

514537 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},

515538 AtomFunction { atomFuncName = "not",

516− atomFuncType = [BoolAtomType, BoolAtomType],

539+ atomFuncType = [boolAtomType, boolAtomType],

517540 atomFunc = boolAtomNot}

518541 ]

519542

520543intAtomFuncLessThan :: Bool -> [Atom] -> Atom

521−intAtomFuncLessThan equality (iatom1:iatom2:_) = (\(IntAtom i1) (IntAtom i2) -> BoolAtom $ i1 `op` i2) iatom1 iatom2

544+intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2

522545 where

523546 op = if equality then (<=) else (<)

524−intAtomFuncLessThan _ _= BoolAtom False

547+intAtomFuncLessThan _ _= Atom False

525548

526549boolAtomNot :: [Atom] -> Atom

527−boolAtomNot (BoolAtom bool:_) = BoolAtom $ not bool

528−boolAtomNot _ = BoolAtom False

550+boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)

551+boolAtomNot _ = Atom False

529552

ProjectM36/TransactionGraph.hs+36−35

@@ -6,6 +6,7 @@ import ProjectM36.Transaction

66import ProjectM36.Relation

77import ProjectM36.TupleSet

88import ProjectM36.Tuple

9+import ProjectM36.Atom

910import qualified Data.Vector as V

1011import qualified ProjectM36.Attribute as A

1112import qualified Data.UUID as U

@@ -19,9 +20,9 @@ data TransactionGraphOperator = JumpToHead HeadName |

1920 JumpToTransaction U.UUID |

2021 Branch HeadName |

2122 Commit |

22− Rollback

23+ Rollback

2324

24−data ROTransactionGraphOperator = ShowGraph

25+data ROTransactionGraphOperator = ShowGraph

2526

2627bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph

2728bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions

@@ -29,10 +30,10 @@ bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bo

2930 bootstrapHeads = M.singleton "master" freshTransaction

3031 freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context

3132 bootstrapTransactions = S.singleton freshTransaction

32−

33−emptyTransactionGraph :: TransactionGraph

33+

34+emptyTransactionGraph :: TransactionGraph

3435emptyTransactionGraph = TransactionGraph M.empty S.empty

35−

36+

3637transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction

3738transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads

3839

@@ -43,7 +44,7 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi

4344 Just $ (head . M.keys) matchingTrans

4445 where

4546 matchingTrans = M.filter (transaction ==) heads

46−

47+

4748transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction

4849transactionForUUID uuid graph = if S.null matchingTrans then

4950 Left $ NoSuchTransactionError uuid

@@ -52,15 +53,15 @@ transactionForUUID uuid graph = if S.null matchingTrans then

5253 where

5354 matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)

5455

55−transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)

56+transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)

5657transactionsForUUIDs uuidSet graph = do

5758 transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)

5859 return (S.fromList transList)

59−

60+

6061isRootTransaction :: Transaction -> TransactionGraph -> Bool

6162isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID

6263isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False

63−

64+

6465-- the first transaction has no parent - all other do have parents- merges have two parents

6566parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

6667parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do

@@ -68,8 +69,8 @@ parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do

6869 return (S.singleton trans)

6970

7071parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph

71−

72−

72+

73+

7374childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

7475childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children

7576childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children

@@ -82,7 +83,7 @@ addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBra

8283--adds a disconnected transaction to a transaction graph at some head

8384addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

8485addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do

85− parentTrans <- transactionForUUID parentUUID graph

86+ parentTrans <- transactionForUUID parentUUID graph

8687 addTransactionToGraph headName parentTrans newUUID context graph

8788

8889-- create a new transaction on "newHeadName" with the branchPointTrans

@@ -101,38 +102,38 @@ validateGraph graph@(TransactionGraph _ transSet) = do

101102 --check that all UUIDs are unique in the graph

102103 --uuids = map transactionUUID transSet

103104 --check that all heads appear in the transSet

104− --check that all forward and backward links are in place

105+ --check that all forward and backward links are in place

105106 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)

106107 mapM (walkChildTransactions S.empty graph) (S.toList transSet)

107−

108+

108109--verify that all parent links exist and that all children exist

109110--maybe verify that all parents end at UUID nil and all children end at leaves

110111walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError

111112walkParentTransactions seenTransSet graph trans =

112− let transUUID = transactionUUID trans in

113− if transUUID == U.nil then

113+ let transUUID = transactionUUID trans in

114+ if transUUID == U.nil then

114115 Nothing

115116 else if S.member transUUID seenTransSet then

116117 Just $ TransactionGraphCycleError transUUID

117− else

118+ else

118119 let parentTransSetOrError = parentTransactions trans graph in

119− case parentTransSetOrError of

120+ case parentTransSetOrError of

120121 Left err -> Just err

121− Right parentTransSet -> do

122+ Right parentTransSet -> do

122123 walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)

123124 case walk of

124125 err:_ -> Just err

125126 _ -> Nothing

126−

127+

127128--refactor: needless duplication in these two functions

128129walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError

129−walkChildTransactions seenTransSet graph trans =

130− let transUUID = transactionUUID trans in

130+walkChildTransactions seenTransSet graph trans =

131+ let transUUID = transactionUUID trans in

131132 if childTransactions trans graph == Right S.empty then

132133 Nothing

133134 else if S.member transUUID seenTransSet then

134135 Just $ TransactionGraphCycleError transUUID

135− else

136+ else

136137 let childTransSetOrError = childTransactions trans graph in

137138 case childTransSetOrError of

138139 Left err -> Just err

@@ -209,24 +210,24 @@ evalROGraphOp discon graph ShowGraph = do

209210 graphRel <- graphAsRelation discon graph

210211 return graphRel

211212

212−--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction

213−graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation

213+--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction

214+graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation

214215graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do

215216 tupleMatrix <- mapM tupleGenerator (S.toList transSet)

216217 mkRelationFromList attrs tupleMatrix

217218 where

218− attrs = A.attributesFromList [Attribute "id" StringAtomType,

219+ attrs = A.attributesFromList [Attribute "id" stringAtomType,

219220 Attribute "parents" (RelationAtomType parentAttributes),

220− Attribute "current" BoolAtomType,

221− Attribute "head" StringAtomType

221+ Attribute "current" boolAtomType,

222+ Attribute "head" stringAtomType

222223 ]

223− parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]

224+ parentAttributes = A.attributesFromList [Attribute "id" stringAtomType]

224225 tupleGenerator transaction = case transactionParentsRelation transaction graph of

225226 Left err -> Left err

226− Right parentTransRel -> Right [StringAtom $ T.pack $ show (transactionUUID transaction),

227− RelationAtom parentTransRel,

228− BoolAtom $ parentUUID == transactionUUID transaction,

229− StringAtom $ case headNameForTransaction transaction graph of

227+ Right parentTransRel -> Right [Atom $ T.pack $ show (transactionUUID transaction),

228+---- Atom parentTransRel,

229+ Atom $ parentUUID == transactionUUID transaction,

230+ Atom $ case headNameForTransaction transaction graph of

230231 Just headName -> headName

231232 Nothing -> ""

232233 ]

@@ -240,5 +241,5 @@ transactionParentsRelation trans graph = do

240241 let tuples = map trans2tuple (S.toList parentTransSet)

241242 mkRelationFromTuples attrs tuples

242243 where

243− attrs = A.attributesFromList [Attribute "id" StringAtomType]

244− trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (T.pack (show $ transactionUUID trans2)))

244+ attrs = A.attributesFromList [Attribute "id" stringAtomType]

245+ trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (Atom (T.pack (show $ transactionUUID trans2)))