cb07a7d · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch 'atom_typeclass_simple'

Conflicts: ProjectM36/Atom.hs ProjectM36/Base.hs ProjectM36/Relation/Show/CSV.hs ProjectM36/Relation/Show/HTML.hs ProjectM36/Relation/Show/Term.hs TutorialD/Interpreter/RelationalExpr.hs test/TutorialD/Interpreter.hs

commitcb07a7d647959aeb274bdfc11e8f28bede173b0a authorAgentM <agentm@themactionfaction.com> dateFri 16 Oct 2015, 12:41 (11 years ago) parentb219876 6dae00e

24 files changed+744−572

compare with master

unifiedsplit

Database/Persist/ProjectM36.hs+104−98 ProjectM36/Atom.hs+63−44 ProjectM36/Attribute.hs−4 ProjectM36/Base.hs+110−51 ProjectM36/ConcreteTypeRep.hs+30 ProjectM36/Relation.hs+52−43 ProjectM36/Relation/Parse/CSV.hs+3−5 ProjectM36/Relation/Show/CSV.hs+5−12 ProjectM36/Relation/Show/Gnuplot.hs+21−20 ProjectM36/Relation/Show/HTML.hs+3−10 ProjectM36/Relation/Show/Term.hs+18−23 ProjectM36/RelationalExpression.hs+141−127 ProjectM36/TransactionGraph.hs+35−35 README.markdown+1−1 TutorialD/Interpreter/Base.hs+8−7 TutorialD/Interpreter/RelationalExpr.hs+43−17 benchmark/bigrel.hs+2−3 docs/new_datatypes.markdown+20 test/Relation/Basic.hs+5−5 test/Relation/Export/CSV.hs+7−6 test/Relation/Import/CSV.hs+7−6 test/TutorialD/Interpreter.hs+61−52 test/TutorialD/Interpreter/Import/TutorialD.hs+3−2 test/persistent-driver/test.hs+2−1

Database/Persist/ProjectM36.hs+104−98

@@ -29,9 +29,12 @@ 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 ProjectM36.RelationalExpression (unsafeCast)

33+import Data.Typeable (typeRep, typeOf, Proxy(..))

34+import Data.Time.Calendar (Day)

35+

36+type ProjectM36Backend = C.Connection

3237

33−type ProjectM36Backend = C.Connection

34−

3538--convert a PersistEntity to a RelationTuple

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

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

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

4245 attrVec <- recordAttributes entInfo record

4346 atomVec <- recordAsAtoms uuid attrVec record

4447 return $ RelationTuple attrVec atomVec

45−

48+

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

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

4851recordAttributes entInfo record = do

4952 let convertAttr = uncurry fieldDefAsAttribute

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

5154 attrList <- mapM convertAttr entInfo

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

53−

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

56+

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

5558fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of

5659 Nothing -> Left $ AtomTypeNotSupported attrName

5760 Just fType -> Right $ Attribute attrName fType

58− where

61+ where

5962 attrName = unDBName $ emFieldDB fieldDef

60−

61−persistValueAtomType :: PersistValue -> Maybe AtomType

63+

64+persistValueAtomType :: PersistValue -> Maybe AtomType

6265persistValueAtomType val = do

6366 atom <- persistValueAtom val

6467 return $ atomTypeForAtom atom

65−

68+

6669persistValueAtom :: PersistValue -> Maybe Atom

6770persistValueAtom 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

71+ PersistText v -> return $ Atom v

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

73+ PersistBool v -> return $ Atom v

74+ PersistDay v -> return $ Atom v

7275 _ -> 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

80− _ -> error "missing conversion"

81−

76+

77+atomAsPersistValue :: Atom -> PersistValue

78+atomAsPersistValue atom@(Atom atomv) = if typeRep (Proxy :: Proxy Int) == typeOf atomv then

79+ PersistInt64 (fromIntegral ((unsafeCast atom) :: Int))

80+ else if typeRep (Proxy :: Proxy T.Text) == typeOf atomv then

81+ PersistText (unsafeCast atom)

82+ else if typeRep (Proxy :: Proxy Bool) == typeOf atomv then

83+ PersistBool (unsafeCast atom)

84+ else if typeRep (Proxy :: Proxy Day) == typeOf atomv then

85+ PersistDay (unsafeCast atom)

86+ else

87+ error "missing conversion"

88+

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

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

8491recordAsAtoms freshUUID _ record = do

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

8794 Nothing -> Left $ AtomTypeNotSupported ""

8895 Just atom -> Right atom

8996 atoms <- mapM valAtom pValues

90− return $ V.fromList $ case freshUUID of

97+ return $ V.fromList $ case freshUUID of

9198 Nothing -> atoms

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

93−

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

100+

94101--used by insert operations

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

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

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

97104recordsAsRelation [] = Left EmptyTuplesError

98105recordsAsRelation recordZips = do

99106 tupleList <- mapM (uncurry recordAsTuple) recordZips

100107 let oneTuple = head tupleList

101108 mkRelation (tupleAttributes oneTuple) (RelationTupleSet tupleList)

102−

103−keyFromValuesOrDie :: (Trans.MonadIO m,

104− PersistEntity record,

109+

110+keyFromValuesOrDie :: (Trans.MonadIO m,

111+ PersistEntity record,

105112 PersistEntityBackend record ~ C.Connection

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

107114keyFromValuesOrDie val = case keyFromValues val of

108115 Right k -> return k

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

110−

117+

111118insertNewRecords :: (Trans.MonadIO m,

112119 PersistEntity record,

113120 PersistEntityBackend record ~ C.Connection) =>

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

115122insertNewRecords uuids records = do

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

117− insertExpr = Insert (relVarNameFromRecord $ head records)

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

124+ insertExpr = Insert (relVarNameFromRecord $ head records)

118125 case recordsAsRelation recordsZip of

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

120− Right rel -> do

127+ Right rel -> do

121128 conn <- ask

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

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

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

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

127134

128135lookupByKey :: forall record m.

129− (Trans.MonadIO m,

130− PersistEntity record,

136+ (Trans.MonadIO m,

137+ PersistEntity record,

131138 PersistEntityBackend record ~ C.Connection)

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

133140lookupByKey key = do

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

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

140147 Right resultRel' -> case singletonTuple resultRel' of

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

142− Just tuple -> do

143− let entityInfo = entityDefFromKey key

149+ Just tuple -> do

150+ let entityInfo = entityDefFromKey key

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

145152 return $ Just entity

146−

147−fromPersistValuesThrow :: (Trans.MonadIO m,

148− PersistEntity record,

153+

154+fromPersistValuesThrow :: (Trans.MonadIO m,

155+ PersistEntity record,

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

150157fromPersistValuesThrow entDef tuple = do

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

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

160167 Right key -> case body of

161168 Left err -> throwIOPersistError (show err)

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

163−

170+

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

165−commonKeyQueryProperties key = do

172+commonKeyQueryProperties key = do

166173 let matchUUID = keyToUUID key

167174 keyAttributeName = unDBName (fieldDB $ entityId entityInfo)

168− relVarName = unDBName $ entityDB entityInfo

175+ relVarName = unDBName $ entityDB entityInfo

169176 matchUUIDText = T.pack $ U.toString matchUUID

170− entityInfo = entityDefFromKey key

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

177+ entityInfo = entityDefFromKey key

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

172179 return (relVarName, restrictionPredicate)

173−

180+

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

175182deleteByKey key = do

176183 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

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

178185 conn <- ask

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

180187 return $ isJust maybeErr

181−

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

183−updatesToUpdateMap :: (Trans.MonadIO m,

188+

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

190+updatesToUpdateMap :: (Trans.MonadIO m,

184191 PersistEntityBackend val ~ C.Connection,

185192 PersistEntity val) =>

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

187−updatesToUpdateMap updates = do

194+updatesToUpdateMap updates = do

188195 let convertMap upd = case updateUpdate upd of

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

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

190197 newAttrValue = persistValueAtom (updatePersistValue upd) in

191198 case newAttrValue of

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

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

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

195202 updateAtomList <- mapM convertMap updates

196203 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 ()

204+

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

199206updateByKey key updates = do

200207 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

201208 updateMap <- updatesToUpdateMap updates

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

205212 case maybeErr of

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

207214 Nothing -> return ()

208−

209−--set the truth unconditionally

215+

216+--set the truth unconditionally

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

211218repsertByKey key val = do

212219 _ <- delete key

213220 insertKey key val

214−

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

221+

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

216223replaceByKey key val = do

217224 deletionSuccess <- deleteByKey key

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

219226 insertKey key val

220−

227+

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

222229entityDefFromKey = entityDef . Just . recordTypeFromKey

223−

230+

224231dummyFromKey :: Key record -> Maybe record

225232dummyFromKey = Just . recordTypeFromKey

226233

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

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

246253 Just uuid -> uuid

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

248−

255+

249256instance PersistStore C.Connection where

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

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

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

254261 insertMany records = do

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

256263 insertNewRecords freshUUIDs records

257−

264+

258265 insert record = do

259266 keys <- insertMany [record]

260267 return $ head keys

261−

268+

262269 --insertEntityMany [] = return []

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

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

264271 insertKey key record = do

265272 let uuid = keyToUUID key

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

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

267274 return ()

268−

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

275+

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

270277 get key = do

271278 ent <- lookupByKey key

272279 case ent of

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

275282

276283 repsert = repsertByKey

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

278−

285+

279286 delete key = deleteByKey key >> return ()

280−

287+

281288 replace = replaceByKey

282−

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

289+

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

284291 update = updateByKey

285−

286−instance FromJSON (BackendKey C.Connection) where

292+

293+instance FromJSON (BackendKey C.Connection) where

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

288−

295+

289296instance ToJSON (BackendKey C.Connection) where

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

291−

292−--wrapped version which throws exceptions

298+

299+--wrapped version which throws exceptions

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

294301executeDatabaseContextExpr conn expr = do

295302 res <- C.executeDatabaseContextExpr conn expr

296303 case res of

297304 Nothing -> return ()

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

299−

306+

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

301308 => record -> RelVarName

302309relVarNameFromRecord = unDBName . entityDB . entityDef . Just

303−

310+

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

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

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

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

308−

315+

309316updatePersistValue :: DP.Update v -> PersistValue

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

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

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

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

316323 Nothing -> Left "uuid text read failure"

317324 Just uuid -> Right uuid

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

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

319326

320327instance FromJSON C.ConnectionInfo where

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

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

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

324331 return ctype

325−

332+

326333instance PersistConfig C.ConnectionInfo where

327334 type PersistConfigBackend C.ConnectionInfo = ReaderT C.Connection

328335 type PersistConfigPool C.ConnectionInfo = C.Connection

329−

336+

330337 loadConfig = parseJSON

331338 applyEnv = return -- no environment variables are used

332339 createPoolConfig conf = do

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

336343 Right conn -> return conn

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

338345 runPool _ r = runReaderT r

339−

346+

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

341348withProjectM36Conn conf connReader = do

342349 conn <- Trans.liftIO $ createPoolConfig conf

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

361368persistUniqueToRestrictionPredicate unique = do

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

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

364− andify [] = TruePredicate

371+ andify [] = TruePredicate

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

366373 return $ andify (zip attrNames atoms)

367−

374+

368375instance PersistUnique C.Connection where

369376 getBy unique = do

370377 conn <- ask

371378 let predicate = persistUniqueToRestrictionPredicate unique

372379 relVarName = unDBName $ entityDB entDef

373380 entDef = entityDef $ dummyFromUnique unique

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

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

375382 case predicate of

376383 Left err -> throwRelErr err

377384 Right predicate' -> do

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

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

409416multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate

410417multiFilterAsRestrictionPredicate andOr (x:xs) = do

411− let predicate = if andOr then AndPredicate else OrPredicate

412− filtHead <- filterAsRestrictionPredicate x

418+ let predicate = if andOr then AndPredicate else OrPredicate

419+ filtHead <- filterAsRestrictionPredicate x

413420 filtTail <- multiFilterAsRestrictionPredicate andOr xs

414421 return $ predicate filtHead filtTail

415422

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

451458 let entDef = entityDef $ dummyFromFilters filters

452459 relVarName = unDBName $ entityDB entDef

453460 right $ Restrict restrictionPredicate (RelationVariable relVarName)

454−

455−

461+

462+

456463instance PersistQuery C.Connection where

457464 updateWhere _ [] = return ()

458465 updateWhere filters updates = do

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

465472 relVarName = unDBName $ entityDB entDef

466473 updateExpr = Update relVarName updateMap restrictionPredicate

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

468− case maybeErr of

475+ case maybeErr of

469476 Just err -> left err

470477 Nothing -> right ()

471478 case e of

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

473480 Right () -> return ()

474481

475482 deleteWhere filters = do

476− conn <- ask

483+ conn <- ask

477484 e <- runEitherT $ do

478485 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters

479− let entDef = entityDef $ dummyFromFilters filters

486+ let entDef = entityDef $ dummyFromFilters filters

480487 relVarName = unDBName $ entityDB entDef

481488 deleteExpr = Delete relVarName restrictionPredicate

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

483− case maybeErr of

490+ case maybeErr of

484491 Just err -> left err

485492 Nothing -> right ()

486493 case e of

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

491498 conn <- ask

492499 e <- runEitherT $ do

493500 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters

494− let entDef = entityDef $ dummyFromFilters filters

501+ let entDef = entityDef $ dummyFromFilters filters

495502 relVarName = unDBName $ entityDB entDef

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

497504 allAttrNames = AttributeNames $ S.fromList allAttrNamesList

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

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

500507 countExpr = Extend tupleExpr groupExpr

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

502− case rel of

509+ case rel of

503510 Left err -> left err

504511 Right rel' -> case singletonTuple rel' of

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

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

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

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

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

509515 Left err -> left err

510516 case e of

511517 Left err -> throwIOPersistError ("count failure: " ++ show err)

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

546552 case keys of

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

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

549−

555+

ProjectM36/Atom.hs+63−44

@@ -2,50 +2,69 @@

22module ProjectM36.Atom where

33import ProjectM36.Base

44import ProjectM36.Error

5+import Data.Typeable

6+import ProjectM36.ConcreteTypeRep

57import qualified Data.Text as T

6−import Text.Read (readMaybe)

7−import Data.Time.Format

8−import Data.ByteString.Base64

9−import qualified Data.Text.Encoding as TE

8+import Data.Time.Calendar (Day)

9+import Data.Time.Clock

10+import Data.ByteString (ByteString)

1011

1112relationForAtom :: Atom -> Either RelationalError Relation

12−relationForAtom (RelationAtom rel) = Right rel

13−relationForAtom _ = Left $ AttributeIsNotRelationValuedError ""

14−

15−atomTypeForAtom :: Atom -> AtomType

16−atomTypeForAtom (StringAtom _) = StringAtomType

17−atomTypeForAtom (IntAtom _) = IntAtomType

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

19−atomTypeForAtom (BoolAtom _) = BoolAtomType

20−atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

21−atomTypeForAtom (DateAtom _) = DateAtomType

22−atomTypeForAtom (DoubleAtom _) = DoubleAtomType

23−atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

24−

25−{- a generic string constructor for atoms

26−used by CSV relation generation

27−-}

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

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

30−atomFromString IntAtomType strIn = case readMaybe strIn of

31− Just i -> Right $ IntAtom i

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

33−atomFromString BoolAtomType strIn = case strIn of

34− "true" -> Right $ BoolAtom True

35− "false" -> Right $ BoolAtom False

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

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

38−atomFromString DateTimeAtomType strIn =

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

40− Just utctime -> Right $ DateTimeAtom utctime

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

42−atomFromString DoubleAtomType strIn = case readMaybe strIn of

43− Just d -> Right $ DoubleAtom d

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

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

46− Just date -> Right $ DateAtom date

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

48−atomFromString ByteStringAtomType strIn = case decode (TE.encodeUtf8 (T.pack strIn)) of

49− Left err -> Left $ ParseError (T.pack err)

50− Right bsVal -> Right $ ByteStringAtom bsVal

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

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

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

15+ Nothing -> Left $ AttributeIsNotRelationValuedError ""

16+

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

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

19+

20+--some convenience functions

21+stringAtomType :: AtomType

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

23+

24+intAtomType :: AtomType

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

26+

27+boolAtomType :: AtomType

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

29+

30+dateAtomType :: AtomType

31+dateAtomType = atomTypeForProxy (Proxy :: Proxy Day)

32+

33+dateTimeAtomType :: AtomType

34+dateTimeAtomType = atomTypeForProxy (Proxy :: Proxy UTCTime)

35+

36+byteStringAtomType :: AtomType

37+byteStringAtomType = atomTypeForProxy (Proxy :: Proxy ByteString)

38+

39+doubleAtomType :: AtomType

40+doubleAtomType = atomTypeForProxy (Proxy :: Proxy Double)

41+

42+--another hard-coded typerep dispatch table :/

43+makeAtomFromText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom

44+makeAtomFromText _ (AtomType cTypeRep) textIn = if

45+ unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then

46+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Int)

47+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Double) then

48+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Double)

49+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy T.Text) then

50+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String T.Text)

51+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then

52+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Day)

53+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy UTCTime) then

54+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String UTCTime)

55+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then

56+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String ByteString)

57+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then

58+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Bool)

59+ else

60+ Left $ ParseError textIn

61+makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

62+

63+--textAtom shortcut

64+stringAtom :: T.Text -> Atom

65+stringAtom t = Atom t

66+

67+--intAtom shortcut

68+intAtom :: Int -> Atom

69+intAtom i = Atom i

70+

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+110−51

@@ -1,9 +1,9 @@

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

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

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

33module ProjectM36.Base where

44import qualified Data.Map as M

55import qualified Data.HashSet as HS

6−import qualified Data.Hashable as Hash

6+import Data.Hashable (Hashable, hashWithSalt)

77import qualified Data.Set as S

88import Control.Monad.State (State)

99import Data.UUID (UUID)

@@ -12,27 +12,93 @@ import Control.DeepSeq.Generics (genericRnf)

1212import GHC.Generics (Generic)

1313import qualified Data.Vector as V

1414import qualified Data.List as L

15−import qualified Data.Text as T

15+import Data.Text (Text,pack,unpack)

1616import Data.Binary

1717import Data.Vector.Binary()

1818import Data.Time.Clock

1919import Data.Time.Clock.POSIX

2020import Data.Time.Calendar (Day,toGregorian,fromGregorian)

2121import Data.Hashable.Time ()

22−import qualified Data.ByteString as BS

23−

24−type StringType = T.Text

25−

26−data Atom = StringAtom StringType |

27− IntAtom Int |

28− BoolAtom Bool |

29− RelationAtom Relation |

30− DateTimeAtom UTCTime |

31− DateAtom Day |

32− DoubleAtom Double |

33− ByteStringAtom BS.ByteString

34− deriving (Show, Eq, Generic)

35−

22+import Data.Typeable

23+import Text.Read (readMaybe)

24+import Data.ByteString (ByteString)

25+import ProjectM36.ConcreteTypeRep

26+

27+type StringType = Text

28+

29+class (Read a,

30+ Hashable a,

31+ Binary a,

32+ Eq a,

33+ Show a,

34+ Typeable a,

35+ NFData a) => Atomable a where

36+ fromText :: (Atomable a) => Text -> Either String a

37+ fromText t = case readMaybe (unpack t) of

38+ Just v -> Right v

39+ Nothing -> Left "parse error"

40+

41+ toText :: a -> Text

42+ toText a = pack $ show a

43+

44+instance Atomable Int

45+instance Atomable Double

46+instance Atomable Text where

47+ --no need to require quoted strings

48+ fromText t = Right t

49+ toText t = t

50+instance Atomable Day

51+instance Atomable UTCTime

52+instance Atomable ByteString

53+instance Atomable Bool

54+instance Atomable Relation

55+instance (Atomable a) => Atomable (Maybe a)

56+

57+data Atom = forall a. Atomable a => Atom a

58+

59+instance Eq Atom where

60+ (Atom a) == (Atom b) = Just a == cast b

61+

62+instance Show Atom where

63+ show (Atom atom) = "Atom " ++ show atom

64+

65+instance Binary Atom where

66+ put atom@(Atom val) = put (atomTypeForAtom atom) >> put val

67+ get = do

68+ atomtype <- get

69+ --not-so-great for this to be hardcoded here- it would be nicer to have a dispatch table linked to the instances themselves

70+ --http://stackoverflow.com/questions/8101067/binary-instance-for-an-existential

71+ case atomtype of

72+ AnyAtomType -> error "unsupported serialization AnyAtomType"

73+ (RelationAtomType _) -> Atom <$> (get :: Get Relation)

74+ (AtomType cTypeRep) -> if unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then

75+ Atom <$> (get :: Get Int)

76+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Text) then

77+ Atom <$> (get :: Get Text)

78+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Double) then

79+ Atom <$> (get :: Get Double)

80+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then

81+ Atom <$> (get :: Get Day)

82+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy UTCTime) then

83+ Atom <$> (get :: Get UTCTime)

84+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then

85+ Atom <$> (get :: Get ByteString)

86+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then

87+ Atom <$> (get :: Get Bool)

88+ else

89+ error "unsupported typerep serialization"

90+

91+instance NFData Atom where

92+ rnf !(Atom a) = rnf a

93+

94+instance Hashable Atom where

95+ hashWithSalt salt (Atom a) = hashWithSalt salt a

96+

97+atomTypeForAtom :: Atom -> AtomType

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

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

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

101+

36102instance Binary UTCTime where

37103 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

38104 get = do

@@ -43,34 +109,23 @@ instance Binary Day where

43109 put day = put $ toGregorian day

44110 get = do

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

46− return $ fromGregorian y m d

112+ return (fromGregorian y m d)

47113

48−instance NFData Atom where rnf = genericRnf

49−

50−instance Hash.Hashable Atom

51−

52−instance Binary Atom

53−

54−data AtomType = StringAtomType |

55− IntAtomType |

56− BoolAtomType |

114+data AtomType = AtomType ConcreteTypeRep |

57115 RelationAtomType Attributes |

58− DateTimeAtomType |

59− DateAtomType |

60− DoubleAtomType |

61− ByteStringAtomType |

62− AnyAtomType --AnyAtomType is used as a wildcard

63− deriving (Eq, Show, Generic)

64−

65−instance NFData AtomType where rnf = genericRnf

66−instance Binary AtomType

67−

68−type AttributeName = T.Text

116+ AnyAtomType --wildcard used in Atom Functions

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

118+

119+isRelationAtomType :: AtomType -> Bool

120+isRelationAtomType (RelationAtomType _) = True

121+isRelationAtomType _ = False

122+

123+type AttributeName = StringType

69124

70125data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)

71126

72−instance Hash.Hashable Attribute where

73− hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName

127+instance Hashable Attribute where

128+ hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName

74129

75130instance NFData Attribute where rnf = genericRnf

76131

@@ -86,7 +141,10 @@ attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2

86141sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

87142sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)

88143

89−newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hash.Hashable, Show, Generic, Binary)

144+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)

145+

146+instance Read Relation where

147+ readsPrec = error "relation read not supported"

90148

91149instance Eq RelationTupleSet where

92150 set1 == set2 = hset set1 == hset set2

@@ -96,9 +154,9 @@ instance Eq RelationTupleSet where

96154instance NFData RelationTupleSet where rnf = genericRnf

97155

98156--the same hash must be generated for equal tuples so that the hashset equality works

99−instance Hash.Hashable RelationTuple where

100− hashWithSalt salt (RelationTuple attrs tupVec) = salt `Hash.hashWithSalt`

101− sortedAttrs `Hash.hashWithSalt`

157+instance Hashable RelationTuple where

158+ hashWithSalt salt (RelationTuple attrs tupVec) = salt `hashWithSalt`

159+ sortedAttrs `hashWithSalt`

102160 (V.toList sortedTupVec)

103161 where

104162 sortedAttrsIndices = sortedAttributesIndices attrs

@@ -120,16 +178,16 @@ instance Eq RelationTuple where

120178

121179instance NFData RelationTuple where rnf = genericRnf

122180

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

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

124182

125183instance Eq Relation where

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

127185

128186instance NFData Relation where rnf = genericRnf

129187

130−instance Hash.Hashable Relation where

131− hashWithSalt salt (Relation attrs tupSet) = salt `Hash.hashWithSalt`

132− sortedAttrs `Hash.hashWithSalt`

188+instance Hashable Relation where

189+ hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt`

190+ sortedAttrs `hashWithSalt`

133191 asList tupSet

134192 where

135193 sortedAttrs = map snd (sortedAttributesIndices attrs)

@@ -276,14 +334,14 @@ data AtomFunction = AtomFunction {

276334 atomFunc :: [Atom] -> Atom

277335 }

278336

279−instance Hash.Hashable AtomFunction where

280− hashWithSalt salt func = salt `Hash.hashWithSalt` (atomFuncName func)

337+instance Hashable AtomFunction where

338+ hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)

281339

282340instance Eq AtomFunction where

283341 f1 == f2 = (atomFuncName f1) == (atomFuncName f2)

284342

285343instance Show AtomFunction where

286− show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

344+ show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

287345 where

288346 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

289347

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

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

300358 deriving (Show, Read)

301359

360+

ProjectM36/ConcreteTypeRep.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+-- adapted from https://hackage.haskell.org/package/concrete-typerep

3+module ProjectM36.ConcreteTypeRep where

4+import Data.Binary

5+import Data.Typeable

6+import Data.Typeable.Internal

7+import Control.DeepSeq (NFData)

9+newtype ConcreteTypeRep = CTR { unCTR :: TypeRep } deriving (Eq, Typeable, Show, NFData)

10+

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

12+

13+type TyConRep = (String, String, String)

14+toTyConRep :: TyCon -> TyConRep

15+toTyConRep (TyCon _ pack modul name) = (pack, modul, name)

16+

17+fromTyConRep (pack, modul, name) = mkTyCon3 pack modul name

18+fromTyConRep :: TyConRep -> TyCon

19+

20+toSerial :: ConcreteTypeRep -> SerialRep

21+toSerial (CTR t) = case splitTyConApp t of

22+ (con, args) -> SR (toTyConRep con, map (toSerial . CTR) args)

23+

24+fromSerial :: SerialRep -> ConcreteTypeRep

25+fromSerial (SR (con, args)) = CTR $ mkTyConApp (fromTyConRep con) (map (unCTR . fromSerial) args)

26+

27+instance Binary ConcreteTypeRep where

28+ put = put . toSerial

29+ get = fromSerial <$> get

30+

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+3−5

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

1+{-# LANGUAGE OverloadedStrings #-}

12module ProjectM36.Relation.Parse.CSV where

23--parse Relations from CSV

34import Data.Csv.Parser

@@ -6,7 +7,6 @@ import Data.Char (ord)

67import qualified Data.ByteString.Lazy as BS

78import ProjectM36.Base

89import ProjectM36.Relation

9−import ProjectM36.Atom

1010import ProjectM36.Error

1111import Data.Text.Encoding (decodeUtf8)

1212import qualified ProjectM36.Attribute as A

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

1515import qualified Data.List as L

1616import qualified Data.Text as T

1717import Data.Attoparsec.ByteString.Lazy

18+import ProjectM36.Atom

1819

1920data CsvImportError = CsvParseError String |

2021 AttributeMappingError RelationalError |

@@ -35,10 +36,7 @@ csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inStr

3536 attrNameSet = S.fromList (V.toList attrNames)

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

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

38− 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− Right atom -> Right atom

39+ makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! (A.attributeName attr))) attrs

4240 case attrNameSet == headerSet of

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

4442 True -> do

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

@@ -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,7 +22,7 @@ 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)

@@ -37,13 +39,4 @@ instance DefaultOrdered RecordRelationTuple where

3739newtype RecordAtom = RecordAtom {unAtom :: Atom}

3840

3941instance ToField RecordAtom where

40− toField ratom = case unAtom ratom of

41− BoolAtom atom -> toField (if atom then "t" else "f")

42− StringAtom atom -> toField atom

43− IntAtom atom -> toField atom

44− DateTimeAtom atom -> toField (show atom)

45− DateAtom atom -> toField (show atom)

46− DoubleAtom atom -> toField atom

47− RelationAtom _ -> error "Relation atoms cannot be used in CSV."

48− ByteStringAtom bs -> toField bs

49−

42+ toField (RecordAtom (Atom atomVal)) = (TE.encodeUtf8 . toText) atomVal

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+3−10

@@ -12,7 +12,7 @@ import qualified Data.Text.Encoding as TE

1212

1313attributesAsHTML :: Attributes -> Text

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

15− where

15+ where

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

1717 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

1818

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

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

2626

2727writeRel :: Relation -> IO ()

28−writeRel = writeHTML . relationAsHTML

28+writeRel = writeHTML . relationAsHTML

2929

3030atomAsHTML :: 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)

36−atomAsHTML (DoubleAtom d) = pack (show d)

37−atomAsHTML (DateAtom d) = pack (show d)

38−atomAsHTML (ByteStringAtom bs) = TE.decodeUtf8 bs

31+atomAsHTML (Atom atom) = toText atom

3932

4033tupleAsHTML :: RelationTuple -> Text

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

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

@@ -7,7 +7,7 @@ import ProjectM36.Relation

77import qualified Data.Set as S

88import qualified Data.List as L

99import qualified Data.Text as T

10−import qualified Data.Text.Encoding as TE

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,22 +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

102−showAtom (ByteStringAtom bs) = TE.decodeUtf8 bs

93+

94+showAtom :: Atom -> StringType

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

96+ Just rel -> renderTable $ relationAsTable rel

97+ Nothing -> toText atom

10398

10499renderTable :: Table -> StringType

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

106101 where

107− cellLocs = cellLocations table

108−

102+ cellLocs = cellLocations table

103+

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

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

111106 where

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

113108 renderHeaderNames = renderRow header columnLocations 1 boxV

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

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

116−

111+

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

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

119114

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

124119 paddedLines !! lineNum

125120 where

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

127−

122+

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

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

130125 where

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

141136

142137orderedAttributeNames :: Relation -> [AttributeName]

143138orderedAttributeNames = S.toAscList . attributeNames

144−

139+

145140repeatString :: Int -> StringType -> StringType

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

147142

ProjectM36/RelationalExpression.hs+141−127

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

1515import Control.Monad.State hiding (join)

1616import Data.Maybe

1717import Data.Either

18+import Data.Typeable (cast)

1819

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

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

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

2223 relvarTable <- liftM relationVariables get

2324 return $ case M.lookup name relvarTable of

2425 Just res -> Right res

25− Nothing -> Left $ RelVarNotDefinedError name

26+ Nothing -> Left $ RelVarNotDefinedError name

2627

2728evalRelationalExpr (Project attrNames expr) = do

2829 rel <- evalRelationalExpr expr

29− case rel of

30+ case rel of

3031 Right rel2 -> return $ project attrNames rel2

3132 Left err -> return $ Left err

3233

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

4748 Right relA2 -> case relB of

4849 Left err -> return $ Left err

4950 Right relB2 -> return $ join relA2 relB2

50−

51+

5152evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

5253 case mkRelation attributeSet tupleSet of

5354 Right rel -> return $ Right rel

5455 Left err -> return $ Left err

55−

56+

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

57−

58+

5859evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

5960 evald <- evalRelationalExpr relExpr

6061 case evald of

6162 Right rel -> return $ rename oldAttrName newAttrName rel

6263 Left err -> return $ Left err

63−

64+

6465evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do

6566 evald <- evalRelationalExpr relExpr

66− case evald of

67+ case evald of

6768 Right rel -> return $ group oldAttrNameSet newAttrName rel

6869 Left err -> return $ Left err

69−

70+

7071evalRelationalExpr (Ungroup attrName relExpr) = do

7172 evald <- evalRelationalExpr relExpr

7273 case evald of

7374 Right rel -> return $ ungroup attrName rel

7475 Left err -> return $ Left err

75−

76+

7677evalRelationalExpr (Restrict predicateExpr relExpr) = do

7778 evald <- evalRelationalExpr relExpr

7879 context <- get

79− case evald of

80+ case evald of

8081 Left err -> return $ Left err

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

8283 Left err -> return $ Left err

8384 Right filterfunc -> return $ restrict filterfunc rel

84−

85+

8586evalRelationalExpr (Equals relExprA relExprB) = do

8687 evaldA <- evalRelationalExpr relExprA

8788 evaldB <- evalRelationalExpr relExprB

8889 case evaldA of

8990 Left err -> return $ Left err

90− Right relA -> case evaldB of

91+ Right relA -> case evaldB of

9192 Left err -> return $ Left err

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

93−

94+

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

9596evalRelationalExpr (NotEquals relExprA relExprB) = do

9697 evaldA <- evalRelationalExpr relExprA

9798 evaldB <- evalRelationalExpr relExprB

9899 case evaldA of

99100 Left err -> return $ Left err

100− Right relA -> case evaldB of

101+ Right relA -> case evaldB of

101102 Left err -> return $ Left err

102103 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

104+

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

106+evalRelationalExpr (Extend tupleExpression relExpr) = do

106107 evald <- evalRelationalExpr relExpr

107108 context <- get

108− case evald of

109+ case evald of

109110 Left err -> return $ Left err

110111 Right rel -> do

111112 case tupleExpressionProcessor rel tupleExpression context of

112113 Left err -> return $ Left err

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

114−

115+

115116emptyDatabaseContext :: DatabaseContext

116117emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

117118 relationVariables = M.empty,

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

126127 }

127128

128129dateExamples :: DatabaseContext

129−dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

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

130+dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

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

131132 atomFunctions = basicAtomFunctions}

132133 where

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

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

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

142143 ]

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

144−

145−suppliersRel :: Relation

145+

146+suppliersRel :: Relation

146147suppliersRel = case mkRelationFromList attrs atomMatrix of

147148 Left _ -> undefined

148149 Right rel -> rel

149150 where

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

151− Attribute "SNAME" StringAtomType,

152− Attribute "STATUS" IntAtomType,

153− Attribute "CITY" StringAtomType]

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

152+ Attribute "SNAME" stringAtomType,

153+ Attribute "STATUS" intAtomType,

154+ Attribute "CITY" stringAtomType]

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

156+ [stringAtom "S1", stringAtom "Smith", intAtom 20, stringAtom "London"],

157+ [stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"],

158+ [stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],

159+ [stringAtom "S4", stringAtom "Clark", intAtom 20, stringAtom "London"],

160+ [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]

161+

161162supplierProductsRel :: Relation

162163supplierProductsRel = case mkRelationFromList attrs matrix of

163164 Left _ -> undefined

164165 Right rel -> rel

165166 where

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

167− Attribute "P#" StringAtomType,

168− Attribute "QTY" IntAtomType]

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

168+ Attribute "P#" stringAtomType,

169+ Attribute "QTY" intAtomType]

169170 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]

171+ [stringAtom "S1", stringAtom "P1", intAtom 300],

172+ [stringAtom "S1", stringAtom "P2", intAtom 200],

173+ [stringAtom "S1", stringAtom "P3", intAtom 400],

174+ [stringAtom "S1", stringAtom "P4", intAtom 200],

175+ [stringAtom "S1", stringAtom "P5", intAtom 100],

176+ [stringAtom "S1", stringAtom "P6", intAtom 100],

177+ [stringAtom "S2", stringAtom "P1", intAtom 300],

178+ [stringAtom "S2", stringAtom "P2", intAtom 400],

179+ [stringAtom "S3", stringAtom "P2", intAtom 200],

180+ [stringAtom "S4", stringAtom "P2", intAtom 200],

181+ [stringAtom "S4", stringAtom "P4", intAtom 300],

182+ [stringAtom "S4", stringAtom "P5", intAtom 400]

182183 ]

183−

184−productsRel :: Relation

184+

185+productsRel :: Relation

185186productsRel = case mkRelationFromList attrs matrix of

186187 Left _ -> undefined

187188 Right rel -> rel

188189 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"]

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

191+ Attribute "PNAME" stringAtomType,

192+ Attribute "COLOR" stringAtomType,

193+ Attribute "WEIGHT" intAtomType,

194+ Attribute "CITY" stringAtomType]

195+ matrix = [

196+ [stringAtom "P1", stringAtom "Nut", stringAtom "Red", intAtom 12, stringAtom "London"],

197+ [stringAtom "P2", stringAtom "Bolt", stringAtom "Green", intAtom 17, stringAtom "Paris"],

198+ [stringAtom "P3", stringAtom "Screw", stringAtom "Blue", intAtom 17, stringAtom "Oslo"],

199+ [stringAtom "P4", stringAtom "Screw", stringAtom "Red", intAtom 14, stringAtom "London"],

200+ [stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"],

201+ [stringAtom "P6", stringAtom "Cog", stringAtom "Red", intAtom 19, stringAtom "London"]

201202 ]

202−

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

203+

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

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

205−setRelVar relVarName rel = do

206+setRelVar relVarName rel = do

206207 currentContext <- get

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

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

209210 case checkConstraints potentialContext of

210211 Just err -> return $ Just err

211− Nothing -> do

212+ Nothing -> do

212213 put potentialContext

213214 return Nothing

214−

215+

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

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

217218deleteRelVar relVarName = do

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

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

224225evalContextExpr (Define relVarName attrs) = do

225226 relvars <- liftM relationVariables get

226− case M.member relVarName relvars of

227+ case M.member relVarName relvars of

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

228229 False -> setRelVar relVarName emptyRelation

229230 where

230231 emptyRelation = Relation attrs emptyTupleSet

231−

232+

232233evalContextExpr (Undefine relVarName) = do

233234 deleteRelVar relVarName

234−

235+

235236evalContextExpr (Assign relVarName expr) = do

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

237238 relVarTable <- liftM relationVariables get

238239 let existingRelVar = M.lookup relVarName relVarTable

239− value <- evalRelationalExpr expr

240− case value of

240+ value <- evalRelationalExpr expr

241+ case value of

241242 Left err -> return $ Just err

242− Right rel -> case existingRelVar of

243+ Right rel -> case existingRelVar of

243244 Nothing -> setRelVar relVarName rel

244245 Just existingRel -> let expectedAttributes = attributes existingRel

245246 foundAttributes = attributes rel in

246− if A.attributesEqual expectedAttributes foundAttributes then

247+ if A.attributesEqual expectedAttributes foundAttributes then

247248 setRelVar relVarName rel

248249 else

249250 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)

250−

251+

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

252253

253254--assign empty rel until restriction is implemented

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

256257 case updatedRel of

257258 Left err -> return $ Just err

258259 Right rel -> setRelVar relVarName rel

259−

260+

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

261262evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do

262263 currstate <- get

263− let relVarTable = relationVariables currstate

264+ let relVarTable = relationVariables currstate

264265 case M.lookup relVarName relVarTable of

265266 Nothing -> return $ Just (RelVarNotDefinedError relVarName)

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

267268 Left err -> return $ Just err

268− Right predicateFunc -> do

269+ Right predicateFunc -> do

269270 case makeUpdatedRel rel of

270271 Left err -> return $ Just err

271272 Right updatedRel -> setRelVar relVarName updatedRel

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

289290 Nothing -> do

290291 put potentialContext

291292 return Nothing

292−

293−evalContextExpr (RemoveInclusionDependency depName) = do

293+

294+evalContextExpr (RemoveInclusionDependency depName) = do

294295 currContext <- get

295296 let currDeps = inclusionDependencies currContext

296297 newDeps = M.delete depName currDeps

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

307308 case catMaybes evald of

308309 [] -> return $ Nothing

309310 err:_ -> return $ Just err

310−

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

311+

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

312313--evalRelVarExpr (Update relVarName updateMap) = do

313314

314315--run verification on all constraints

315316checkConstraints :: DatabaseContext -> Maybe RelationalError

316−checkConstraints context = case failures of

317+checkConstraints context = case failures of

317318 [] -> Nothing

318319 l:_ -> Just l

319320 where

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

321322 deps = inclusionDependencies context

322323 eval expr = runState (evalRelationalExpr expr) context

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

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

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

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

326327 (Left err, _) -> Just err

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

328329 Left err -> Just err

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

330− Nothing

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

331+ Nothing

331332 else

332333 Just $ InclusionDependencyCheckError depName

333334 where

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

339340checkConstraint (InclusionDependency name subDep superDep) = do

340341 evalSub <- evalRelationalExpr subDep

341342 evalSuper <- evalRelationalExpr superDep

342− case evalSub of

343+ case evalSub of

343344 Left err -> Just err

344− Right relSub

345+ Right relSub

345346 result <- liftM2 union evalSub evalSuper

346347 return $ Nothing

347348-}

348−

349+

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

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

351−

352+

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

353354typeForRelationalExpr expr = do

354355 currstate <- get

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

356357 put $ contextWithEmptyTupleSets currstate

357358 evalRelationalExpr expr

358−

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

359+

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

360361--this is useful for type checking and optimization

361362contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

362363contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs

363364 where

364− incDeps = inclusionDependencies contextIn

365+ incDeps = inclusionDependencies contextIn

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

366367 funcs = atomFunctions contextIn

367−

368+

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

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

370371predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do

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

376377 expr1v <- predicateRestrictionFilter context attrs expr1

377378 expr2v <- predicateRestrictionFilter context attrs expr2

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

379−

380+

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

381−

382+

382383predicateRestrictionFilter context attrs (NotPredicate expr) = do

383384 exprv <- predicateRestrictionFilter context attrs expr

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

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

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

387388 (Left err, _) -> Left err

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

389− Right $ \_ -> True

390+ Right $ \_ -> True

390391 else if rel == relationFalse then

391− Right $ \_ -> False

392+ Right $ \_ -> False

392393 else

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

394−

395+

395396predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName atomExpr) = do

396397 attr <- A.attributeForName attrName attrs

397398 atomExprType <- typeFromAtomExpr attrs context atomExpr

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

400401 else

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

402403 Left _ -> False

403− Right atomIn ->

404+ Right atomIn ->

404405 case evalAtomExpr tupleIn context atomExpr of

405406 Left _ -> False

406407 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

408+

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

410+predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do

410411 aType <- typeFromAtomExpr attrs context atomExpr

411− if aType /= BoolAtomType then

412− Left $ AtomTypeMismatchError aType BoolAtomType

412+ if aType /= boolAtomType then

413+ Left $ AtomTypeMismatchError aType boolAtomType

413414 else

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

415416 Left _ -> False

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

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

417418

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

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

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

422423 Right rel

423424

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

425−tupleExpressionProcessor relIn

426+tupleExpressionProcessor relIn

426427 (AttributeTupleExpr newAttrName atomExpr) context = do

427428 _ <- tupleExprCheckNewAttrName newAttrName relIn

428429 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr

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

445446 return $ (atomFunc func) evaldArgs

446447evalAtomExpr _ context (RelationAtomExpr relExpr) = do

447448 relAtom <- evalState (evalRelationalExpr relExpr) context

448− return $ RelationAtom relAtom

449+ return $ Atom relAtom

449450

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

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

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

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

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

454455 let funcs = atomFunctions context

455456 func <- atomFunctionForName funcName funcs

456457 return $ last (atomFuncType func)

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

481482 (Left err, _) -> Left err

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

483484

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

486+castRelation :: Atom -> Relation

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

488+ Just rel -> rel

489+ Nothing -> error "castRelation failure"

490+

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

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

493+ Just x -> x

494+ Nothing -> error "unsafeCast failed"

495+

484496basicAtomFunctions :: AtomFunctions

485497basicAtomFunctions = HS.fromList [

486498 --match on any relation type

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

499+ AtomFunction { atomFuncName = "add",

500+ atomFuncType = [intAtomType, intAtomType, intAtomType],

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

488502 AtomFunction { atomFuncName = "id",

489503 atomFuncType = [AnyAtomType, AnyAtomType],

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

491505 AtomFunction { atomFuncName = "sum",

492− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

506+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

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

494508 AtomFunction { atomFuncName = "count",

495− atomFuncType = foldAtomFuncType AnyAtomType IntAtomType,

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

509+ atomFuncType = foldAtomFuncType AnyAtomType intAtomType,

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

497511 AtomFunction { atomFuncName = "max",

498− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

512+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

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

500514 AtomFunction { atomFuncName = "min",

501− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

515+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

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

503517 AtomFunction { atomFuncName = "lt",

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

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

505519 atomFunc = intAtomFuncLessThan False},

506520 AtomFunction { atomFuncName = "lte",

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

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

508522 atomFunc = intAtomFuncLessThan True},

509523 AtomFunction { atomFuncName = "gte",

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

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

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

512526 AtomFunction { atomFuncName = "gt",

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

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

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

515529 AtomFunction { atomFuncName = "not",

516− atomFuncType = [BoolAtomType, BoolAtomType],

530+ atomFuncType = [boolAtomType, boolAtomType],

517531 atomFunc = boolAtomNot}

518532 ]

519533

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

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

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

522536 where

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

524−intAtomFuncLessThan _ _= BoolAtom False

538+intAtomFuncLessThan _ _= Atom False

525539

526540boolAtomNot :: [Atom] -> Atom

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

528−boolAtomNot _ = BoolAtom False

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

542+boolAtomNot _ = Atom False

529543

ProjectM36/TransactionGraph.hs+35−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,23 @@ 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 _ -> Right [Atom $ T.pack $ show (transactionUUID transaction),

228+ Atom $ parentUUID == transactionUUID transaction,

229+ Atom $ case headNameForTransaction transaction graph of

230230 Just headName -> headName

231231 Nothing -> ""

232232 ]

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

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

241241 mkRelationFromTuples attrs tuples

242242 where

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

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

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

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

README.markdown+1−1

@@ -28,7 +28,7 @@ Project:M36 supports multiple frontends which target different audiences.

28281. [Transaction Graph Operators](docs/transaction_graph_operators.markdown)

29291. [Persistent Library Driver](docs/persistent_library_driver.markdown)

30301. [ProjectM36.Client Library](docs/projectm36_client_library.markdown)

31−

31+1. [Adding New Data Types](docs/new_datatypes.markdown)

3232

3333## Development

3434

TutorialD/Interpreter/Base.hs+8−7

@@ -10,6 +10,7 @@ import qualified Data.List as L

1010import qualified Data.Vector as V

1111import qualified Data.Text.IO as TIO

1212import System.IO

13+import ProjectM36.Atom

1314

1415lexer :: Token.TokenParser ()

1516lexer = Token.makeTokenParser tutD

@@ -52,14 +53,14 @@ float = Token.float lexer

5253

5354atomTypeToTutDType :: AtomType -> Maybe T.Text

5455atomTypeToTutDType atomType = case atomType of

55− StringAtomType -> Just "char"

56− IntAtomType -> Just "int"

57− DateTimeAtomType -> Just "datetime"

58− DoubleAtomType -> Just "double"

59− DateAtomType -> Just "date"

60− RelationAtomType attrs -> Just $ "relation" `T.append` showRelationAttributes attrs

56+ aType@(AtomType _) -> lookup aType [(stringAtomType, "char"),

57+ (intAtomType, "int"),

58+ (boolAtomType, "bool"),

59+ (dateTimeAtomType, "datetime"),

60+ (doubleAtomType, "double")]

61+ (RelationAtomType attrs) -> Just $ "relation" `T.append` showRelationAttributes attrs

6162 _ -> Nothing

62−

63+

6364showRelationAttributes :: Attributes -> T.Text

6465showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"

6566 where

TutorialD/Interpreter/RelationalExpr.hs+43−17

@@ -18,14 +18,17 @@ import Control.Applicative (liftA)

1818import Data.ByteString.Base64 as B64

1919import Data.Text.Encoding as TE

2020

21+import Data.Time.Calendar (Day)

22+import Data.Time.Clock (UTCTime)

23+

2124atomTypeP :: Parser AtomType

22−atomTypeP = (reserved "char" *> return StringAtomType) <|>

23− (reserved "int" *> return IntAtomType) <|>

24− (reserved "datetime" *> return DateTimeAtomType) <|>

25− (reserved "date" *> return DateAtomType) <|>

26− (reserved "double" *> return DoubleAtomType) <|>

27− (reserved "bool" *> return BoolAtomType) <|>

28− (reserved "bytestring" *> return ByteStringAtomType) <|>

25+atomTypeP = (reserved "char" *> return stringAtomType) <|>

26+ (reserved "int" *> return intAtomType) <|>

27+ (reserved "datetime" *> return dateTimeAtomType) <|>

28+ (reserved "date" *> return dateAtomType) <|>

29+ (reserved "double" *> return doubleAtomType) <|>

30+ (reserved "bool" *> return boolAtomType) <|>

31+ (reserved "bytestring" *> return byteStringAtomType) <|>

2932 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))

3033

3134--used in projection

@@ -227,8 +230,16 @@ nakedAtomExprP :: Parser AtomExpr

227230nakedAtomExprP = NakedAtomExpr <$> atomP

228231

229232atomP :: Parser Atom

230−atomP = dateTimeAtomP <|> dateAtomP <|> byteStringAtomP <|>

231− stringAtomP <|> doubleAtomP <|> intAtomP <|> boolAtomP <|> relationAtomP

233+atomP = dateTimeAtomP <|>

234+ dateAtomP <|>

235+ maybeTextAtomP <|>

236+ maybeIntAtomP <|>

237+ byteStringAtomP <|>

238+ stringAtomP <|>

239+ doubleAtomP <|>

240+ intAtomP <|>

241+ boolAtomP <|>

242+ relationAtomP

232243

233244functionAtomExprP :: Parser AtomExpr

234245functionAtomExprP = do

@@ -240,7 +251,20 @@ relationalAtomExprP :: Parser AtomExpr

240251relationalAtomExprP = RelationAtomExpr <$> relExprP

241252

242253stringAtomP :: Parser Atom

243−stringAtomP = liftA (StringAtom . T.pack) quotedString

254+stringAtomP = liftA (Atom . T.pack) quotedString

255+

256+--until polymorphic type constructors and algebraic data types are properly supported, such constructs must be unfortunately hard-coded

257+maybeTextAtomP :: Parser Atom

258+maybeTextAtomP = do

259+ maybeText <- try $ ((Just . T.pack <$> (reserved "Just" *> quotedString)) <|>

260+ (reserved "nothing" *> return Nothing)) <* reserved "::maybe char"

261+ return $ Atom maybeText

262+

263+maybeIntAtomP :: Parser Atom

264+maybeIntAtomP = do

265+ maybeInt <- try $ ((Just . fromIntegral <$> (reserved "Just" *> integer)) <|>

266+ (reserved "nothing" *> return Nothing)) <* reserved "::maybe int"

267+ return $ Atom (maybeInt :: Maybe Int)

244268

245269dateTimeAtomP :: Parser Atom

246270dateTimeAtomP = do

@@ -249,7 +273,7 @@ dateTimeAtomP = do

249273 reserved "::datetime"

250274 return dateTimeString

251275 case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" dateTimeString' of

252− Just utctime -> return $ DateTimeAtom utctime

276+ Just utctime -> return $ Atom (utctime :: UTCTime)

253277 Nothing -> fail "Failed to parse datetime"

254278

255279dateAtomP :: Parser Atom

@@ -259,22 +283,24 @@ dateAtomP = do

259283 reserved "::date"

260284 return dateString

261285 case parseTimeM False defaultTimeLocale "%Y-%m-%d" dateString' of

262− Just utctime -> return $ DateAtom utctime

286+ Just todaytime -> return $ Atom (todaytime :: Day)

263287 Nothing -> fail "Failed to parse date"

264288

265289doubleAtomP :: Parser Atom

266−doubleAtomP = DoubleAtom <$> (try float)

290+doubleAtomP = Atom <$> (try float)

267291

268292intAtomP :: Parser Atom

269−intAtomP = (IntAtom . fromIntegral) <$> integer

293+intAtomP = do

294+ i <- integer

295+ return $ Atom ((fromIntegral i) :: Int)

270296

271297boolAtomP :: Parser Atom

272298boolAtomP = do

273299 val <- char 't' <|> char 'f'

274− return $ BoolAtom (val == 't')

300+ return $ Atom (val == 't')

275301

276302relationAtomP :: Parser Atom

277−relationAtomP = RelationAtom <$> relationP

303+relationAtomP = Atom <$> relationP

278304

279305byteStringAtomP :: Parser Atom

280306byteStringAtomP = do

@@ -284,7 +310,7 @@ byteStringAtomP = do

284310 return byteString

285311 case B64.decode $ TE.encodeUtf8 (T.pack byteString') of

286312 Left err -> fail err

287− Right bsVal -> return $ ByteStringAtom bsVal

313+ Right bsVal -> return $ Atom bsVal

288314

289315--relation constructor -- no choice but to propagate relation-construction errors as parse errors. Perhaps this could be improved in the future

290316relationP :: Parser Relation

benchmark/bigrel.hs+2−3

@@ -1,7 +1,6 @@

11{-# LANGUAGE FlexibleInstances,OverloadedStrings #-}

22import ProjectM36.Base

33import ProjectM36.Relation

4−import ProjectM36.Tuple

54import ProjectM36.Relation.Show.CSV

65import ProjectM36.Relation.Show.HTML

76import TutorialD.Interpreter.Base (displayOpResult)

@@ -73,7 +72,7 @@ intmapMatrixRun = do

7372intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)

7473intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]

7574 where

76− mapper tupCount = IM.fromList $ map (\c-> (c, IntAtom tupCount)) [0..attributeCount]

75+ mapper tupCount = IM.fromList $ map (\c-> (c, Atom tupCount)) [0..attributeCount]

7776

7877instance Hash.Hashable (IM.IntMap Atom) where

7978 hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)

@@ -88,7 +87,7 @@ vectorMatrixRun = do

8887vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)

8988vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]

9089 where

91− mapper tupCount = V.replicate attributeCount (IntAtom tupCount)

90+ mapper tupCount = V.replicate attributeCount (Atom tupCount)

9291

9392instance Hash.Hashable (V.Vector Atom) where

9493 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)

docs/new_datatypes.markdownnew file+20

@@ -0,0 +1,20 @@

1+# Creating New Data Types

3+## Introduction

5+The most common data types are built into Project:M36 directly. Such types include integers, text, byte strings, booleans and floats. It can often be handy to create one's own data types in a database and manipulate them as first-class values through the relational algebra.

7+Project: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.

9+## Support

10+

11+Any Haskell data type which is an instance of ```Atomable``` is a candidate for a Project:M36 value called an ```Atom```. Database tuples are composed of Atoms.

12+

13+Project:M36 does not yet support dynamically-loaded components, so the data type must be compiled into the Project:M36 backend.

14+

15+### Implementation

16+

17+1. Create an instance of your data type for the ```Atomable``` typeclass. The ```Atomable``` typeclass implies instances for a variety of standard typeclasses.

18+1. Update the ```Binary Atom``` instance to include deserialization for your type.

19+1. Update the ```makeAtomFromText``` in ```ProjectM36/Atom.hs``` to support CSV import.

20+1. Optionally adjust ```TutorialD/Interpreter/RelationalExpression.hs``` to add support for parsing your data type in the TutorialD interpreter. Look for ```atomP```.

test/Relation/Basic.hs+5−5

@@ -62,8 +62,8 @@ simpleRel = case mkRelation attrs tupleSet of

6262 Right rel -> rel

6363 Left _ -> undefined

6464 where

65− attrs = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" StringAtomType]

66− tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [StringAtom "spam", StringAtom "spam2"])]

65+ attrs = A.attributesFromList [Attribute "a" stringAtomType, Attribute "b" stringAtomType]

66+ tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [stringAtom "spam", stringAtom "spam2"])]

6767

6868--rename tests

6969testRename1 :: Test

@@ -77,7 +77,7 @@ testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRe

7777testMkRelation1 :: Test

7878testMkRelation1 = TestCase $ assertEqual "key mismatch" (Left $ TupleAttributeTypeMismatchError A.emptyAttributes) (mkRelation testAttrs testTupSet) -- the error attribute set is empty due to an optimization- the tuple attrs do not match the atoms' types

7979 where

80− testAttrs = A.attributesFromList [Attribute "a" StringAtomType]

81− testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],

82− mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]

80+ testAttrs = A.attributesFromList [Attribute "a" stringAtomType]

81+ testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [stringAtom "v"],

82+ mkRelationTuple testAttrs $ V.fromList [intAtom 2]]

8383

test/Relation/Export/CSV.hs+7−6

@@ -6,6 +6,7 @@ import ProjectM36.Relation.Show.CSV

66import ProjectM36.Relation.Parse.CSV

77import qualified ProjectM36.Attribute as A

88import ProjectM36.Relation

9+import ProjectM36.Atom

910

1011main :: IO ()

1112main = do

@@ -15,13 +16,13 @@ main = do

1516--round-trip a basic relation through CSV

1617testCSVExport :: Test

1718testCSVExport = TestCase $ do

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

19− Attribute "SNAME" StringAtomType,

20− Attribute "STATUS" IntAtomType,

21− Attribute "CITY" StringAtomType]

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

20+ Attribute "SNAME" stringAtomType,

21+ Attribute "STATUS" intAtomType,

22+ Attribute "CITY" stringAtomType]

2223 relOrErr = mkRelationFromList attrs [

23− [StringAtom "S9", StringAtom "Perry", IntAtom 170, StringAtom "Londonderry"],

24− [StringAtom "S8", StringAtom "Mike", IntAtom 150, StringAtom "Boston"]]

24+ [stringAtom "S9", stringAtom "Perry", intAtom 170, stringAtom "Londonderry"],

25+ [stringAtom "S8", stringAtom "Mike", intAtom 150, stringAtom "Boston"]]

2526 case relOrErr of

2627 Left err -> assertFailure $ "export relation creation failure: " ++ (show err)

2728 Right rel -> do

test/Relation/Import/CSV.hs+7−6

@@ -7,6 +7,7 @@ import qualified ProjectM36.Attribute as A

77import System.Exit

88import qualified Data.Text.Lazy as T

99import Data.Text.Lazy.Encoding

10+import ProjectM36.Atom

1011

1112main :: IO ()

1213main = do

@@ -16,13 +17,13 @@ main = do

1617testCSVSuccess :: Test

1718testCSVSuccess = TestCase $ do

1819 let sampleCSV = (encodeUtf8 . T.pack) "S#,CITY,STATUS,SNAME\n\"S8\",\"Boston\",150,\"Mike\"\nS9,Londonderry,170,Perry"

19− expectedAttrs = A.attributesFromList [Attribute "S#" StringAtomType,

20− Attribute "SNAME" StringAtomType,

21− Attribute "STATUS" IntAtomType,

22− Attribute "CITY" StringAtomType]

20+ expectedAttrs = A.attributesFromList [Attribute "S#" stringAtomType,

21+ Attribute "SNAME" stringAtomType,

22+ Attribute "STATUS" intAtomType,

23+ Attribute "CITY" stringAtomType]

2324 expectedRel = mkRelationFromList expectedAttrs [

24− [StringAtom "S9", StringAtom "Perry", IntAtom 170, StringAtom "Londonderry"],

25− [StringAtom "S8", StringAtom "Mike", IntAtom 150, StringAtom "Boston"]]

25+ [stringAtom "S9", stringAtom "Perry", intAtom 170, stringAtom "Londonderry"],

26+ [stringAtom "S8", stringAtom "Mike", intAtom 150, stringAtom "Boston"]]

2627 case csvAsRelation sampleCSV expectedAttrs of

2728 Left err -> assertFailure $ show err

2829 Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel)

test/TutorialD/Interpreter.hs+61−52

@@ -11,6 +11,7 @@ import ProjectM36.Error

1111import ProjectM36.Base

1212import ProjectM36.TransactionGraph

1313import ProjectM36.Client

14+import ProjectM36.Atom

1415import qualified ProjectM36.Attribute as A

1516import qualified Data.Map as M

1617import System.Exit

@@ -18,6 +19,8 @@ import Data.Maybe (isJust)

1819import System.IO

1920import qualified Data.Vector as V

2021import Data.Text.Encoding as TE

22+import Data.Typeable (Proxy(..))

23+import Data.Text (Text)

2124

2225--urgent: add group and ungroup tests- I missed the group relation type bug

2326main :: IO ()

@@ -33,7 +36,7 @@ main = do

3336 ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),

3437 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),

3538 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),

36− ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [(RelationTuple simpleCAttributes) (V.fromList [StringAtom "spam", IntAtom 5])]),

39+ ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [(RelationTuple simpleCAttributes) (V.fromList [stringAtom "spam", intAtom 5])]),

3740 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),

3841 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),

3942 ("x:=true where true", Right relationTrue),

@@ -45,54 +48,60 @@ main = do

4548 ("x:=true=true", Right relationTrue),

4649 ("x:=true=false", Right relationFalse),

4750 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),

48− ("x:=relation {b int, a char}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [StringAtom "spam", IntAtom 5]]),

51+ ("x:=relation {b int, a char}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList[stringAtom "spam", intAtom 5]]),

4952 -- test nested relation constructor

50− ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntAtom 6]])])]),

51− ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [StringAtom "spam", IntAtom 5])]),

52− ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])]),

53− ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 6])]),

54− ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 10])]),

55− ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntAtomType StringAtomType)),

56− ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 12])])

53+ ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [intAtom 5, Atom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [intAtom 6]])])]),

54+ ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [stringAtom "spam", intAtom 5])]),

55+ ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 5])]),

56+ ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 6])]),

57+ ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 10])]),

58+ ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 intAtomType stringAtomType)),

59+ ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 12])])

5760 ]

58− simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]

59− simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]

60− simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]

61− simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]

62− byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]

63− simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]

64− nestedRelationAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntAtomType])]

65− extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

66− groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]

67− minMaxAttrs = A.attributesFromList [Attribute "S#" StringAtomType, Attribute "z" IntAtomType]

61+ simpleAAttributes = A.attributesFromList [Attribute "a" intAtomType]

62+ simpleBAttributes = A.attributesFromList [Attribute "d" intAtomType]

63+ simpleCAttributes = A.attributesFromList [Attribute "a" stringAtomType, Attribute "b" intAtomType]

64+ simpleDAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" intAtomType]

65+ simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Text))]

66+ simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Int))]

67+ simpleProjectionAttributes = A.attributesFromList [Attribute "c" intAtomType]

68+ nestedRelationAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" intAtomType])]

69+ extendTestAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

70+ byteStringAttributes = A.attributesFromList [Attribute "y" byteStringAtomType]

71+ groupCountAttrs = A.attributesFromList [Attribute "z" intAtomType]

72+ minMaxAttrs = A.attributesFromList [Attribute "S#" stringAtomType, Attribute "z" intAtomType]

6873 dateExampleRelTests = [("x:=S where true", Right suppliersRel),

69− ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ StringAtom "London")) suppliersRel),

74+ ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ stringAtom "London")) suppliersRel),

7075 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),

71− ("x:=P where COLOR=\"Blue\" and CITY=\"Paris\"", mkRelationFromList (attributes productsRel) [[StringAtom "P5", StringAtom "Cam", StringAtom "Blue", IntAtom 12, StringAtom "Paris"]]),

72− ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50])])),

76+ ("x:=P where COLOR=\"Blue\" and CITY=\"Paris\"", mkRelationFromList (attributes productsRel) [[stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"]]),

77+ ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [Attribute "STATUS" intAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "STATUS" intAtomType]) (V.fromList [intAtom 50])])),

7378 --atom function tests

7479 ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),

75− ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),

76− ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel])])),

80+ ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ stringAtom "Blake") then updateTuple (M.singleton "CITY" (stringAtom "Boston")) tuple else tuple) suppliersRel),

81+ ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [intAtom 5, Atom suppliersRel])])),

7782 --relatom function tests

78− ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1)])),

83+ ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ intAtom 1)])),

7984 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),

80− ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=max(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),

81− ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=min(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),

82− ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=sum(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),

85+ ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=max(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [stringAtom s,intAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),

86+ ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=min(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [stringAtom s,intAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),

87+ ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=sum(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [stringAtom s,intAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),

8388 --boolean function restriction

84− ("x:=S where ^lt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),

85− ("x:=S where ^gt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],

86− [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]),

87− ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),

88− ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),

89+ ("x:=S where ^lt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"]]),

90+ ("x:=S where ^gt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],

91+ [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]),

92+ ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError intAtomType boolAtomType),

93+ ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"]]),

8994 --test "all but" attribute inversion syntax

9095 ("x:=S{all but S#} = S{CITY,SNAME,STATUS}", Right $ relationTrue),

9196 --test key syntax

9297 ("x:=S; key testconstraint {S#,CITY} x; insert x relation{tuple{CITY \"London\", S# \"S1\", SNAME \"gonk\", STATUS 50}}", Left (InclusionDependencyCheckError "testconstraint")),

9398 ("y:=S; key testconstraint {S#} y; insert y relation{tuple{CITY \"London\", S# \"S6\", SNAME \"gonk\", STATUS 50}}; x:=y{S#} = S{S#} union relation{tuple{S# \"S6\"}}", Right $ relationTrue),

9499 --test binary bytestring data type

95− ("x:=relation{tuple{y \"dGVzdGRhdGE=\"::bytestring}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]])

100+ ("x:=relation{tuple{y \"dGVzdGRhdGE=\"::bytestring}}", mkRelationFromList byteStringAttributes [[Atom (TE.encodeUtf8 "testdata")]]),

101+ --test Maybe Text

102+ ("x:=relation{tuple{a Just \"spam\"::maybe char}}", mkRelationFromList simpleMaybeTextAttributes [[Atom (Just "spam" :: Maybe Text)]]),

103+ --test Maybe Int

104+ ("x:=relation{tuple{a Just 3::maybe int}}", mkRelationFromList simpleMaybeIntAttributes [[Atom (Just 3 :: Maybe Int)]])

96105 ]

97106

98107

@@ -183,24 +192,24 @@ transactionBranchTest = TestCase $ do

183192simpleJoinTest :: Test

184193simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP"

185194 where

186− attrs = A.attributesFromList [Attribute "CITY" StringAtomType,

187− Attribute "QTY" IntAtomType,

188− Attribute "P#" StringAtomType,

189− Attribute "S#" StringAtomType,

190− Attribute "SNAME" StringAtomType,

191− Attribute "STATUS" IntAtomType]

192− joinedRel = mkRelationFromList attrs [[StringAtom "London", IntAtom 100, StringAtom "P6", StringAtom "S1", StringAtom "Smith", IntAtom 20],

193− [StringAtom "London", IntAtom 400, StringAtom "P3", StringAtom "S1", StringAtom "Smith", IntAtom 20],

194− [StringAtom "London", IntAtom 400, StringAtom "P5", StringAtom "S4", StringAtom "Clark", IntAtom 20],

195− [StringAtom "London", IntAtom 300, StringAtom "P1", StringAtom "S1", StringAtom "Smith", IntAtom 20],

196− [StringAtom "Paris", IntAtom 200, StringAtom "P2", StringAtom "S3", StringAtom "Blake", IntAtom 30],

197− [StringAtom "Paris", IntAtom 300, StringAtom "P1", StringAtom "S2", StringAtom "Jones", IntAtom 10],

198− [StringAtom "London", IntAtom 100, StringAtom "P5", StringAtom "S1", StringAtom "Smith", IntAtom 20],

199− [StringAtom "London", IntAtom 300, StringAtom "P4", StringAtom "S4", StringAtom "Clark", IntAtom 20],

200− [StringAtom "Paris", IntAtom 400, StringAtom "P2", StringAtom "S2", StringAtom "Jones", IntAtom 10],

201− [StringAtom "London", IntAtom 200, StringAtom "P2", StringAtom "S1", StringAtom "Smith", IntAtom 20],

202− [StringAtom "London", IntAtom 200, StringAtom "P4", StringAtom "S1", StringAtom "Smith", IntAtom 20],

203− [StringAtom "London", IntAtom 200, StringAtom "P2", StringAtom "S4", StringAtom "Clark", IntAtom 20]

195+ attrs = A.attributesFromList [Attribute "CITY" stringAtomType,

196+ Attribute "QTY" intAtomType,

197+ Attribute "P#" stringAtomType,

198+ Attribute "S#" stringAtomType,

199+ Attribute "SNAME" stringAtomType,

200+ Attribute "STATUS" intAtomType]

201+ joinedRel = mkRelationFromList attrs [[stringAtom "London", intAtom 100, stringAtom "P6", stringAtom "S1", stringAtom "Smith", intAtom 20],

202+ [stringAtom "London", intAtom 400, stringAtom "P3", stringAtom "S1", stringAtom "Smith", intAtom 20],

203+ [stringAtom "London", intAtom 400, stringAtom "P5", stringAtom "S4", stringAtom "Clark", intAtom 20],

204+ [stringAtom "London", intAtom 300, stringAtom "P1", stringAtom "S1", stringAtom "Smith", intAtom 20],

205+ [stringAtom "Paris", intAtom 200, stringAtom "P2", stringAtom "S3", stringAtom "Blake", intAtom 30],

206+ [stringAtom "Paris", intAtom 300, stringAtom "P1", stringAtom "S2", stringAtom "Jones", intAtom 10],

207+ [stringAtom "London", intAtom 100, stringAtom "P5", stringAtom "S1", stringAtom "Smith", intAtom 20],

208+ [stringAtom "London", intAtom 300, stringAtom "P4", stringAtom "S4", stringAtom "Clark", intAtom 20],

209+ [stringAtom "Paris", intAtom 400, stringAtom "P2", stringAtom "S2", stringAtom "Jones", intAtom 10],

210+ [stringAtom "London", intAtom 200, stringAtom "P2", stringAtom "S1", stringAtom "Smith", intAtom 20],

211+ [stringAtom "London", intAtom 200, stringAtom "P4", stringAtom "S1", stringAtom "Smith", intAtom 20],

212+ [stringAtom "London", intAtom 200, stringAtom "P2", stringAtom "S4", stringAtom "Clark", intAtom 20]

204213 ]

205214

206215dateExamplesConnection :: IO (Connection)

test/TutorialD/Interpreter/Import/TutorialD.hs+3−2

@@ -1,6 +1,7 @@

11{-# LANGUAGE OverloadedStrings #-}

22import Test.HUnit

33import ProjectM36.Base

4+import ProjectM36.Atom

45import qualified ProjectM36.Attribute as A

56import TutorialD.Interpreter.Import.TutorialD

67import System.Exit

@@ -20,7 +21,7 @@ testTutdImport = TestCase $ do

2021 withSystemTempFile "m.tutd" $ \tempPath handle -> do

2122 hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"

2223 hClose handle

23− let expectedExpr = MultipleExpr [Assign "x" (ExistingRelation (Relation expectedAttrs $ RelationTupleSet [RelationTuple expectedAttrs $ V.fromList [IntAtom 5, StringAtom "spam"]]))]

24− expectedAttrs = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" StringAtomType]

24+ let expectedExpr = MultipleExpr [Assign "x" (ExistingRelation (Relation expectedAttrs $ RelationTupleSet [RelationTuple expectedAttrs $ V.fromList [intAtom 5, stringAtom "spam"]]))]

25+ expectedAttrs = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" stringAtomType]

2526 imported <- importTutorialD tempPath DC.empty

2627 assertEqual "import tutd" (Right expectedExpr) imported

test/persistent-driver/test.hs+2−1

@@ -10,6 +10,7 @@

1010import Test.HUnit

1111import Database.Persist.ProjectM36

1212import ProjectM36.Client

13+import ProjectM36.Atom

1314import qualified ProjectM36.Client as C

1415import System.Exit

1516import Database.Persist

@@ -41,7 +42,7 @@ inProcSettings = InProcessConnectionInfo NoPersistence

4142

4243defPersonRel :: Connection -> IO ()

4344defPersonRel conn = do

44− maybeErr <- C.executeDatabaseContextExpr conn (Define "person" (attributesFromList [Attribute "name" StringAtomType, Attribute "age" IntAtomType, Attribute "id" StringAtomType]))

45+ maybeErr <- C.executeDatabaseContextExpr conn (Define "person" (attributesFromList [Attribute "name" stringAtomType, Attribute "age" intAtomType, Attribute "id" stringAtomType]))

4546 case maybeErr of

4647 Nothing -> return ()

4748 Just err -> assertFailure $ "defPersonRel" ++ show err