git.iko.soy/project-m36
on master help sign in
Merge branch 'atom_typeclass_simple'
cb07a7dAgentM
Database/Persist/ProjectM36.hs+104−98
compare with master
unifiedsplit
@@ -29,9 +29,12 @@ import Control.Monad.Trans.Either
29import qualified Database.Persist.Types as DPT
29import qualified Database.Persist.Types as DPT
30import qualified Data.Set as S
30import qualified Data.Set as S
31import qualified Data.Conduit.List as CL
31import 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
32
37
33−type ProjectM36Backend = C.Connection
34−
35--convert a PersistEntity to a RelationTuple
38--convert a PersistEntity to a RelationTuple
36recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
39recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
37 => Maybe U.UUID -> record -> Either RelationalError RelationTuple
40 => 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
42 attrVec <- recordAttributes entInfo record
45 attrVec <- recordAttributes entInfo record
43 atomVec <- recordAsAtoms uuid attrVec record
46 atomVec <- recordAsAtoms uuid attrVec record
44 return $ RelationTuple attrVec atomVec
47 return $ RelationTuple attrVec atomVec
45−
48+
46recordAttributes :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
49recordAttributes :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
47 => [(EmbedFieldDef, PersistValue)] -> record -> Either RelationalError Attributes
50 => [(EmbedFieldDef, PersistValue)] -> record -> Either RelationalError Attributes
48recordAttributes entInfo record = do
51recordAttributes entInfo record = do
49 let convertAttr = uncurry fieldDefAsAttribute
52 let convertAttr = uncurry fieldDefAsAttribute
50 idDBName = unDBName $ fieldDB $ entityId (entityDef $ Just record)
53 idDBName = unDBName $ fieldDB $ entityId (entityDef $ Just record)
51 attrList <- mapM convertAttr entInfo
54 attrList <- mapM convertAttr entInfo
52− return $ V.fromList ([Attribute idDBName StringAtomType] ++ attrList)
55+ return $ V.fromList ([Attribute idDBName stringAtomType] ++ attrList)
53−
56+
54fieldDefAsAttribute :: EmbedFieldDef -> PersistValue -> Either RelationalError Attribute
57fieldDefAsAttribute :: EmbedFieldDef -> PersistValue -> Either RelationalError Attribute
55fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of
58fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of
56 Nothing -> Left $ AtomTypeNotSupported attrName
59 Nothing -> Left $ AtomTypeNotSupported attrName
57 Just fType -> Right $ Attribute attrName fType
60 Just fType -> Right $ Attribute attrName fType
58− where
61+ where
59 attrName = unDBName $ emFieldDB fieldDef
62 attrName = unDBName $ emFieldDB fieldDef
60−
63+
61−persistValueAtomType :: PersistValue -> Maybe AtomType
64+persistValueAtomType :: PersistValue -> Maybe AtomType
62persistValueAtomType val = do
65persistValueAtomType val = do
63 atom <- persistValueAtom val
66 atom <- persistValueAtom val
64 return $ atomTypeForAtom atom
67 return $ atomTypeForAtom atom
65−
68+
66persistValueAtom :: PersistValue -> Maybe Atom
69persistValueAtom :: PersistValue -> Maybe Atom
67persistValueAtom val = case val of
70persistValueAtom val = case val of
68− PersistText v -> return $ StringAtom v
71+ PersistText v -> return $ Atom v
69− PersistInt64 v -> return $ IntAtom (fromIntegral v)
72+ PersistInt64 v -> return $ Atom ((fromIntegral v)::Int)
70− PersistBool v -> return $ BoolAtom v
73+ PersistBool v -> return $ Atom v
71− PersistDay v -> return $ DateAtom v
74+ PersistDay v -> return $ Atom v
72 _ -> Nothing
75 _ -> Nothing
73−
76+
74−atomAsPersistValue :: Atom -> PersistValue
77+atomAsPersistValue :: Atom -> PersistValue
75−atomAsPersistValue a = case a of
78+atomAsPersistValue atom@(Atom atomv) = if typeRep (Proxy :: Proxy Int) == typeOf atomv then
76− StringAtom v -> PersistText v
77− IntAtom v -> PersistInt64 (fromIntegral v)
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
78− BoolAtom v -> PersistBool v
83+ PersistBool (unsafeCast atom)
84+ else if typeRep (Proxy :: Proxy Day) == typeOf atomv then
79− DateAtom v -> PersistDay v
85+ PersistDay (unsafeCast atom)
86+ else
80− _ -> error "missing conversion"
87+ error "missing conversion"
81−
88+
82recordAsAtoms :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
89recordAsAtoms :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
83 => Maybe U.UUID -> Attributes -> record -> Either RelationalError (V.Vector Atom)
90 => Maybe U.UUID -> Attributes -> record -> Either RelationalError (V.Vector Atom)
84recordAsAtoms freshUUID _ record = do
91recordAsAtoms freshUUID _ record = do
@@ -87,37 +94,37 @@ recordAsAtoms freshUUID _ record = do
87 Nothing -> Left $ AtomTypeNotSupported ""
94 Nothing -> Left $ AtomTypeNotSupported ""
88 Just atom -> Right atom
95 Just atom -> Right atom
89 atoms <- mapM valAtom pValues
96 atoms <- mapM valAtom pValues
90− return $ V.fromList $ case freshUUID of
97+ return $ V.fromList $ case freshUUID of
91 Nothing -> atoms
98 Nothing -> atoms
92− Just uuid -> [StringAtom $ T.pack (U.toString uuid)] ++ atoms
99+ Just uuid -> [Atom $ T.pack (U.toString uuid)] ++ atoms
93−
100+
94--used by insert operations
101--used by insert operations
95−recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection) =>
102+recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection) =>
96 [(Maybe U.UUID, record)] -> Either RelationalError Relation
103 [(Maybe U.UUID, record)] -> Either RelationalError Relation
97recordsAsRelation [] = Left EmptyTuplesError
104recordsAsRelation [] = Left EmptyTuplesError
98recordsAsRelation recordZips = do
105recordsAsRelation recordZips = do
99 tupleList <- mapM (uncurry recordAsTuple) recordZips
106 tupleList <- mapM (uncurry recordAsTuple) recordZips
100 let oneTuple = head tupleList
107 let oneTuple = head tupleList
101 mkRelation (tupleAttributes oneTuple) (RelationTupleSet tupleList)
108 mkRelation (tupleAttributes oneTuple) (RelationTupleSet tupleList)
102−
109+
103−keyFromValuesOrDie :: (Trans.MonadIO m,
110+keyFromValuesOrDie :: (Trans.MonadIO m,
104− PersistEntity record,
111+ PersistEntity record,
105 PersistEntityBackend record ~ C.Connection
112 PersistEntityBackend record ~ C.Connection
106 ) => [PersistValue] -> m (Key record)
113 ) => [PersistValue] -> m (Key record)
107keyFromValuesOrDie val = case keyFromValues val of
114keyFromValuesOrDie val = case keyFromValues val of
108 Right k -> return k
115 Right k -> return k
109 Left _ -> Trans.liftIO $ throwIO $ PersistError "key pooped"
116 Left _ -> Trans.liftIO $ throwIO $ PersistError "key pooped"
110−
117+
111insertNewRecords :: (Trans.MonadIO m,
118insertNewRecords :: (Trans.MonadIO m,
112 PersistEntity record,
119 PersistEntity record,
113 PersistEntityBackend record ~ C.Connection) =>
120 PersistEntityBackend record ~ C.Connection) =>
114 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]
121 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]
115insertNewRecords uuids records = do
122insertNewRecords uuids records = do
116− let recordsZip = zip (map Just uuids) records
123+ let recordsZip = zip (map Just uuids) records
117− insertExpr = Insert (relVarNameFromRecord $ head records)
124+ insertExpr = Insert (relVarNameFromRecord $ head records)
118 case recordsAsRelation recordsZip of
125 case recordsAsRelation recordsZip of
119 Left err -> throw $ PersistError (T.pack $ show err)
126 Left err -> throw $ PersistError (T.pack $ show err)
120− Right rel -> do
127+ Right rel -> do
121 conn <- ask
128 conn <- ask
122 Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))
129 Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))
123 mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids
130 mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids
@@ -126,8 +133,8 @@ throwIOPersistError :: (Trans.MonadIO m) => String -> m a
126throwIOPersistError msg = Trans.liftIO $ throwIO $ PersistError (T.pack msg)
133throwIOPersistError msg = Trans.liftIO $ throwIO $ PersistError (T.pack msg)
127
134
128lookupByKey :: forall record m.
135lookupByKey :: forall record m.
129− (Trans.MonadIO m,
136+ (Trans.MonadIO m,
130− PersistEntity record,
137+ PersistEntity record,
131 PersistEntityBackend record ~ C.Connection)
138 PersistEntityBackend record ~ C.Connection)
132 => Key record -> ReaderT C.Connection m (Maybe (Entity record))
139 => Key record -> ReaderT C.Connection m (Maybe (Entity record))
133lookupByKey key = do
140lookupByKey key = do
@@ -139,13 +146,13 @@ lookupByKey key = do
139 Left err -> throwIOPersistError ("executeRelationExpr error: " ++ show err)
146 Left err -> throwIOPersistError ("executeRelationExpr error: " ++ show err)
140 Right resultRel' -> case singletonTuple resultRel' of
147 Right resultRel' -> case singletonTuple resultRel' of
141 Nothing -> return Nothing --no match on key
148 Nothing -> return Nothing --no match on key
142− Just tuple -> do
149+ Just tuple -> do
143− let entityInfo = entityDefFromKey key
150+ let entityInfo = entityDefFromKey key
144 entity <- fromPersistValuesThrow entityInfo tuple --correct, one match
151 entity <- fromPersistValuesThrow entityInfo tuple --correct, one match
145 return $ Just entity
152 return $ Just entity
146−
153+
147−fromPersistValuesThrow :: (Trans.MonadIO m,
154+fromPersistValuesThrow :: (Trans.MonadIO m,
148− PersistEntity record,
155+ PersistEntity record,
149 PersistEntityBackend record ~ C.Connection) => EntityDef -> RelationTuple -> m (Entity record)
156 PersistEntityBackend record ~ C.Connection) => EntityDef -> RelationTuple -> m (Entity record)
150fromPersistValuesThrow entDef tuple = do
157fromPersistValuesThrow entDef tuple = do
151 let body = fromPersistValues $ map getValue (entityFields entDef)
158 let body = fromPersistValues $ map getValue (entityFields entDef)
@@ -160,17 +167,17 @@ fromPersistValuesThrow entDef tuple = do
160 Right key -> case body of
167 Right key -> case body of
161 Left err -> throwIOPersistError (show err)
168 Left err -> throwIOPersistError (show err)
162 Right body' -> return $ Entity key body'
169 Right body' -> return $ Entity key body'
163−
170+
164commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)
171commonKeyQueryProperties :: (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
166 let matchUUID = keyToUUID key
173 let matchUUID = keyToUUID key
167 keyAttributeName = unDBName (fieldDB $ entityId entityInfo)
174 keyAttributeName = unDBName (fieldDB $ entityId entityInfo)
168− relVarName = unDBName $ entityDB entityInfo
175+ relVarName = unDBName $ entityDB entityInfo
169 matchUUIDText = T.pack $ U.toString matchUUID
176 matchUUIDText = T.pack $ U.toString matchUUID
170− entityInfo = entityDefFromKey key
177+ entityInfo = entityDefFromKey key
171− restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (StringAtom matchUUIDText))
178+ restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (Atom matchUUIDText))
172 return (relVarName, restrictionPredicate)
179 return (relVarName, restrictionPredicate)
173−
180+
174deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (Bool)
181deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (Bool)
175deleteByKey key = do
182deleteByKey key = do
176 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
183 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
@@ -178,15 +185,15 @@ deleteByKey key = do
178 conn <- ask
185 conn <- ask
179 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query
186 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query
180 return $ isJust maybeErr
187 return $ isJust maybeErr
181−
188+
182−--convert persistent update list to ProjectM36 Update map
189+--convert persistent update list to ProjectM36 Update map
183−updatesToUpdateMap :: (Trans.MonadIO m,
190+updatesToUpdateMap :: (Trans.MonadIO m,
184 PersistEntityBackend val ~ C.Connection,
191 PersistEntityBackend val ~ C.Connection,
185 PersistEntity val) =>
192 PersistEntity val) =>
186 [DP.Update val] -> ReaderT C.Connection m (M.Map AttributeName Atom)
193 [DP.Update val] -> ReaderT C.Connection m (M.Map AttributeName Atom)
187−updatesToUpdateMap updates = do
194+updatesToUpdateMap updates = do
188 let convertMap upd = case updateUpdate upd of
195 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
190 newAttrValue = persistValueAtom (updatePersistValue upd) in
197 newAttrValue = persistValueAtom (updatePersistValue upd) in
191 case newAttrValue of
198 case newAttrValue of
192 Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"
199 Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"
@@ -194,8 +201,8 @@ updatesToUpdateMap updates = do
194 _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"
201 _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"
195 updateAtomList <- mapM convertMap updates
202 updateAtomList <- mapM convertMap updates
196 return $ M.fromList updateAtomList
203 return $ M.fromList updateAtomList
197−
204+
198−updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()
205+updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()
199updateByKey key updates = do
206updateByKey key updates = do
200 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
207 (relVarName, restrictionPredicate) <- commonKeyQueryProperties key
201 updateMap <- updatesToUpdateMap updates
208 updateMap <- updatesToUpdateMap updates
@@ -205,22 +212,22 @@ updateByKey key updates = do
205 case maybeErr of
212 case maybeErr of
206 Just err -> throwIOPersistError ("executeDatabaseExpr error" ++ show err)
213 Just err -> throwIOPersistError ("executeDatabaseExpr error" ++ show err)
207 Nothing -> return ()
214 Nothing -> return ()
208−
215+
209−--set the truth unconditionally
216+--set the truth unconditionally
210repsertByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
217repsertByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
211repsertByKey key val = do
218repsertByKey key val = do
212 _ <- delete key
219 _ <- delete key
213 insertKey key val
220 insertKey key val
214−
221+
215−replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
222+replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()
216replaceByKey key val = do
223replaceByKey key val = do
217 deletionSuccess <- deleteByKey key
224 deletionSuccess <- deleteByKey key
218 when (not deletionSuccess) (Trans.liftIO $ throwIO $ PersistError "entity missing during replace")
225 when (not deletionSuccess) (Trans.liftIO $ throwIO $ PersistError "entity missing during replace")
219 insertKey key val
226 insertKey key val
220−
227+
221entityDefFromKey :: PersistEntity record => Key record -> EntityDef
228entityDefFromKey :: PersistEntity record => Key record -> EntityDef
222entityDefFromKey = entityDef . Just . recordTypeFromKey
229entityDefFromKey = entityDef . Just . recordTypeFromKey
223−
230+
224dummyFromKey :: Key record -> Maybe record
231dummyFromKey :: Key record -> Maybe record
225dummyFromKey = Just . recordTypeFromKey
232dummyFromKey = Just . recordTypeFromKey
226
233
@@ -245,7 +252,7 @@ keyToUUID key = case keyToValues key of
245 Nothing -> error "error reading uuid from text in key construction"
252 Nothing -> error "error reading uuid from text in key construction"
246 Just uuid -> uuid
253 Just uuid -> uuid
247 _ -> error "unexpected persist value in key construction"
254 _ -> error "unexpected persist value in key construction"
248−
255+
249instance PersistStore C.Connection where
256instance PersistStore C.Connection where
250 newtype BackendKey C.Connection = ProjectM36Key { unPM36Key :: U.UUID }
257 newtype BackendKey C.Connection = ProjectM36Key { unPM36Key :: U.UUID }
251 deriving (Show, Read, Eq, Ord, PersistField)
258 deriving (Show, Read, Eq, Ord, PersistField)
@@ -254,19 +261,19 @@ instance PersistStore C.Connection where
254 insertMany records = do
261 insertMany records = do
255 freshUUIDs <- Trans.liftIO $ mapM (\_-> nextRandom) records
262 freshUUIDs <- Trans.liftIO $ mapM (\_-> nextRandom) records
256 insertNewRecords freshUUIDs records
263 insertNewRecords freshUUIDs records
257−
264+
258 insert record = do
265 insert record = do
259 keys <- insertMany [record]
266 keys <- insertMany [record]
260 return $ head keys
267 return $ head keys
261−
268+
262 --insertEntityMany [] = return []
269 --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 ()
264 insertKey key record = do
271 insertKey key record = do
265 let uuid = keyToUUID key
272 let uuid = keyToUUID key
266− _ <- insertNewRecords [uuid] [record]
273+ _ <- insertNewRecords [uuid] [record]
267 return ()
274 return ()
268−
275+
269− --get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val)
276+ --get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val)
270 get key = do
277 get key = do
271 ent <- lookupByKey key
278 ent <- lookupByKey key
272 case ent of
279 case ent of
@@ -275,37 +282,37 @@ instance PersistStore C.Connection where
275
282
276 repsert = repsertByKey
283 repsert = repsertByKey
277 --delete followed by insert "set the record as the truth
284 --delete followed by insert "set the record as the truth
278−
285+
279 delete key = deleteByKey key >> return ()
286 delete key = deleteByKey key >> return ()
280−
287+
281 replace = replaceByKey
288 replace = replaceByKey
282−
289+
283− --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()
290+ --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()
284 update = updateByKey
291 update = updateByKey
285−
292+
286−instance FromJSON (BackendKey C.Connection) where
293+instance FromJSON (BackendKey C.Connection) where
287 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))
294 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))
288−
295+
289instance ToJSON (BackendKey C.Connection) where
296instance ToJSON (BackendKey C.Connection) where
290 toJSON (ProjectM36Key uuid) = toJSON $ U.toString uuid
297 toJSON (ProjectM36Key uuid) = toJSON $ U.toString uuid
291−
298+
292−--wrapped version which throws exceptions
299+--wrapped version which throws exceptions
293executeDatabaseContextExpr :: C.Connection -> DatabaseExpr -> IO ()
300executeDatabaseContextExpr :: C.Connection -> DatabaseExpr -> IO ()
294executeDatabaseContextExpr conn expr = do
301executeDatabaseContextExpr conn expr = do
295 res <- C.executeDatabaseContextExpr conn expr
302 res <- C.executeDatabaseContextExpr conn expr
296 case res of
303 case res of
297 Nothing -> return ()
304 Nothing -> return ()
298 Just err -> throwIO (PersistError $ T.pack (show err))
305 Just err -> throwIO (PersistError $ T.pack (show err))
299−
306+
300relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)
307relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)
301 => record -> RelVarName
308 => record -> RelVarName
302relVarNameFromRecord = unDBName . entityDB . entityDef . Just
309relVarNameFromRecord = unDBName . entityDB . entityDef . Just
303−
310+
304{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
311{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
305updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
312updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
306updateFieldDef (DP.Update f _ _) = persistFieldDef f
313updateFieldDef (DP.Update f _ _) = persistFieldDef f
307updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"
314updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"
308−
315+
309updatePersistValue :: DP.Update v -> PersistValue
316updatePersistValue :: DP.Update v -> PersistValue
310updatePersistValue (DP.Update _ v _) = toPersistValue v
317updatePersistValue (DP.Update _ v _) = toPersistValue v
311updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"
318updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"
@@ -315,18 +322,18 @@ instance PersistField U.UUID where
315 fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of
322 fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of
316 Nothing -> Left "uuid text read failure"
323 Nothing -> Left "uuid text read failure"
317 Just uuid -> Right uuid
324 Just uuid -> Right uuid
318− fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
325+ fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
319
326
320instance FromJSON C.ConnectionInfo where
327instance FromJSON C.ConnectionInfo where
321 parseJSON v = modifyFailure ("Persistent: error loading ProjectM36 conf: " ++) $
328 parseJSON v = modifyFailure ("Persistent: error loading ProjectM36 conf: " ++) $
322 flip (withObject "ProjectM36Conf") v $ \o -> do
329 flip (withObject "ProjectM36Conf") v $ \o -> do
323 ctype <- parseJSON =<< ( o .: "connectionType")
330 ctype <- parseJSON =<< ( o .: "connectionType")
324 return ctype
331 return ctype
325−
332+
326instance PersistConfig C.ConnectionInfo where
333instance PersistConfig C.ConnectionInfo where
327 type PersistConfigBackend C.ConnectionInfo = ReaderT C.Connection
334 type PersistConfigBackend C.ConnectionInfo = ReaderT C.Connection
328 type PersistConfigPool C.ConnectionInfo = C.Connection
335 type PersistConfigPool C.ConnectionInfo = C.Connection
329−
336+
330 loadConfig = parseJSON
337 loadConfig = parseJSON
331 applyEnv = return -- no environment variables are used
338 applyEnv = return -- no environment variables are used
332 createPoolConfig conf = do
339 createPoolConfig conf = do
@@ -336,7 +343,7 @@ instance PersistConfig C.ConnectionInfo where
336 Right conn -> return conn
343 Right conn -> return conn
337 --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
344 --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
338 runPool _ r = runReaderT r
345 runPool _ r = runReaderT r
339−
346+
340withProjectM36Conn :: (Monad m, Trans.MonadIO m) => C.ConnectionInfo -> (C.Connection -> m a) -> m a
347withProjectM36Conn :: (Monad m, Trans.MonadIO m) => C.ConnectionInfo -> (C.Connection -> m a) -> m a
341withProjectM36Conn conf connReader = do
348withProjectM36Conn conf connReader = do
342 conn <- Trans.liftIO $ createPoolConfig conf
349 conn <- Trans.liftIO $ createPoolConfig conf
@@ -361,17 +368,17 @@ persistUniqueToRestrictionPredicate :: PersistEntity record => Unique record ->
361persistUniqueToRestrictionPredicate unique = do
368persistUniqueToRestrictionPredicate unique = do
362 atoms <- mapM (\v -> maybe (Left $ AtomTypeNotSupported "") Right $ persistValueAtom v) $ persistUniqueToValues unique
369 atoms <- mapM (\v -> maybe (Left $ AtomTypeNotSupported "") Right $ persistValueAtom v) $ persistUniqueToValues unique
363 let attrNames = map (unDBName . snd) $ persistUniqueToFieldNames unique
370 let attrNames = map (unDBName . snd) $ persistUniqueToFieldNames unique
364− andify [] = TruePredicate
371+ andify [] = TruePredicate
365 andify ((attrName, atom):xs) = AndPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom)) $ andify xs
372 andify ((attrName, atom):xs) = AndPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom)) $ andify xs
366 return $ andify (zip attrNames atoms)
373 return $ andify (zip attrNames atoms)
367−
374+
368instance PersistUnique C.Connection where
375instance PersistUnique C.Connection where
369 getBy unique = do
376 getBy unique = do
370 conn <- ask
377 conn <- ask
371 let predicate = persistUniqueToRestrictionPredicate unique
378 let predicate = persistUniqueToRestrictionPredicate unique
372 relVarName = unDBName $ entityDB entDef
379 relVarName = unDBName $ entityDB entDef
373 entDef = entityDef $ dummyFromUnique unique
380 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))
375 case predicate of
382 case predicate of
376 Left err -> throwRelErr err
383 Left err -> throwRelErr err
377 Right predicate' -> do
384 Right predicate' -> do
@@ -408,8 +415,8 @@ instance PersistUnique C.Connection where
408multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr
415multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr
409multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate
416multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate
410multiFilterAsRestrictionPredicate andOr (x:xs) = do
417multiFilterAsRestrictionPredicate andOr (x:xs) = do
411− let predicate = if andOr then AndPredicate else OrPredicate
418+ let predicate = if andOr then AndPredicate else OrPredicate
412− filtHead <- filterAsRestrictionPredicate x
419+ filtHead <- filterAsRestrictionPredicate x
413 filtTail <- multiFilterAsRestrictionPredicate andOr xs
420 filtTail <- multiFilterAsRestrictionPredicate andOr xs
414 return $ predicate filtHead filtTail
421 return $ predicate filtHead filtTail
415
422
@@ -451,8 +458,8 @@ selectionFromRestriction filters = do
451 let entDef = entityDef $ dummyFromFilters filters
458 let entDef = entityDef $ dummyFromFilters filters
452 relVarName = unDBName $ entityDB entDef
459 relVarName = unDBName $ entityDB entDef
453 right $ Restrict restrictionPredicate (RelationVariable relVarName)
460 right $ Restrict restrictionPredicate (RelationVariable relVarName)
454−
461+
455−
462+
456instance PersistQuery C.Connection where
463instance PersistQuery C.Connection where
457 updateWhere _ [] = return ()
464 updateWhere _ [] = return ()
458 updateWhere filters updates = do
465 updateWhere filters updates = do
@@ -465,7 +472,7 @@ instance PersistQuery C.Connection where
465 relVarName = unDBName $ entityDB entDef
472 relVarName = unDBName $ entityDB entDef
466 updateExpr = Update relVarName updateMap restrictionPredicate
473 updateExpr = Update relVarName updateMap restrictionPredicate
467 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn updateExpr
474 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn updateExpr
468− case maybeErr of
475+ case maybeErr of
469 Just err -> left err
476 Just err -> left err
470 Nothing -> right ()
477 Nothing -> right ()
471 case e of
478 case e of
@@ -473,14 +480,14 @@ instance PersistQuery C.Connection where
473 Right () -> return ()
480 Right () -> return ()
474
481
475 deleteWhere filters = do
482 deleteWhere filters = do
476− conn <- ask
483+ conn <- ask
477 e <- runEitherT $ do
484 e <- runEitherT $ do
478 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
485 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
479− let entDef = entityDef $ dummyFromFilters filters
486+ let entDef = entityDef $ dummyFromFilters filters
480 relVarName = unDBName $ entityDB entDef
487 relVarName = unDBName $ entityDB entDef
481 deleteExpr = Delete relVarName restrictionPredicate
488 deleteExpr = Delete relVarName restrictionPredicate
482 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn deleteExpr
489 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn deleteExpr
483− case maybeErr of
490+ case maybeErr of
484 Just err -> left err
491 Just err -> left err
485 Nothing -> right ()
492 Nothing -> right ()
486 case e of
493 case e of
@@ -491,7 +498,7 @@ instance PersistQuery C.Connection where
491 conn <- ask
498 conn <- ask
492 e <- runEitherT $ do
499 e <- runEitherT $ do
493 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
500 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
494− let entDef = entityDef $ dummyFromFilters filters
501+ let entDef = entityDef $ dummyFromFilters filters
495 relVarName = unDBName $ entityDB entDef
502 relVarName = unDBName $ entityDB entDef
496 allAttrNamesList = map (unDBName . fieldDB) (entityFields entDef) ++ [unDBName (fieldDB (entityId entDef))]
503 allAttrNamesList = map (unDBName . fieldDB) (entityFields entDef) ++ [unDBName (fieldDB (entityId entDef))]
497 allAttrNames = AttributeNames $ S.fromList allAttrNamesList
504 allAttrNames = AttributeNames $ S.fromList allAttrNamesList
@@ -499,13 +506,12 @@ instance PersistQuery C.Connection where
499 tupleExpr = AttributeTupleExpr "persistcount" (FunctionAtomExpr "count" [AttributeAtomExpr "persistcountrel"])
506 tupleExpr = AttributeTupleExpr "persistcount" (FunctionAtomExpr "count" [AttributeAtomExpr "persistcountrel"])
500 countExpr = Extend tupleExpr groupExpr
507 countExpr = Extend tupleExpr groupExpr
501 rel <- Trans.liftIO $ C.executeRelationalExpr conn countExpr
508 rel <- Trans.liftIO $ C.executeRelationalExpr conn countExpr
502− case rel of
509+ case rel of
503 Left err -> left err
510 Left err -> left err
504 Right rel' -> case singletonTuple rel' of
511 Right rel' -> case singletonTuple rel' of
505 Nothing -> Trans.liftIO $ throwIO $ PersistError "failed to get count tuple"
512 Nothing -> Trans.liftIO $ throwIO $ PersistError "failed to get count tuple"
506 Just tuple -> case atomForAttributeName "persistcount" tuple of
513 Just tuple -> case atomForAttributeName "persistcount" tuple of
507− (Right (IntAtom c)) -> (Trans.liftIO $ putStrLn (show c)) >> return c
514+ (Right c) -> return (castInt c)
508− Right _ -> Trans.liftIO $ throwIO $ PersistError "count returned wrong data type"
509 Left err -> left err
515 Left err -> left err
510 case e of
516 case e of
511 Left err -> throwIOPersistError ("count failure: " ++ show err)
517 Left err -> throwIOPersistError ("count failure: " ++ show err)
@@ -546,4 +552,4 @@ instance PersistQuery C.Connection where
546 case keys of
552 case keys of
547 Left err -> throwIOPersistError ("keyFromValues failure2: " ++ show err)
553 Left err -> throwIOPersistError ("keyFromValues failure2: " ++ show err)
548 Right keys' -> return $ return (CL.sourceList keys')
554 Right keys' -> return $ return (CL.sourceList keys')
549−
555+
ProjectM36/Atom.hs+63−44
@@ -2,50 +2,69 @@
2module ProjectM36.Atom where
2module ProjectM36.Atom where
3import ProjectM36.Base
3import ProjectM36.Base
4import ProjectM36.Error
4import ProjectM36.Error
5+import Data.Typeable
6+import ProjectM36.ConcreteTypeRep
5import qualified Data.Text as T
7import qualified Data.Text as T
6−import Text.Read (readMaybe)
8+import Data.Time.Calendar (Day)
7−import Data.Time.Format
9+import Data.Time.Clock
8−import Data.ByteString.Base64
10+import Data.ByteString (ByteString)
9−import qualified Data.Text.Encoding as TE
10
11
11relationForAtom :: Atom -> Either RelationalError Relation
12relationForAtom :: Atom -> Either RelationalError Relation
12−relationForAtom (RelationAtom rel) = Right rel
13+relationForAtom (Atom atom) = case cast atom of
14+ Just rel@(Relation _ _) -> Right rel
13−relationForAtom _ = Left $ AttributeIsNotRelationValuedError ""
15+ Nothing -> Left $ AttributeIsNotRelationValuedError ""
14−
16+
15−atomTypeForAtom :: Atom -> AtomType
17+atomTypeForProxy :: (Atomable a) => Proxy a -> AtomType
16−atomTypeForAtom (StringAtom _) = StringAtomType
18+atomTypeForProxy prox = AtomType $ CTR (typeRep prox)
17−atomTypeForAtom (IntAtom _) = IntAtomType
19+
18−atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes
20+--some convenience functions
19−atomTypeForAtom (BoolAtom _) = BoolAtomType
21+stringAtomType :: AtomType
20−atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType
22+stringAtomType = atomTypeForProxy (Proxy :: Proxy StringType)
21−atomTypeForAtom (DateAtom _) = DateAtomType
23+
22−atomTypeForAtom (DoubleAtom _) = DoubleAtomType
24+intAtomType :: AtomType
23−atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType
25+intAtomType = atomTypeForProxy (Proxy :: Proxy Int)
24−
26+
25−{- a generic string constructor for atoms
27+boolAtomType :: AtomType
26−used by CSV relation generation
28+boolAtomType = atomTypeForProxy (Proxy :: Proxy Bool)
27−-}
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 :/
28−atomFromString :: AtomType -> String -> Either RelationalError Atom
43+makeAtomFromText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom
29−atomFromString StringAtomType strIn = Right $ StringAtom (T.pack strIn)
44+makeAtomFromText _ (AtomType cTypeRep) textIn = if
30−atomFromString IntAtomType strIn = case readMaybe strIn of
45+ unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then
31− Just i -> Right $ IntAtom i
46+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Int)
32− Nothing -> Left (ParseError "Failed to parse integer")
47+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Double) then
33−atomFromString BoolAtomType strIn = case strIn of
48+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Double)
34− "true" -> Right $ BoolAtom True
49+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy T.Text) then
35− "false" -> Right $ BoolAtom False
50+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String T.Text)
36− _ -> Left (ParseError "Failed to parse boolean")
51+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then
37−atomFromString (RelationAtomType _) _ = Left $ ParseError "Nested relation parsing not supported"
52+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Day)
38−atomFromString DateTimeAtomType strIn =
53+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy UTCTime) then
39− case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" strIn of
54+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String UTCTime)
40− Just utctime -> Right $ DateTimeAtom utctime
55+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then
41− Nothing -> Left $ ParseError "Failed to parse datetime"
56+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String ByteString)
42−atomFromString DoubleAtomType strIn = case readMaybe strIn of
57+ else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then
43− Just d -> Right $ DoubleAtom d
58+ either (Left . ParseError . T.pack) (Right . Atom) (fromText textIn :: Either String Bool)
44− Nothing -> Left (ParseError "Failed to parse double")
59+ else
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)
60+ Left $ ParseError textIn
50− Right bsVal -> Right $ ByteStringAtom bsVal
61+makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName
51−atomFromString AnyAtomType _ = Left $ ParseError "Parsing AnyAtomType is not supported"
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
28atomTypes :: Attributes -> V.Vector AtomType
28atomTypes :: Attributes -> V.Vector AtomType
29atomTypes attrs = V.map atomType attrs
29atomTypes attrs = V.map atomType attrs
30
30
31−isRelationAtomType :: AtomType -> Bool
32−isRelationAtomType (RelationAtomType _) = True
33−isRelationAtomType _ = False
34−
35--hm- no error-checking here
31--hm- no error-checking here
36addAttribute :: Attribute -> Attributes -> Attributes
32addAttribute :: Attribute -> Attributes -> Attributes
37addAttribute attr attrs = attrs `V.snoc` attr
33addAttribute 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 #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module ProjectM36.Base where
3module ProjectM36.Base where
4import qualified Data.Map as M
4import qualified Data.Map as M
5import qualified Data.HashSet as HS
5import qualified Data.HashSet as HS
6−import qualified Data.Hashable as Hash
6+import Data.Hashable (Hashable, hashWithSalt)
7import qualified Data.Set as S
7import qualified Data.Set as S
8import Control.Monad.State (State)
8import Control.Monad.State (State)
9import Data.UUID (UUID)
9import Data.UUID (UUID)
@@ -12,27 +12,93 @@ import Control.DeepSeq.Generics (genericRnf)
12import GHC.Generics (Generic)
12import GHC.Generics (Generic)
13import qualified Data.Vector as V
13import qualified Data.Vector as V
14import qualified Data.List as L
14import qualified Data.List as L
15−import qualified Data.Text as T
15+import Data.Text (Text,pack,unpack)
16import Data.Binary
16import Data.Binary
17import Data.Vector.Binary()
17import Data.Vector.Binary()
18import Data.Time.Clock
18import Data.Time.Clock
19import Data.Time.Clock.POSIX
19import Data.Time.Clock.POSIX
20import Data.Time.Calendar (Day,toGregorian,fromGregorian)
20import Data.Time.Calendar (Day,toGregorian,fromGregorian)
21import Data.Hashable.Time ()
21import Data.Hashable.Time ()
22+import Data.Typeable
23+import Text.Read (readMaybe)
22−import qualified Data.ByteString as BS
24+import Data.ByteString (ByteString)
23−
25+import ProjectM36.ConcreteTypeRep
26+
24−type StringType = T.Text
27+type StringType = Text
25−
28+
26−data Atom = StringAtom StringType |
29+class (Read a,
27− IntAtom Int |
30+ Hashable a,
28− BoolAtom Bool |
31+ Binary a,
29− RelationAtom Relation |
32+ Eq a,
30− DateTimeAtom UTCTime |
33+ Show a,
31− DateAtom Day |
34+ Typeable a,
32− DoubleAtom Double |
35+ NFData a) => Atomable a where
33− ByteStringAtom BS.ByteString
36+ fromText :: (Atomable a) => Text -> Either String a
34− deriving (Show, Eq, Generic)
37+ fromText t = case readMaybe (unpack t) of
35−
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+
36instance Binary UTCTime where
102instance Binary UTCTime where
37 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)
103 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)
38 get = do
104 get = do
@@ -43,34 +109,23 @@ instance Binary Day where
43 put day = put $ toGregorian day
109 put day = put $ toGregorian day
44 get = do
110 get = do
45 (y,m,d) <- get :: Get (Integer, Int, Int)
111 (y,m,d) <- get :: Get (Integer, Int, Int)
46− return $ fromGregorian y m d
112+ return (fromGregorian y m d)
47
113
48−instance NFData Atom where rnf = genericRnf
114+data AtomType = AtomType ConcreteTypeRep |
49−
50−instance Hash.Hashable Atom
51−
52−instance Binary Atom
53−
54−data AtomType = StringAtomType |
55− IntAtomType |
56− BoolAtomType |
57 RelationAtomType Attributes |
115 RelationAtomType Attributes |
58− DateTimeAtomType |
116+ AnyAtomType --wildcard used in Atom Functions
59− DateAtomType |
60− DoubleAtomType |
61− ByteStringAtomType |
62− AnyAtomType --AnyAtomType is used as a wildcard
63− deriving (Eq, Show, Generic)
117+ deriving (Eq,NFData,Generic,Binary,Show)
64−
118+
65−instance NFData AtomType where rnf = genericRnf
119+isRelationAtomType :: AtomType -> Bool
66−instance Binary AtomType
120+isRelationAtomType (RelationAtomType _) = True
67−
121+isRelationAtomType _ = False
122+
68−type AttributeName = T.Text
123+type AttributeName = StringType
69
124
70data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
125data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
71
126
72−instance Hash.Hashable Attribute where
127+instance Hashable Attribute where
73− hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName
128+ hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName
74
129
75instance NFData Attribute where rnf = genericRnf
130instance NFData Attribute where rnf = genericRnf
76
131
@@ -86,7 +141,10 @@ attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2
86sortedAttributesIndices :: Attributes -> [(Int, Attribute)]
141sortedAttributesIndices :: Attributes -> [(Int, Attribute)]
87sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)
142sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)
88
143
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"
90
148
91instance Eq RelationTupleSet where
149instance Eq RelationTupleSet where
92 set1 == set2 = hset set1 == hset set2
150 set1 == set2 = hset set1 == hset set2
@@ -96,9 +154,9 @@ instance Eq RelationTupleSet where
96instance NFData RelationTupleSet where rnf = genericRnf
154instance NFData RelationTupleSet where rnf = genericRnf
97
155
98--the same hash must be generated for equal tuples so that the hashset equality works
156--the same hash must be generated for equal tuples so that the hashset equality works
99−instance Hash.Hashable RelationTuple where
157+instance Hashable RelationTuple where
100− hashWithSalt salt (RelationTuple attrs tupVec) = salt `Hash.hashWithSalt`
158+ hashWithSalt salt (RelationTuple attrs tupVec) = salt `hashWithSalt`
101− sortedAttrs `Hash.hashWithSalt`
159+ sortedAttrs `hashWithSalt`
102 (V.toList sortedTupVec)
160 (V.toList sortedTupVec)
103 where
161 where
104 sortedAttrsIndices = sortedAttributesIndices attrs
162 sortedAttrsIndices = sortedAttributesIndices attrs
@@ -120,16 +178,16 @@ instance Eq RelationTuple where
120
178
121instance NFData RelationTuple where rnf = genericRnf
179instance NFData RelationTuple where rnf = genericRnf
122
180
123−data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic)
181+data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)
124
182
125instance Eq Relation where
183instance Eq Relation where
126 Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2
184 Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2
127
185
128instance NFData Relation where rnf = genericRnf
186instance NFData Relation where rnf = genericRnf
129
187
130−instance Hash.Hashable Relation where
188+instance Hashable Relation where
131− hashWithSalt salt (Relation attrs tupSet) = salt `Hash.hashWithSalt`
189+ hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt`
132− sortedAttrs `Hash.hashWithSalt`
190+ sortedAttrs `hashWithSalt`
133 asList tupSet
191 asList tupSet
134 where
192 where
135 sortedAttrs = map snd (sortedAttributesIndices attrs)
193 sortedAttrs = map snd (sortedAttributesIndices attrs)
@@ -276,14 +334,14 @@ data AtomFunction = AtomFunction {
276 atomFunc :: [Atom] -> Atom
334 atomFunc :: [Atom] -> Atom
277 }
335 }
278
336
279−instance Hash.Hashable AtomFunction where
337+instance Hashable AtomFunction where
280− hashWithSalt salt func = salt `Hash.hashWithSalt` (atomFuncName func)
338+ hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)
281
339
282instance Eq AtomFunction where
340instance Eq AtomFunction where
283 f1 == f2 = (atomFuncName f1) == (atomFuncName f2)
341 f1 == f2 = (atomFuncName f1) == (atomFuncName f2)
284
342
285instance Show AtomFunction where
343instance Show AtomFunction where
286− show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes
344+ show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes
287 where
345 where
288 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))
346 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))
289
347
@@ -299,3 +357,4 @@ data PersistenceStrategy = NoPersistence | --no filesystem persistence/memory-on
299 --CrashSafePersistence FilePath --full fsync- not yet implemented
357 --CrashSafePersistence FilePath --full fsync- not yet implemented
300 deriving (Show, Read)
358 deriving (Show, Read)
301
359
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)
8+
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
4import qualified Data.HashSet as HS
4import qualified Data.HashSet as HS
5import Control.Monad
5import Control.Monad
6import qualified Data.Vector as V
6import qualified Data.Vector as V
7−
7+import ProjectM36.Atom
8+import Data.Typeable (cast)
8import ProjectM36.Base
9import ProjectM36.Base
9import ProjectM36.Tuple
10import ProjectM36.Tuple
10import qualified ProjectM36.Attribute as A
11import qualified ProjectM36.Attribute as A
@@ -25,10 +26,10 @@ attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs
25
26
26attributesForNames :: S.Set AttributeName -> Relation -> Attributes
27attributesForNames :: S.Set AttributeName -> Relation -> Attributes
27attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs
28attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs
28−
29+
29atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType
30atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType
30atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs
31atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs
31−
32+
32mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
33mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
33mkRelationFromList attrs atomMatrix = do
34mkRelationFromList attrs atomMatrix = do
34 tupSet <- mkTupleSetFromList attrs atomMatrix
35 tupSet <- mkTupleSetFromList attrs atomMatrix
@@ -38,7 +39,7 @@ mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
38mkRelation attrs tupleSet = do
39mkRelation attrs tupleSet = do
39 --check that all tuples have the same keys
40 --check that all tuples have the same keys
40 --check that all tuples have keys (1-N) where N is the attribute count
41 --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
42 Left err -> Left err
43 Left err -> Left err
43 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
44 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
44
45
@@ -61,8 +62,8 @@ singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Countable 1 the
61 Nothing
62 Nothing
62
63
63union :: Relation -> Relation -> Either RelationalError Relation
64union :: Relation -> Relation -> Either RelationalError Relation
64−union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
65+union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
65− if not (A.attributesEqual attrs1 attrs2)
66+ if not (A.attributesEqual attrs1 attrs2)
66 then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))
67 then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))
67 else
68 else
68 Right $ Relation attrs1 newtuples
69 Right $ Relation attrs1 newtuples
@@ -70,7 +71,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
70 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ (asList tupSet1) ++ (map (reorderTuple attrs1) (asList tupSet2))
71 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ (asList tupSet1) ++ (map (reorderTuple attrs1) (asList tupSet2))
71
72
72project :: AttributeNames -> Relation -> Either RelationalError Relation
73project :: AttributeNames -> Relation -> Either RelationalError Relation
73−project projectionAttrNames rel =
74+project projectionAttrNames rel =
74 case AS.projectionAttributesForAttributeNames (attributes rel) projectionAttrNames of
75 case AS.projectionAttributesForAttributeNames (attributes rel) projectionAttrNames of
75 Left err -> Left err
76 Left err -> Left err
76 Right newAttrs -> relFold (folder newAttrs) (Right $ Relation newAttrs emptyTupleSet) rel
77 Right newAttrs -> relFold (folder newAttrs) (Right $ Relation newAttrs emptyTupleSet) rel
@@ -78,7 +79,7 @@ project projectionAttrNames rel =
78 folder newAttrs tupleToProject acc = case acc of
79 folder newAttrs tupleToProject acc = case acc of
79 Left err -> Left err
80 Left err -> Left err
80 Right acc2 -> union acc2 (Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]))
81 Right acc2 -> union acc2 (Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]))
81−
82+
82rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
83rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
83rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
84rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
84 if not attributeValid
85 if not attributeValid
@@ -93,7 +94,7 @@ rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
93 newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs
94 newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs
94 newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)
95 newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)
95 tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple
96 tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple
96−
97+
97--the algebra should return a relation of one attribute and one row with the arity
98--the algebra should return a relation of one attribute and one row with the arity
98arity :: Relation -> Int
99arity :: Relation -> Int
99arity (Relation attrs _) = A.arity attrs
100arity (Relation attrs _) = A.arity attrs
@@ -113,7 +114,7 @@ cardinality (Relation _ tupSet) = Countable (length (asList tupSet))
113{-
114{-
114group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
115group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
115group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
116group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
116− nonGroupProjection <- project nonGroupAttrNames rel
117+ nonGroupProjection <- project nonGroupAttrNames rel
117 relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection
118 relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection
118 where
119 where
119 newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr
120 newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr
@@ -121,35 +122,35 @@ group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
121 nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames
122 nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames
122 --map the projection to add the additional new attribute
123 --map the projection to add the additional new attribute
123 --create the new attribute (a new relation) by filtering and projecting the tupleSet
124 --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
125 Left err -> Left err
126 Left err -> Left err
126 Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))
127 Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))
127-}
128-}
128−
129+
129--algorithm: self-join with image relation
130--algorithm: self-join with image relation
130group :: AttributeNames -> AttributeName -> Relation -> Either RelationalError Relation
131group :: AttributeNames -> AttributeName -> Relation -> Either RelationalError Relation
131group groupAttrNames newAttrName rel = do
132group groupAttrNames newAttrName rel = do
132 let nonGroupAttrNames = AS.invertAttributeNames groupAttrNames
133 let nonGroupAttrNames = AS.invertAttributeNames groupAttrNames
133− nonGroupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) nonGroupAttrNames
134+ nonGroupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) nonGroupAttrNames
134 groupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) groupAttrNames
135 groupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) groupAttrNames
135 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)
136 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)
136 matchingRelTuple tupIn = case imageRelationFor tupIn rel of
137 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))
138 Left _ -> undefined
139 Left _ -> undefined
139 mogrifier tupIn = tupleExtend tupIn (matchingRelTuple tupIn)
140 mogrifier tupIn = tupleExtend tupIn (matchingRelTuple tupIn)
140 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes
141 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes
141 nonGroupProjection <- project nonGroupAttrNames rel
142 nonGroupProjection <- project nonGroupAttrNames rel
142 relMogrify mogrifier newAttrs nonGroupProjection
143 relMogrify mogrifier newAttrs nonGroupProjection
143
144
144−
145+
145--help restriction function
146--help restriction function
146−--returns a subrelation of
147+--returns a subrelation of
147restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
148restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
148restrictEq tuple rel = restrict rfilter rel
149restrictEq tuple rel = restrict rfilter rel
149 where
150 where
150 rfilter :: RelationTuple -> Bool
151 rfilter :: RelationTuple -> Bool
151 rfilter tupleIn = tupleIntersection tuple tupleIn == tuple
152 rfilter tupleIn = tupleIntersection tuple tupleIn == tuple
152−
153+
153-- unwrap relation-valued attribute
154-- unwrap relation-valued attribute
154-- return error if relval attrs and nongroup attrs overlap
155-- return error if relval attrs and nongroup attrs overlap
155ungroup :: AttributeName -> Relation -> Either RelationalError Relation
156ungroup :: AttributeName -> Relation -> Either RelationalError Relation
@@ -165,8 +166,8 @@ ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of
165 Right accRel -> do
166 Right accRel -> do
166 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn
167 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn
167 union accRel ungrouped
168 union accRel ungrouped
168−
169+
169−--take an relval attribute name and a tuple and ungroup the relval
170+--take an relval attribute name and a tuple and ungroup the relval
170tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
171tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
171tupleUngroup relvalAttrName newAttrs tuple = do
172tupleUngroup relvalAttrName newAttrs tuple = do
172 relvalRelation <- relationForAttributeName relvalAttrName tuple
173 relvalRelation <- relationForAttributeName relvalAttrName tuple
@@ -177,17 +178,17 @@ tupleUngroup relvalAttrName newAttrs tuple = do
177 folder tupleIn acc = case acc of
178 folder tupleIn acc = case acc of
178 Left err -> Left err
179 Left err -> Left err
179 Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])
180 Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])
180−
181+
181attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
182attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
182−attributesForRelval relvalAttrName (Relation attrs _) = do
183+attributesForRelval relvalAttrName (Relation attrs _) = do
183 atomType <- A.atomTypeForAttributeName relvalAttrName attrs
184 atomType <- A.atomTypeForAttributeName relvalAttrName attrs
184− case atomType of
185+ case atomType of
185 (RelationAtomType relAttrs) -> Right relAttrs
186 (RelationAtomType relAttrs) -> Right relAttrs
186 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
187 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
187
188
188restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
189restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
189--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset
190--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
191 where
192 where
192 processedTupSet = RelationTupleSet ((filter rfilter (asList tupset)) `P.using` (P.parListChunk 1000 P.rdeepseq))
193 processedTupSet = RelationTupleSet ((filter rfilter (asList tupset)) `P.using` (P.parListChunk 1000 P.rdeepseq))
193
194
@@ -199,7 +200,7 @@ join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do
199 newAttrs <- A.joinAttributes attrs1 attrs2
200 newAttrs <- A.joinAttributes attrs1 attrs2
200 let tupleSetJoiner accumulator tuple1 = do
201 let tupleSetJoiner accumulator tuple1 = do
201 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2
202 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2
202− return $ joinedTupSet ++ accumulator
203+ return $ joinedTupSet ++ accumulator
203 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)
204 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)
204 newTupSet <- mkTupleSet newAttrs newTupSetList
205 newTupSet <- mkTupleSet newAttrs newTupSetList
205 return $ Relation newAttrs newTupSet
206 return $ Relation newAttrs newTupSet
@@ -213,10 +214,10 @@ relMap mapper (Relation attrs tupleSet) = do
213 where
214 where
214 typeMapCheck tupleIn = do
215 typeMapCheck tupleIn = do
215 let remappedTuple = mapper tupleIn
216 let remappedTuple = mapper tupleIn
216− if tupleAttributes remappedTuple == tupleAttributes tupleIn
217+ if tupleAttributes remappedTuple == tupleAttributes tupleIn
217− then Right remappedTuple
218+ then Right remappedTuple
218− else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)
219+ else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)
219−
220+
220relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
221relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
221relMogrify mapper newAttributes (Relation _ tupSet) = do
222relMogrify mapper newAttributes (Relation _ tupSet) = do
222 mkRelationFromTuples newAttributes newTuples
223 mkRelationFromTuples newAttributes newTuples
@@ -227,7 +228,7 @@ relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
227relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)
228relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)
228
229
229--image relation as defined by CJ Date
230--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
231
232
232--check that matching attribute names have the same types
233--check that matching attribute names have the same types
233imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
234imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
@@ -235,9 +236,9 @@ imageRelationFor matchTuple rel = do
235 restricted <- restrictEq matchTuple rel --restrict across matching tuples
236 restricted <- restrictEq matchTuple rel --restrict across matching tuples
236 let projectionAttrNames = AttributeNames $ A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)
237 let projectionAttrNames = AttributeNames $ A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)
237 project projectionAttrNames restricted --project across attributes not in rel
238 project projectionAttrNames restricted --project across attributes not in rel
238−
239+
239--returns a relation-valued attribute image relation for each tuple in rel1
240--returns a relation-valued attribute image relation for each tuple in rel1
240−--algorithm:
241+--algorithm:
241 {-
242 {-
242imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation
243imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation
243imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do
244imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do
@@ -245,34 +246,42 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe
245 where
246 where
246 matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2
247 matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2
247 newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2
248 newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2
248−
249+
249 tupleSetJoiner tup1 acc = undefined
250 tupleSetJoiner tup1 acc = undefined
250-}
251-}
251−
252+
252-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long
253-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long
253-- this is useful for performance and resource usage testing
254-- this is useful for performance and resource usage testing
254matrixRelation :: Int -> Int -> Either RelationalError Relation
255matrixRelation :: Int -> Int -> Either RelationalError Relation
255matrixRelation attributeCount tupleCount = do
256matrixRelation attributeCount tupleCount = do
256− let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]
257+ 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))
258+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> Atom tupleX))
258 tuples = map (\c -> tuple c) [0 .. tupleCount]
259 tuples = map (\c -> tuple c) [0 .. tupleCount]
259 mkRelationFromTuples attrs tuples
260 mkRelationFromTuples attrs tuples
260
261
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+
261--used by sum atom function
268--used by sum atom function
262relationSum :: Relation -> Atom
269relationSum :: 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
264 where
271 where
272+ --extract Int from Atom
273+ newVal :: RelationTuple -> Int
265− newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0
274+ newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0
266
275
267relationCount :: Relation -> Atom
276relationCount :: Relation -> Atom
268−relationCount relIn = IntAtom $ relFold (\_ acc -> acc + 1) 0 relIn
277+relationCount relIn = Atom $ relFold (\_ acc -> acc + 1) (0::Int) relIn
269
278
270relationMax :: Relation -> Atom
279relationMax :: 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
272 where
281 where
273− newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0
282+ newVal tupIn = castInt $ (tupleAtoms tupIn) V.! 0
274−
283+
275relationMin :: Relation -> Atom
284relationMin :: 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
277 where
286 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 #-}
1module ProjectM36.Relation.Parse.CSV where
2module ProjectM36.Relation.Parse.CSV where
2--parse Relations from CSV
3--parse Relations from CSV
3import Data.Csv.Parser
4import Data.Csv.Parser
@@ -6,7 +7,6 @@ import Data.Char (ord)
6import qualified Data.ByteString.Lazy as BS
7import qualified Data.ByteString.Lazy as BS
7import ProjectM36.Base
8import ProjectM36.Base
8import ProjectM36.Relation
9import ProjectM36.Relation
9−import ProjectM36.Atom
10import ProjectM36.Error
10import ProjectM36.Error
11import Data.Text.Encoding (decodeUtf8)
11import Data.Text.Encoding (decodeUtf8)
12import qualified ProjectM36.Attribute as A
12import qualified ProjectM36.Attribute as A
@@ -15,6 +15,7 @@ import Data.HashMap.Lazy as HM
15import qualified Data.List as L
15import qualified Data.List as L
16import qualified Data.Text as T
16import qualified Data.Text as T
17import Data.Attoparsec.ByteString.Lazy
17import Data.Attoparsec.ByteString.Lazy
18+import ProjectM36.Atom
18
19
19data CsvImportError = CsvParseError String |
20data CsvImportError = CsvParseError String |
20 AttributeMappingError RelationalError |
21 AttributeMappingError RelationalError |
@@ -35,10 +36,7 @@ csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inStr
35 attrNameSet = S.fromList (V.toList attrNames)
36 attrNameSet = S.fromList (V.toList attrNames)
36 headerSet = S.fromList (V.toList strHeader)
37 headerSet = S.fromList (V.toList strHeader)
37 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]
38 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+ 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
39− makeAtom aType strIn = case atomFromString aType strIn of
40− Left err -> Left $ AttributeMappingError err
41− Right atom -> Right atom
42 case attrNameSet == headerSet of
40 case attrNameSet == headerSet of
43 False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)
41 False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)
44 True -> do
42 True -> do
ProjectM36/Relation/Show/CSV.hs+5−12
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1module ProjectM36.Relation.Show.CSV where
2module ProjectM36.Relation.Show.CSV where
2import ProjectM36.Base
3import ProjectM36.Base
3import ProjectM36.Attribute
4import ProjectM36.Attribute
@@ -7,7 +8,8 @@ import qualified Data.ByteString.Lazy as BS
7import qualified Data.Vector as V
8import qualified Data.Vector as V
8import ProjectM36.Error
9import ProjectM36.Error
9import qualified Data.Text.Encoding as TE
10import qualified Data.Text.Encoding as TE
10−{-# OPTIONS_GHC -fno-warn-orphans #-}
11+
12+
11
13
12--spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes
14--spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes
13relationAsCSV :: Relation -> Either RelationalError BS.ByteString
15relationAsCSV :: Relation -> Either RelationalError BS.ByteString
@@ -20,7 +22,7 @@ relationAsCSV (Relation attrs tupleSet) = if relValAttrs /= [] then --check for
20 where
22 where
21 relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs
23 relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs
22 bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs
24 bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs
23−
25+
24{-
26{-
25instance ToRecord RelationTuple where
27instance ToRecord RelationTuple where
26 toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)
28 toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)
@@ -37,13 +39,4 @@ instance DefaultOrdered RecordRelationTuple where
37newtype RecordAtom = RecordAtom {unAtom :: Atom}
39newtype RecordAtom = RecordAtom {unAtom :: Atom}
38
40
39instance ToField RecordAtom where
41instance ToField RecordAtom where
40− toField ratom = case unAtom ratom of
42+ toField (RecordAtom (Atom atomVal)) = (TE.encodeUtf8 . toText) atomVal
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−
ProjectM36/Relation/Show/Gnuplot.hs+21−20
@@ -3,6 +3,7 @@ module ProjectM36.Relation.Show.Gnuplot where
3import ProjectM36.Base
3import ProjectM36.Base
4import ProjectM36.Relation
4import ProjectM36.Relation
5import ProjectM36.Tuple
5import ProjectM36.Tuple
6+import ProjectM36.Atom
6import qualified ProjectM36.Attribute as A
7import qualified ProjectM36.Attribute as A
7import qualified Data.Vector as V
8import qualified Data.Vector as V
8
9
@@ -18,20 +19,20 @@ import qualified Graphics.Gnuplot.Advanced as GPA
18--nested relations?
19--nested relations?
19
20
20data PlotError = InvalidAttributeCountError |
21data PlotError = InvalidAttributeCountError |
21− InvalidAttributeTypeError
22+ InvalidAttributeTypeError
22 deriving (Show)
23 deriving (Show)
23−
24+
24−--plotRelation :: Relation -> Either PlotError
25+--plotRelation :: Relation -> Either PlotError
25
26
26intFromAtomIndex :: Int -> RelationTuple -> Int
27intFromAtomIndex :: 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
28
29
29graph1DRelation :: Relation -> Plot2D.T Int Int
30graph1DRelation :: Relation -> Plot2D.T Int Int
30graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel
31graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel
31−
32+
32points1DRelation :: Relation -> [Int]
33points1DRelation :: Relation -> [Int]
33points1DRelation rel = relFold folder [] rel
34points1DRelation rel = relFold folder [] rel
34− where
35+ where
35 folder tup acc = intFromAtomIndex 0 tup : acc
36 folder tup acc = intFromAtomIndex 0 tup : acc
36
37
37graph2DRelation :: Relation -> Plot2D.T Int Int
38graph2DRelation :: Relation -> Plot2D.T Int Int
@@ -45,8 +46,8 @@ points2DRelation rel = relFold folder [] rel
45graph3DRelation :: Relation -> Plot3D.T Int Int Int
46graph3DRelation :: Relation -> Plot3D.T Int Int Int
46graph3DRelation rel = do
47graph3DRelation rel = do
47 Plot3D.cloud Graph3D.points $ points3DRelation rel
48 Plot3D.cloud Graph3D.points $ points3DRelation rel
48−
49+
49−points3DRelation :: Relation -> [(Int, Int, Int)]
50+points3DRelation :: Relation -> [(Int, Int, Int)]
50points3DRelation rel = relFold folder [] rel
51points3DRelation rel = relFold folder [] rel
51 where
52 where
52 folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup, intFromAtomIndex 2 tup) : acc
53 folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup, intFromAtomIndex 2 tup) : acc
@@ -55,21 +56,21 @@ points3DRelation rel = relFold folder [] rel
55sample1DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType]) [[IntAtom 2], [IntAtom 3]] of
56sample1DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType]) [[IntAtom 2], [IntAtom 3]] of
56 Right rel -> rel
57 Right rel -> rel
57 Left _ -> undefined
58 Left _ -> undefined
58−
59+
59−sample2DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 2, IntAtom 3],
60+sample2DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 2, IntAtom 3],
60− [IntAtom 2, IntAtom 4]] of
61+ [IntAtom 2, IntAtom 4]] of
61 Right rel -> rel
62 Right rel -> rel
62 Left _ -> undefined
63 Left _ -> undefined
63−
64+
64−sample3DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType, Attribute "z" IntAtomType]) [[IntAtom 2, IntAtom 3, IntAtom 3],
65+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
66+ [IntAtom 2, IntAtom 4, IntAtom 4]] of
66 Right rel -> rel
67 Right rel -> rel
67 Left _ -> undefined
68 Left _ -> undefined
68
69
69-}
70-}
70−
71+
71plotRelation :: Relation -> IO (Maybe PlotError)
72plotRelation :: 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
73 if attrTypes /= A.atomTypes (attributes rel) then
74 if attrTypes /= A.atomTypes (attributes rel) then
74 return $ Just InvalidAttributeTypeError
75 return $ Just InvalidAttributeTypeError
75 else do
76 else do
@@ -78,14 +79,14 @@ plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in
78 2 -> (GPA.plotDefault $ graph2DRelation rel) >> return Nothing
79 2 -> (GPA.plotDefault $ graph2DRelation rel) >> return Nothing
79 3 -> (GPA.plotDefault $ graph3DRelation rel) >> return Nothing
80 3 -> (GPA.plotDefault $ graph3DRelation rel) >> return Nothing
80 _ -> return $ Just InvalidAttributeCountError
81 _ -> return $ Just InvalidAttributeCountError
81−
82+
82−
83+
83{-
84{-
84--PNG
85--PNG
85savePlottedRelation :: String -> Relation -> IO ()
86savePlottedRelation :: String -> Relation -> IO ()
86−savePlottedRelation path rel = case plotRelation rel of
87+savePlottedRelation path rel = case plotRelation rel of
87 Left err -> putStrLn (show err)
88 Left err -> putStrLn (show err)
88 Right (Left g2d) -> plot' [] (PNG path) g2d >> return ()
89 Right (Left g2d) -> plot' [] (PNG path) g2d >> return ()
89 Right (Right g3d) -> plot' [] (PNG path) g3d >> return ()
90 Right (Right g3d) -> plot' [] (PNG path) g3d >> return ()
90−-}
91+-}
91
92
ProjectM36/Relation/Show/HTML.hs+3−10
@@ -12,7 +12,7 @@ import qualified Data.Text.Encoding as TE
12
12
13attributesAsHTML :: Attributes -> Text
13attributesAsHTML :: Attributes -> Text
14attributesAsHTML attrs = "<tr>" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "</tr>"
14attributesAsHTML attrs = "<tr>" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "</tr>"
15− where
15+ where
16 oneAttrHTML attrName = "<th>" `append` attrName `append` "</th>"
16 oneAttrHTML attrName = "<th>" `append` attrName `append` "</th>"
17 attrNameList = sortedAttributeNameList (attributeNameSet attrs)
17 attrNameList = sortedAttributeNameList (attributeNameSet attrs)
18
18
@@ -25,17 +25,10 @@ writeHTML :: Text -> IO ()
25writeHTML = TIO.writeFile "/home/agentm/rel.html"
25writeHTML = TIO.writeFile "/home/agentm/rel.html"
26
26
27writeRel :: Relation -> IO ()
27writeRel :: Relation -> IO ()
28−writeRel = writeHTML . relationAsHTML
28+writeRel = writeHTML . relationAsHTML
29
29
30atomAsHTML :: Atom -> Text
30atomAsHTML :: Atom -> Text
31−atomAsHTML (StringAtom atom) = atom
31+atomAsHTML (Atom atom) = toText 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
39
32
40tupleAsHTML :: RelationTuple -> Text
33tupleAsHTML :: RelationTuple -> Text
41tupleAsHTML tuple = "<tr>" `append` T.concat (L.map tupleFrag (tupleSortedAssocs tuple)) `append` "</tr>"
34tupleAsHTML 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
7import qualified Data.Set as S
7import qualified Data.Set as S
8import qualified Data.List as L
8import qualified Data.List as L
9import qualified Data.Text as T
9import qualified Data.Text as T
10−import qualified Data.Text.Encoding as TE
10+import Data.Typeable (cast)
11
11
12boxV :: StringType
12boxV :: StringType
13boxV = "│"
13boxV = "│"
@@ -44,15 +44,15 @@ dboxR = "╡"
44
44
45class TermSize a where
45class TermSize a where
46 termLength :: a -> Int
46 termLength :: a -> Int
47−
47+
48−--represent a relation as a table similar to those drawn by Date
48+--represent a relation as a table similar to those drawn by Date
49type Cell = StringType
49type Cell = StringType
50type Table = ([Cell], [[Cell]]) --header, body
50type Table = ([Cell], [[Cell]]) --header, body
51
51
52addRow :: [Cell] -> Table -> Table
52addRow :: [Cell] -> Table -> Table
53addRow cells (header,body) = (header, body ++ [cells])
53addRow cells (header,body) = (header, body ++ [cells])
54
54
55−--calculate maximum per-row and per-column sizes
55+--calculate maximum per-row and per-column sizes
56
56
57cellLocations :: Table -> ([Int],[Int]) --column size, row size
57cellLocations :: Table -> ([Int],[Int]) --column size, row size
58cellLocations tab@(header, _) = (maxWidths, maxHeights)
58cellLocations tab@(header, _) = (maxWidths, maxHeights)
@@ -63,18 +63,18 @@ cellLocations tab@(header, _) = (maxWidths, maxHeights)
63 rowHeights = map snd cellSizeMatrix
63 rowHeights = map snd cellSizeMatrix
64 maxHeights = map (\l -> if length l == 0 then 0 else L.maximumBy compare l) rowHeights
64 maxHeights = map (\l -> if length l == 0 then 0 else L.maximumBy compare l) rowHeights
65 mergeMax a b = map (\(c,d) -> max c d) (zip a b)
65 mergeMax a b = map (\(c,d) -> max c d) (zip a b)
66−
66+
67--the normal "lines" function returns an empty list for an empty string which is not what we want
67--the normal "lines" function returns an empty list for an empty string which is not what we want
68breakLines :: StringType -> [StringType]
68breakLines :: StringType -> [StringType]
69breakLines "" = [""]
69breakLines "" = [""]
70breakLines x = T.lines x
70breakLines x = T.lines x
71−
71+
72−cellSizes :: Table -> [([Int], [Int])]
72+cellSizes :: Table -> [([Int], [Int])]
73cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows
73cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows
74 where
74 where
75 maxRowWidth row = if length (lengths row) == 0 then
75 maxRowWidth row = if length (lengths row) == 0 then
76 0
76 0
77− else
77+ else
78 L.maximumBy compare (lengths row)
78 L.maximumBy compare (lengths row)
79 lengths row = map T.length (breakLines row)
79 lengths row = map T.length (breakLines row)
80 allRows = [header] ++ body
80 allRows = [header] ++ body
@@ -90,22 +90,17 @@ relationAsTable rel@(Relation _ tupleSet) = (header, body)
90 Left _ -> "?"
90 Left _ -> "?"
91 Right atom -> showAtom atom
91 Right atom -> showAtom atom
92 ) oAttrs]
92 ) oAttrs]
93−
93+
94−showAtom :: Atom -> StringType
94+showAtom :: Atom -> StringType
95−showAtom (StringAtom atom) = atom
95+showAtom (Atom atom) = case cast atom of
96−showAtom (IntAtom atom) = T.pack $ show atom
97−showAtom (RelationAtom rel) = renderTable $ relationAsTable rel
96+ Just rel -> renderTable $ relationAsTable rel
98−showAtom (BoolAtom bool) = T.pack $ if bool then "t" else "f"
97+ Nothing -> toText atom
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
103
98
104renderTable :: Table -> StringType
99renderTable :: Table -> StringType
105renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs
100renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs
106 where
101 where
107− cellLocs = cellLocations table
102+ cellLocs = cellLocations table
108−
103+
109renderHeader :: Table -> [Int] -> StringType
104renderHeader :: Table -> [Int] -> StringType
110renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar
105renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar
111 where
106 where
@@ -113,7 +108,7 @@ renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHead
113 renderHeaderNames = renderRow header columnLocations 1 boxV
108 renderHeaderNames = renderRow header columnLocations 1 boxV
114 renderBottomBar = if length body == 0 then ""
109 renderBottomBar = if length body == 0 then ""
115 else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n"
110 else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n"
116−
111+
117renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType
112renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType
118renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end
113renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end
119
114
@@ -124,7 +119,7 @@ leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then
124 paddedLines !! lineNum
119 paddedLines !! lineNum
125 where
120 where
126 paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)
121 paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)
127−
122+
128renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType
123renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType
129renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]
124renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]
130 where
125 where
@@ -141,7 +136,7 @@ renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar
141
136
142orderedAttributeNames :: Relation -> [AttributeName]
137orderedAttributeNames :: Relation -> [AttributeName]
143orderedAttributeNames = S.toAscList . attributeNames
138orderedAttributeNames = S.toAscList . attributeNames
144−
139+
145repeatString :: Int -> StringType -> StringType
140repeatString :: Int -> StringType -> StringType
146repeatString c s = T.concat (take c (repeat s))
141repeatString c s = T.concat (take c (repeat s))
147
142
ProjectM36/RelationalExpression.hs+141−127
@@ -15,6 +15,7 @@ import qualified Data.Set as S
15import Control.Monad.State hiding (join)
15import Control.Monad.State hiding (join)
16import Data.Maybe
16import Data.Maybe
17import Data.Either
17import Data.Either
18+import Data.Typeable (cast)
18
19
19--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
20--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
20evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
21evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
@@ -22,11 +23,11 @@ evalRelationalExpr (RelationVariable name) = do
22 relvarTable <- liftM relationVariables get
23 relvarTable <- liftM relationVariables get
23 return $ case M.lookup name relvarTable of
24 return $ case M.lookup name relvarTable of
24 Just res -> Right res
25 Just res -> Right res
25− Nothing -> Left $ RelVarNotDefinedError name
26+ Nothing -> Left $ RelVarNotDefinedError name
26
27
27evalRelationalExpr (Project attrNames expr) = do
28evalRelationalExpr (Project attrNames expr) = do
28 rel <- evalRelationalExpr expr
29 rel <- evalRelationalExpr expr
29− case rel of
30+ case rel of
30 Right rel2 -> return $ project attrNames rel2
31 Right rel2 -> return $ project attrNames rel2
31 Left err -> return $ Left err
32 Left err -> return $ Left err
32
33
@@ -47,71 +48,71 @@ evalRelationalExpr (Join exprA exprB) = do
47 Right relA2 -> case relB of
48 Right relA2 -> case relB of
48 Left err -> return $ Left err
49 Left err -> return $ Left err
49 Right relB2 -> return $ join relA2 relB2
50 Right relB2 -> return $ join relA2 relB2
50−
51+
51evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
52evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
52 case mkRelation attributeSet tupleSet of
53 case mkRelation attributeSet tupleSet of
53 Right rel -> return $ Right rel
54 Right rel -> return $ Right rel
54 Left err -> return $ Left err
55 Left err -> return $ Left err
55−
56+
56evalRelationalExpr (ExistingRelation rel) = return (Right rel)
57evalRelationalExpr (ExistingRelation rel) = return (Right rel)
57−
58+
58evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
59evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
59 evald <- evalRelationalExpr relExpr
60 evald <- evalRelationalExpr relExpr
60 case evald of
61 case evald of
61 Right rel -> return $ rename oldAttrName newAttrName rel
62 Right rel -> return $ rename oldAttrName newAttrName rel
62 Left err -> return $ Left err
63 Left err -> return $ Left err
63−
64+
64evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do
65evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do
65 evald <- evalRelationalExpr relExpr
66 evald <- evalRelationalExpr relExpr
66− case evald of
67+ case evald of
67 Right rel -> return $ group oldAttrNameSet newAttrName rel
68 Right rel -> return $ group oldAttrNameSet newAttrName rel
68 Left err -> return $ Left err
69 Left err -> return $ Left err
69−
70+
70evalRelationalExpr (Ungroup attrName relExpr) = do
71evalRelationalExpr (Ungroup attrName relExpr) = do
71 evald <- evalRelationalExpr relExpr
72 evald <- evalRelationalExpr relExpr
72 case evald of
73 case evald of
73 Right rel -> return $ ungroup attrName rel
74 Right rel -> return $ ungroup attrName rel
74 Left err -> return $ Left err
75 Left err -> return $ Left err
75−
76+
76evalRelationalExpr (Restrict predicateExpr relExpr) = do
77evalRelationalExpr (Restrict predicateExpr relExpr) = do
77 evald <- evalRelationalExpr relExpr
78 evald <- evalRelationalExpr relExpr
78 context <- get
79 context <- get
79− case evald of
80+ case evald of
80 Left err -> return $ Left err
81 Left err -> return $ Left err
81 Right rel -> case predicateRestrictionFilter context (attributes rel) predicateExpr of
82 Right rel -> case predicateRestrictionFilter context (attributes rel) predicateExpr of
82 Left err -> return $ Left err
83 Left err -> return $ Left err
83 Right filterfunc -> return $ restrict filterfunc rel
84 Right filterfunc -> return $ restrict filterfunc rel
84−
85+
85evalRelationalExpr (Equals relExprA relExprB) = do
86evalRelationalExpr (Equals relExprA relExprB) = do
86 evaldA <- evalRelationalExpr relExprA
87 evaldA <- evalRelationalExpr relExprA
87 evaldB <- evalRelationalExpr relExprB
88 evaldB <- evalRelationalExpr relExprB
88 case evaldA of
89 case evaldA of
89 Left err -> return $ Left err
90 Left err -> return $ Left err
90− Right relA -> case evaldB of
91+ Right relA -> case evaldB of
91 Left err -> return $ Left err
92 Left err -> return $ Left err
92 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse
93 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse
93−
94+
94--warning: copy-pasta from above- refactor
95--warning: copy-pasta from above- refactor
95evalRelationalExpr (NotEquals relExprA relExprB) = do
96evalRelationalExpr (NotEquals relExprA relExprB) = do
96 evaldA <- evalRelationalExpr relExprA
97 evaldA <- evalRelationalExpr relExprA
97 evaldB <- evalRelationalExpr relExprB
98 evaldB <- evalRelationalExpr relExprB
98 case evaldA of
99 case evaldA of
99 Left err -> return $ Left err
100 Left err -> return $ Left err
100− Right relA -> case evaldB of
101+ Right relA -> case evaldB of
101 Left err -> return $ Left err
102 Left err -> return $ Left err
102 Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse
103 Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse
103−
104+
104−-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
105+-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
105−evalRelationalExpr (Extend tupleExpression relExpr) = do
106+evalRelationalExpr (Extend tupleExpression relExpr) = do
106 evald <- evalRelationalExpr relExpr
107 evald <- evalRelationalExpr relExpr
107 context <- get
108 context <- get
108− case evald of
109+ case evald of
109 Left err -> return $ Left err
110 Left err -> return $ Left err
110 Right rel -> do
111 Right rel -> do
111 case tupleExpressionProcessor rel tupleExpression context of
112 case tupleExpressionProcessor rel tupleExpression context of
112 Left err -> return $ Left err
113 Left err -> return $ Left err
113 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel
114 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel
114−
115+
115emptyDatabaseContext :: DatabaseContext
116emptyDatabaseContext :: DatabaseContext
116emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
117emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
117 relationVariables = M.empty,
118 relationVariables = M.empty,
@@ -126,8 +127,8 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
126 }
127 }
127
128
128dateExamples :: DatabaseContext
129dateExamples :: DatabaseContext
129−dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,
130+dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,
130− relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,
131+ relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,
131 atomFunctions = basicAtomFunctions}
132 atomFunctions = basicAtomFunctions}
132 where
133 where
133 dateRelVars = M.fromList [("S", suppliers),
134 dateRelVars = M.fromList [("S", suppliers),
@@ -141,77 +142,77 @@ dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,
141 ("SP_pkey", simplePKey ["S#", "P#"] "SP")
142 ("SP_pkey", simplePKey ["S#", "P#"] "SP")
142 ]
143 ]
143 simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)
144 simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)
144−
145+
145−suppliersRel :: Relation
146+suppliersRel :: Relation
146suppliersRel = case mkRelationFromList attrs atomMatrix of
147suppliersRel = case mkRelationFromList attrs atomMatrix of
147 Left _ -> undefined
148 Left _ -> undefined
148 Right rel -> rel
149 Right rel -> rel
149 where
150 where
150− attrs = A.attributesFromList [Attribute "S#" StringAtomType,
151+ attrs = A.attributesFromList [Attribute "S#" stringAtomType,
151− Attribute "SNAME" StringAtomType,
152+ Attribute "SNAME" stringAtomType,
152− Attribute "STATUS" IntAtomType,
153+ Attribute "STATUS" intAtomType,
153− Attribute "CITY" StringAtomType]
154+ Attribute "CITY" stringAtomType]
154 atomMatrix = [
155 atomMatrix = [
155− [StringAtom "S1", StringAtom "Smith", IntAtom 20, StringAtom "London"],
156+ [stringAtom "S1", stringAtom "Smith", intAtom 20, stringAtom "London"],
156− [StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"],
157+ [stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"],
157− [StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],
158+ [stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],
158− [StringAtom "S4", StringAtom "Clark", IntAtom 20, StringAtom "London"],
159+ [stringAtom "S4", stringAtom "Clark", intAtom 20, stringAtom "London"],
159− [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]
160+ [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]
160−
161+
161supplierProductsRel :: Relation
162supplierProductsRel :: Relation
162supplierProductsRel = case mkRelationFromList attrs matrix of
163supplierProductsRel = case mkRelationFromList attrs matrix of
163 Left _ -> undefined
164 Left _ -> undefined
164 Right rel -> rel
165 Right rel -> rel
165 where
166 where
166− attrs = A.attributesFromList [Attribute "S#" StringAtomType,
167+ attrs = A.attributesFromList [Attribute "S#" stringAtomType,
167− Attribute "P#" StringAtomType,
168+ Attribute "P#" stringAtomType,
168− Attribute "QTY" IntAtomType]
169+ Attribute "QTY" intAtomType]
169 matrix = [
170 matrix = [
170− [StringAtom "S1", StringAtom "P1", IntAtom 300],
171+ [stringAtom "S1", stringAtom "P1", intAtom 300],
171− [StringAtom "S1", StringAtom "P2", IntAtom 200],
172+ [stringAtom "S1", stringAtom "P2", intAtom 200],
172− [StringAtom "S1", StringAtom "P3", IntAtom 400],
173+ [stringAtom "S1", stringAtom "P3", intAtom 400],
173− [StringAtom "S1", StringAtom "P4", IntAtom 200],
174+ [stringAtom "S1", stringAtom "P4", intAtom 200],
174− [StringAtom "S1", StringAtom "P5", IntAtom 100],
175+ [stringAtom "S1", stringAtom "P5", intAtom 100],
175− [StringAtom "S1", StringAtom "P6", IntAtom 100],
176+ [stringAtom "S1", stringAtom "P6", intAtom 100],
176− [StringAtom "S2", StringAtom "P1", IntAtom 300],
177+ [stringAtom "S2", stringAtom "P1", intAtom 300],
177− [StringAtom "S2", StringAtom "P2", IntAtom 400],
178+ [stringAtom "S2", stringAtom "P2", intAtom 400],
178− [StringAtom "S3", StringAtom "P2", IntAtom 200],
179+ [stringAtom "S3", stringAtom "P2", intAtom 200],
179− [StringAtom "S4", StringAtom "P2", IntAtom 200],
180+ [stringAtom "S4", stringAtom "P2", intAtom 200],
180− [StringAtom "S4", StringAtom "P4", IntAtom 300],
181+ [stringAtom "S4", stringAtom "P4", intAtom 300],
181− [StringAtom "S4", StringAtom "P5", IntAtom 400]
182+ [stringAtom "S4", stringAtom "P5", intAtom 400]
182 ]
183 ]
183−
184+
184−productsRel :: Relation
185+productsRel :: Relation
185productsRel = case mkRelationFromList attrs matrix of
186productsRel = case mkRelationFromList attrs matrix of
186 Left _ -> undefined
187 Left _ -> undefined
187 Right rel -> rel
188 Right rel -> rel
188 where
189 where
189− attrs = A.attributesFromList [Attribute "P#" StringAtomType,
190+ attrs = A.attributesFromList [Attribute "P#" stringAtomType,
190− Attribute "PNAME" StringAtomType,
191+ Attribute "PNAME" stringAtomType,
191− Attribute "COLOR" StringAtomType,
192+ Attribute "COLOR" stringAtomType,
192− Attribute "WEIGHT" IntAtomType,
193+ Attribute "WEIGHT" intAtomType,
193− Attribute "CITY" StringAtomType]
194+ Attribute "CITY" stringAtomType]
194− matrix = [
195+ matrix = [
195− [StringAtom "P1", StringAtom "Nut", StringAtom "Red", IntAtom 12, StringAtom "London"],
196+ [stringAtom "P1", stringAtom "Nut", stringAtom "Red", intAtom 12, stringAtom "London"],
196− [StringAtom "P2", StringAtom "Bolt", StringAtom "Green", IntAtom 17, StringAtom "Paris"],
197+ [stringAtom "P2", stringAtom "Bolt", stringAtom "Green", intAtom 17, stringAtom "Paris"],
197− [StringAtom "P3", StringAtom "Screw", StringAtom "Blue", IntAtom 17, StringAtom "Oslo"],
198+ [stringAtom "P3", stringAtom "Screw", stringAtom "Blue", intAtom 17, stringAtom "Oslo"],
198− [StringAtom "P4", StringAtom "Screw", StringAtom "Red", IntAtom 14, StringAtom "London"],
199+ [stringAtom "P4", stringAtom "Screw", stringAtom "Red", intAtom 14, stringAtom "London"],
199− [StringAtom "P5", StringAtom "Cam", StringAtom "Blue", IntAtom 12, StringAtom "Paris"],
200+ [stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"],
200− [StringAtom "P6", StringAtom "Cog", StringAtom "Red", IntAtom 19, StringAtom "London"]
201+ [stringAtom "P6", stringAtom "Cog", stringAtom "Red", intAtom 19, stringAtom "London"]
201 ]
202 ]
202−
203+
203−--helper function to process relation variable creation/assignment
204+--helper function to process relation variable creation/assignment
204setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
205setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
205−setRelVar relVarName rel = do
206+setRelVar relVarName rel = do
206 currentContext <- get
207 currentContext <- get
207 let newRelVars = M.insert relVarName rel $ relationVariables currentContext
208 let newRelVars = M.insert relVarName rel $ relationVariables currentContext
208 let potentialContext = DatabaseContext (inclusionDependencies currentContext) newRelVars (atomFunctions currentContext)
209 let potentialContext = DatabaseContext (inclusionDependencies currentContext) newRelVars (atomFunctions currentContext)
209 case checkConstraints potentialContext of
210 case checkConstraints potentialContext of
210 Just err -> return $ Just err
211 Just err -> return $ Just err
211− Nothing -> do
212+ Nothing -> do
212 put potentialContext
213 put potentialContext
213 return Nothing
214 return Nothing
214−
215+
215-- 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
216-- 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
216deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
217deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
217deleteRelVar relVarName = do
218deleteRelVar relVarName = do
@@ -223,31 +224,31 @@ deleteRelVar relVarName = do
223evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
224evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
224evalContextExpr (Define relVarName attrs) = do
225evalContextExpr (Define relVarName attrs) = do
225 relvars <- liftM relationVariables get
226 relvars <- liftM relationVariables get
226− case M.member relVarName relvars of
227+ case M.member relVarName relvars of
227 True -> return (Just (RelVarAlreadyDefinedError relVarName))
228 True -> return (Just (RelVarAlreadyDefinedError relVarName))
228 False -> setRelVar relVarName emptyRelation
229 False -> setRelVar relVarName emptyRelation
229 where
230 where
230 emptyRelation = Relation attrs emptyTupleSet
231 emptyRelation = Relation attrs emptyTupleSet
231−
232+
232evalContextExpr (Undefine relVarName) = do
233evalContextExpr (Undefine relVarName) = do
233 deleteRelVar relVarName
234 deleteRelVar relVarName
234−
235+
235evalContextExpr (Assign relVarName expr) = do
236evalContextExpr (Assign relVarName expr) = do
236 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
237 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
237 relVarTable <- liftM relationVariables get
238 relVarTable <- liftM relationVariables get
238 let existingRelVar = M.lookup relVarName relVarTable
239 let existingRelVar = M.lookup relVarName relVarTable
239− value <- evalRelationalExpr expr
240+ value <- evalRelationalExpr expr
240− case value of
241+ case value of
241 Left err -> return $ Just err
242 Left err -> return $ Just err
242− Right rel -> case existingRelVar of
243+ Right rel -> case existingRelVar of
243 Nothing -> setRelVar relVarName rel
244 Nothing -> setRelVar relVarName rel
244 Just existingRel -> let expectedAttributes = attributes existingRel
245 Just existingRel -> let expectedAttributes = attributes existingRel
245 foundAttributes = attributes rel in
246 foundAttributes = attributes rel in
246− if A.attributesEqual expectedAttributes foundAttributes then
247+ if A.attributesEqual expectedAttributes foundAttributes then
247 setRelVar relVarName rel
248 setRelVar relVarName rel
248 else
249 else
249 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)
250 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)
250−
251+
251evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName))
252evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName))
252
253
253--assign empty rel until restriction is implemented
254--assign empty rel until restriction is implemented
@@ -256,16 +257,16 @@ evalContextExpr (Delete relVarName predicate) = do
256 case updatedRel of
257 case updatedRel of
257 Left err -> return $ Just err
258 Left err -> return $ Just err
258 Right rel -> setRelVar relVarName rel
259 Right rel -> setRelVar relVarName rel
259−
260+
260--union of restricted+updated portion and the unrestricted+unupdated portion
261--union of restricted+updated portion and the unrestricted+unupdated portion
261evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do
262evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do
262 currstate <- get
263 currstate <- get
263− let relVarTable = relationVariables currstate
264+ let relVarTable = relationVariables currstate
264 case M.lookup relVarName relVarTable of
265 case M.lookup relVarName relVarTable of
265 Nothing -> return $ Just (RelVarNotDefinedError relVarName)
266 Nothing -> return $ Just (RelVarNotDefinedError relVarName)
266 Just rel -> case predicateRestrictionFilter currstate (attributes rel) restrictionPredicateExpr of
267 Just rel -> case predicateRestrictionFilter currstate (attributes rel) restrictionPredicateExpr of
267 Left err -> return $ Just err
268 Left err -> return $ Just err
268− Right predicateFunc -> do
269+ Right predicateFunc -> do
269 case makeUpdatedRel rel of
270 case makeUpdatedRel rel of
270 Left err -> return $ Just err
271 Left err -> return $ Just err
271 Right updatedRel -> setRelVar relVarName updatedRel
272 Right updatedRel -> setRelVar relVarName updatedRel
@@ -289,8 +290,8 @@ evalContextExpr (AddInclusionDependency newDepName newDep) = do
289 Nothing -> do
290 Nothing -> do
290 put potentialContext
291 put potentialContext
291 return Nothing
292 return Nothing
292−
293+
293−evalContextExpr (RemoveInclusionDependency depName) = do
294+evalContextExpr (RemoveInclusionDependency depName) = do
294 currContext <- get
295 currContext <- get
295 let currDeps = inclusionDependencies currContext
296 let currDeps = inclusionDependencies currContext
296 newDeps = M.delete depName currDeps
297 newDeps = M.delete depName currDeps
@@ -307,13 +308,13 @@ evalContextExpr (MultipleExpr exprs) = do
307 case catMaybes evald of
308 case catMaybes evald of
308 [] -> return $ Nothing
309 [] -> return $ Nothing
309 err:_ -> return $ Just err
310 err:_ -> return $ Just err
310−
311+
311−-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples
312+-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples
312--evalRelVarExpr (Update relVarName updateMap) = do
313--evalRelVarExpr (Update relVarName updateMap) = do
313
314
314--run verification on all constraints
315--run verification on all constraints
315checkConstraints :: DatabaseContext -> Maybe RelationalError
316checkConstraints :: DatabaseContext -> Maybe RelationalError
316−checkConstraints context = case failures of
317+checkConstraints context = case failures of
317 [] -> Nothing
318 [] -> Nothing
318 l:_ -> Just l
319 l:_ -> Just l
319 where
320 where
@@ -321,13 +322,13 @@ checkConstraints context = case failures of
321 deps = inclusionDependencies context
322 deps = inclusionDependencies context
322 eval expr = runState (evalRelationalExpr expr) context
323 eval expr = runState (evalRelationalExpr expr) context
323 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = case evaldSub of
324 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = case evaldSub of
324− (Left err, _) -> Just err
325+ (Left err, _) -> Just err
325 (Right relSub, _) -> case evaldSuper of
326 (Right relSub, _) -> case evaldSuper of
326 (Left err, _) -> Just err
327 (Left err, _) -> Just err
327 (Right relSuper, _) -> case union relSub relSuper of
328 (Right relSuper, _) -> case union relSub relSuper of
328 Left err -> Just err
329 Left err -> Just err
329− Right resultRel -> if resultRel == relSuper then
330+ Right resultRel -> if resultRel == relSuper then
330− Nothing
331+ Nothing
331 else
332 else
332 Just $ InclusionDependencyCheckError depName
333 Just $ InclusionDependencyCheckError depName
333 where
334 where
@@ -339,32 +340,32 @@ checkConstraint :: InclusionDependency -> DatabaseState (Maybe RelationalError)
339checkConstraint (InclusionDependency name subDep superDep) = do
340checkConstraint (InclusionDependency name subDep superDep) = do
340 evalSub <- evalRelationalExpr subDep
341 evalSub <- evalRelationalExpr subDep
341 evalSuper <- evalRelationalExpr superDep
342 evalSuper <- evalRelationalExpr superDep
342− case evalSub of
343+ case evalSub of
343 Left err -> Just err
344 Left err -> Just err
344− Right relSub
345+ Right relSub
345 result <- liftM2 union evalSub evalSuper
346 result <- liftM2 union evalSub evalSuper
346 return $ Nothing
347 return $ Nothing
347-}
348-}
348−
349+
349-- 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
350-- 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
350-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
351-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
351−
352+
352typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
353typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
353typeForRelationalExpr expr = do
354typeForRelationalExpr expr = do
354 currstate <- get
355 currstate <- get
355 --replace the relationVariables context element with a cloned set of relation devoid of tuples
356 --replace the relationVariables context element with a cloned set of relation devoid of tuples
356 put $ contextWithEmptyTupleSets currstate
357 put $ contextWithEmptyTupleSets currstate
357 evalRelationalExpr expr
358 evalRelationalExpr expr
358−
359+
359−--returns a database context with all tuples removed
360+--returns a database context with all tuples removed
360--this is useful for type checking and optimization
361--this is useful for type checking and optimization
361contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
362contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
362contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs
363contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs
363 where
364 where
364− incDeps = inclusionDependencies contextIn
365+ incDeps = inclusionDependencies contextIn
365 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
366 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
366 funcs = atomFunctions contextIn
367 funcs = atomFunctions contextIn
367−
368+
368{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
369{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
369predicateRestrictionFilter :: DatabaseContext -> Attributes -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)
370predicateRestrictionFilter :: DatabaseContext -> Attributes -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)
370predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do
371predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do
@@ -376,9 +377,9 @@ predicateRestrictionFilter context attrs (OrPredicate expr1 expr2) = do
376 expr1v <- predicateRestrictionFilter context attrs expr1
377 expr1v <- predicateRestrictionFilter context attrs expr1
377 expr2v <- predicateRestrictionFilter context attrs expr2
378 expr2v <- predicateRestrictionFilter context attrs expr2
378 return $ \x -> expr1v x || expr2v x
379 return $ \x -> expr1v x || expr2v x
379−
380+
380predicateRestrictionFilter _ _ TruePredicate = Right $ \_ -> True
381predicateRestrictionFilter _ _ TruePredicate = Right $ \_ -> True
381−
382+
382predicateRestrictionFilter context attrs (NotPredicate expr) = do
383predicateRestrictionFilter context attrs (NotPredicate expr) = do
383 exprv <- predicateRestrictionFilter context attrs expr
384 exprv <- predicateRestrictionFilter context attrs expr
384 return $ \x -> not (exprv x)
385 return $ \x -> not (exprv x)
@@ -386,12 +387,12 @@ predicateRestrictionFilter context attrs (NotPredicate expr) = do
386predicateRestrictionFilter context _ (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of
387predicateRestrictionFilter context _ (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of
387 (Left err, _) -> Left err
388 (Left err, _) -> Left err
388 (Right rel, _) -> if rel == relationTrue then
389 (Right rel, _) -> if rel == relationTrue then
389− Right $ \_ -> True
390+ Right $ \_ -> True
390 else if rel == relationFalse then
391 else if rel == relationFalse then
391− Right $ \_ -> False
392+ Right $ \_ -> False
392 else
393 else
393 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
394 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
394−
395+
395predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName atomExpr) = do
396predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName atomExpr) = do
396 attr <- A.attributeForName attrName attrs
397 attr <- A.attributeForName attrName attrs
397 atomExprType <- typeFromAtomExpr attrs context atomExpr
398 atomExprType <- typeFromAtomExpr attrs context atomExpr
@@ -400,20 +401,20 @@ predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName at
400 else
401 else
401 Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of
402 Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of
402 Left _ -> False
403 Left _ -> False
403− Right atomIn ->
404+ Right atomIn ->
404 case evalAtomExpr tupleIn context atomExpr of
405 case evalAtomExpr tupleIn context atomExpr of
405 Left _ -> False
406 Left _ -> False
406 Right atomCmp -> atomCmp == atomIn
407 Right atomCmp -> atomCmp == atomIn
407−
408+
408−-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
409+-- 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
410+predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do
410 aType <- typeFromAtomExpr attrs context atomExpr
411 aType <- typeFromAtomExpr attrs context atomExpr
411− if aType /= BoolAtomType then
412+ if aType /= boolAtomType then
412− Left $ AtomTypeMismatchError aType BoolAtomType
413+ Left $ AtomTypeMismatchError aType boolAtomType
413 else
414 else
414 Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of
415 Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of
415 Left _ -> False
416 Left _ -> False
416− Right boolAtomValue -> boolAtomValue == BoolAtom True)
417+ Right boolAtomValue -> boolAtomValue == Atom True)
417
418
418tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
419tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
419tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then
420tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then
@@ -422,7 +423,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName
422 Right rel
423 Right rel
423
424
424tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)
425tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)
425−tupleExpressionProcessor relIn
426+tupleExpressionProcessor relIn
426 (AttributeTupleExpr newAttrName atomExpr) context = do
427 (AttributeTupleExpr newAttrName atomExpr) context = do
427 _ <- tupleExprCheckNewAttrName newAttrName relIn
428 _ <- tupleExprCheckNewAttrName newAttrName relIn
428 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr
429 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr
@@ -445,12 +446,12 @@ evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do
445 return $ (atomFunc func) evaldArgs
446 return $ (atomFunc func) evaldArgs
446evalAtomExpr _ context (RelationAtomExpr relExpr) = do
447evalAtomExpr _ context (RelationAtomExpr relExpr) = do
447 relAtom <- evalState (evalRelationalExpr relExpr) context
448 relAtom <- evalState (evalRelationalExpr relExpr) context
448− return $ RelationAtom relAtom
449+ return $ Atom relAtom
449
450
450typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType
451typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType
451typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs
452typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs
452typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)
453typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)
453−typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do
454+typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do
454 let funcs = atomFunctions context
455 let funcs = atomFunctions context
455 func <- atomFunctionForName funcName funcs
456 func <- atomFunctionForName funcName funcs
456 return $ last (atomFuncType func)
457 return $ last (atomFuncType func)
@@ -481,49 +482,62 @@ verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do
481 (Left err, _) -> Left err
482 (Left err, _) -> Left err
482 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))
483 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))
483
484
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+
484basicAtomFunctions :: AtomFunctions
496basicAtomFunctions :: AtomFunctions
485basicAtomFunctions = HS.fromList [
497basicAtomFunctions = HS.fromList [
486 --match on any relation type
498 --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)},
488 AtomFunction { atomFuncName = "id",
502 AtomFunction { atomFuncName = "id",
489 atomFuncType = [AnyAtomType, AnyAtomType],
503 atomFuncType = [AnyAtomType, AnyAtomType],
490 atomFunc = (\(x:_) -> x)},
504 atomFunc = (\(x:_) -> x)},
491 AtomFunction { atomFuncName = "sum",
505 AtomFunction { atomFuncName = "sum",
492− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,
506+ atomFuncType = foldAtomFuncType intAtomType intAtomType,
493− atomFunc = (\((RelationAtom relIn):_) -> relationSum relIn)},
507+ atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},
494 AtomFunction { atomFuncName = "count",
508 AtomFunction { atomFuncName = "count",
495− atomFuncType = foldAtomFuncType AnyAtomType IntAtomType,
509+ atomFuncType = foldAtomFuncType AnyAtomType intAtomType,
496− atomFunc = (\((RelationAtom relIn):_) -> relationCount relIn)},
510+ atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},
497 AtomFunction { atomFuncName = "max",
511 AtomFunction { atomFuncName = "max",
498− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,
512+ atomFuncType = foldAtomFuncType intAtomType intAtomType,
499− atomFunc = (\((RelationAtom relIn):_) -> relationMax relIn)},
513+ atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},
500 AtomFunction { atomFuncName = "min",
514 AtomFunction { atomFuncName = "min",
501− atomFuncType = foldAtomFuncType IntAtomType IntAtomType,
515+ atomFuncType = foldAtomFuncType intAtomType intAtomType,
502− atomFunc = (\((RelationAtom relIn):_) -> relationMin relIn)},
516+ atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},
503 AtomFunction { atomFuncName = "lt",
517 AtomFunction { atomFuncName = "lt",
504− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],
518+ atomFuncType = [intAtomType, intAtomType, boolAtomType],
505 atomFunc = intAtomFuncLessThan False},
519 atomFunc = intAtomFuncLessThan False},
506 AtomFunction { atomFuncName = "lte",
520 AtomFunction { atomFuncName = "lte",
507− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],
521+ atomFuncType = [intAtomType, intAtomType, boolAtomType],
508 atomFunc = intAtomFuncLessThan True},
522 atomFunc = intAtomFuncLessThan True},
509 AtomFunction { atomFuncName = "gte",
523 AtomFunction { atomFuncName = "gte",
510− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],
524+ atomFuncType = [intAtomType, intAtomType, boolAtomType],
511 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},
525 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},
512 AtomFunction { atomFuncName = "gt",
526 AtomFunction { atomFuncName = "gt",
513− atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],
527+ atomFuncType = [intAtomType, intAtomType, boolAtomType],
514 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},
528 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},
515 AtomFunction { atomFuncName = "not",
529 AtomFunction { atomFuncName = "not",
516− atomFuncType = [BoolAtomType, BoolAtomType],
530+ atomFuncType = [boolAtomType, boolAtomType],
517 atomFunc = boolAtomNot}
531 atomFunc = boolAtomNot}
518 ]
532 ]
519
533
520intAtomFuncLessThan :: Bool -> [Atom] -> Atom
534intAtomFuncLessThan :: 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
522 where
536 where
523 op = if equality then (<=) else (<)
537 op = if equality then (<=) else (<)
524−intAtomFuncLessThan _ _= BoolAtom False
538+intAtomFuncLessThan _ _= Atom False
525
539
526boolAtomNot :: [Atom] -> Atom
540boolAtomNot :: [Atom] -> Atom
527−boolAtomNot (BoolAtom bool:_) = BoolAtom $ not bool
541+boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)
528−boolAtomNot _ = BoolAtom False
542+boolAtomNot _ = Atom False
529
543
ProjectM36/TransactionGraph.hs+35−35
@@ -6,6 +6,7 @@ import ProjectM36.Transaction
6import ProjectM36.Relation
6import ProjectM36.Relation
7import ProjectM36.TupleSet
7import ProjectM36.TupleSet
8import ProjectM36.Tuple
8import ProjectM36.Tuple
9+import ProjectM36.Atom
9import qualified Data.Vector as V
10import qualified Data.Vector as V
10import qualified ProjectM36.Attribute as A
11import qualified ProjectM36.Attribute as A
11import qualified Data.UUID as U
12import qualified Data.UUID as U
@@ -19,9 +20,9 @@ data TransactionGraphOperator = JumpToHead HeadName |
19 JumpToTransaction U.UUID |
20 JumpToTransaction U.UUID |
20 Branch HeadName |
21 Branch HeadName |
21 Commit |
22 Commit |
22− Rollback
23+ Rollback
23
24
24−data ROTransactionGraphOperator = ShowGraph
25+data ROTransactionGraphOperator = ShowGraph
25
26
26bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
27bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
27bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
28bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
@@ -29,10 +30,10 @@ bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bo
29 bootstrapHeads = M.singleton "master" freshTransaction
30 bootstrapHeads = M.singleton "master" freshTransaction
30 freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context
31 freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context
31 bootstrapTransactions = S.singleton freshTransaction
32 bootstrapTransactions = S.singleton freshTransaction
32−
33+
33−emptyTransactionGraph :: TransactionGraph
34+emptyTransactionGraph :: TransactionGraph
34emptyTransactionGraph = TransactionGraph M.empty S.empty
35emptyTransactionGraph = TransactionGraph M.empty S.empty
35−
36+
36transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
37transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
37transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
38transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
38
39
@@ -43,7 +44,7 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi
43 Just $ (head . M.keys) matchingTrans
44 Just $ (head . M.keys) matchingTrans
44 where
45 where
45 matchingTrans = M.filter (transaction ==) heads
46 matchingTrans = M.filter (transaction ==) heads
46−
47+
47transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction
48transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction
48transactionForUUID uuid graph = if S.null matchingTrans then
49transactionForUUID uuid graph = if S.null matchingTrans then
49 Left $ NoSuchTransactionError uuid
50 Left $ NoSuchTransactionError uuid
@@ -52,15 +53,15 @@ transactionForUUID uuid graph = if S.null matchingTrans then
52 where
53 where
53 matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
54 matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
54
55
55−transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
56+transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
56transactionsForUUIDs uuidSet graph = do
57transactionsForUUIDs uuidSet graph = do
57 transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)
58 transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)
58 return (S.fromList transList)
59 return (S.fromList transList)
59−
60+
60isRootTransaction :: Transaction -> TransactionGraph -> Bool
61isRootTransaction :: Transaction -> TransactionGraph -> Bool
61isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID
62isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID
62isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
63isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
63−
64+
64-- the first transaction has no parent - all other do have parents- merges have two parents
65-- the first transaction has no parent - all other do have parents- merges have two parents
65parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
66parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
66parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
67parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
@@ -68,8 +69,8 @@ parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
68 return (S.singleton trans)
69 return (S.singleton trans)
69
70
70parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph
71parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph
71−
72+
72−
73+
73childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
74childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
74childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children
75childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children
75childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children
76childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children
@@ -82,7 +83,7 @@ addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBra
82--adds a disconnected transaction to a transaction graph at some head
83--adds a disconnected transaction to a transaction graph at some head
83addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
84addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
84addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
85addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
85− parentTrans <- transactionForUUID parentUUID graph
86+ parentTrans <- transactionForUUID parentUUID graph
86 addTransactionToGraph headName parentTrans newUUID context graph
87 addTransactionToGraph headName parentTrans newUUID context graph
87
88
88-- create a new transaction on "newHeadName" with the branchPointTrans
89-- create a new transaction on "newHeadName" with the branchPointTrans
@@ -101,38 +102,38 @@ validateGraph graph@(TransactionGraph _ transSet) = do
101 --check that all UUIDs are unique in the graph
102 --check that all UUIDs are unique in the graph
102 --uuids = map transactionUUID transSet
103 --uuids = map transactionUUID transSet
103 --check that all heads appear in the transSet
104 --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
105 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
106 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
106 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
107 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
107−
108+
108--verify that all parent links exist and that all children exist
109--verify that all parent links exist and that all children exist
109--maybe verify that all parents end at UUID nil and all children end at leaves
110--maybe verify that all parents end at UUID nil and all children end at leaves
110walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
111walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
111walkParentTransactions seenTransSet graph trans =
112walkParentTransactions seenTransSet graph trans =
112− let transUUID = transactionUUID trans in
113+ let transUUID = transactionUUID trans in
113− if transUUID == U.nil then
114+ if transUUID == U.nil then
114 Nothing
115 Nothing
115 else if S.member transUUID seenTransSet then
116 else if S.member transUUID seenTransSet then
116 Just $ TransactionGraphCycleError transUUID
117 Just $ TransactionGraphCycleError transUUID
117− else
118+ else
118 let parentTransSetOrError = parentTransactions trans graph in
119 let parentTransSetOrError = parentTransactions trans graph in
119− case parentTransSetOrError of
120+ case parentTransSetOrError of
120 Left err -> Just err
121 Left err -> Just err
121− Right parentTransSet -> do
122+ Right parentTransSet -> do
122 walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
123 walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
123 case walk of
124 case walk of
124 err:_ -> Just err
125 err:_ -> Just err
125 _ -> Nothing
126 _ -> Nothing
126−
127+
127--refactor: needless duplication in these two functions
128--refactor: needless duplication in these two functions
128walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
129walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
129−walkChildTransactions seenTransSet graph trans =
130+walkChildTransactions seenTransSet graph trans =
130− let transUUID = transactionUUID trans in
131+ let transUUID = transactionUUID trans in
131 if childTransactions trans graph == Right S.empty then
132 if childTransactions trans graph == Right S.empty then
132 Nothing
133 Nothing
133 else if S.member transUUID seenTransSet then
134 else if S.member transUUID seenTransSet then
134 Just $ TransactionGraphCycleError transUUID
135 Just $ TransactionGraphCycleError transUUID
135− else
136+ else
136 let childTransSetOrError = childTransactions trans graph in
137 let childTransSetOrError = childTransactions trans graph in
137 case childTransSetOrError of
138 case childTransSetOrError of
138 Left err -> Just err
139 Left err -> Just err
@@ -209,24 +210,23 @@ evalROGraphOp discon graph ShowGraph = do
209 graphRel <- graphAsRelation discon graph
210 graphRel <- graphAsRelation discon graph
210 return graphRel
211 return graphRel
211
212
212−--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
213+--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
214+graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
214graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
215graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
215 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
216 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
216 mkRelationFromList attrs tupleMatrix
217 mkRelationFromList attrs tupleMatrix
217 where
218 where
218− attrs = A.attributesFromList [Attribute "id" StringAtomType,
219+ attrs = A.attributesFromList [Attribute "id" stringAtomType,
219 Attribute "parents" (RelationAtomType parentAttributes),
220 Attribute "parents" (RelationAtomType parentAttributes),
220− Attribute "current" BoolAtomType,
221+ Attribute "current" boolAtomType,
221− Attribute "head" StringAtomType
222+ Attribute "head" stringAtomType
222 ]
223 ]
223− parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]
224+ parentAttributes = A.attributesFromList [Attribute "id" stringAtomType]
224 tupleGenerator transaction = case transactionParentsRelation transaction graph of
225 tupleGenerator transaction = case transactionParentsRelation transaction graph of
225 Left err -> Left err
226 Left err -> Left err
226− Right parentTransRel -> Right [StringAtom $ T.pack $ show (transactionUUID transaction),
227+ Right _ -> Right [Atom $ T.pack $ show (transactionUUID transaction),
227− RelationAtom parentTransRel,
228− BoolAtom $ parentUUID == transactionUUID transaction,
228+ Atom $ parentUUID == transactionUUID transaction,
229− StringAtom $ case headNameForTransaction transaction graph of
229+ Atom $ case headNameForTransaction transaction graph of
230 Just headName -> headName
230 Just headName -> headName
231 Nothing -> ""
231 Nothing -> ""
232 ]
232 ]
@@ -240,5 +240,5 @@ transactionParentsRelation trans graph = do
240 let tuples = map trans2tuple (S.toList parentTransSet)
240 let tuples = map trans2tuple (S.toList parentTransSet)
241 mkRelationFromTuples attrs tuples
241 mkRelationFromTuples attrs tuples
242 where
242 where
243− attrs = A.attributesFromList [Attribute "id" StringAtomType]
243+ attrs = A.attributesFromList [Attribute "id" stringAtomType]
244− trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (T.pack (show $ transactionUUID trans2)))
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.
281. [Transaction Graph Operators](docs/transaction_graph_operators.markdown)
281. [Transaction Graph Operators](docs/transaction_graph_operators.markdown)
291. [Persistent Library Driver](docs/persistent_library_driver.markdown)
291. [Persistent Library Driver](docs/persistent_library_driver.markdown)
301. [ProjectM36.Client Library](docs/projectm36_client_library.markdown)
301. [ProjectM36.Client Library](docs/projectm36_client_library.markdown)
31−
31+1. [Adding New Data Types](docs/new_datatypes.markdown)
32
32
33## Development
33## Development
34
34
TutorialD/Interpreter/Base.hs+8−7
@@ -10,6 +10,7 @@ import qualified Data.List as L
10import qualified Data.Vector as V
10import qualified Data.Vector as V
11import qualified Data.Text.IO as TIO
11import qualified Data.Text.IO as TIO
12import System.IO
12import System.IO
13+import ProjectM36.Atom
13
14
14lexer :: Token.TokenParser ()
15lexer :: Token.TokenParser ()
15lexer = Token.makeTokenParser tutD
16lexer = Token.makeTokenParser tutD
@@ -52,14 +53,14 @@ float = Token.float lexer
52
53
53atomTypeToTutDType :: AtomType -> Maybe T.Text
54atomTypeToTutDType :: AtomType -> Maybe T.Text
54atomTypeToTutDType atomType = case atomType of
55atomTypeToTutDType atomType = case atomType of
55− StringAtomType -> Just "char"
56+ aType@(AtomType _) -> lookup aType [(stringAtomType, "char"),
56− IntAtomType -> Just "int"
57+ (intAtomType, "int"),
57− DateTimeAtomType -> Just "datetime"
58+ (boolAtomType, "bool"),
58− DoubleAtomType -> Just "double"
59+ (dateTimeAtomType, "datetime"),
59− DateAtomType -> Just "date"
60+ (doubleAtomType, "double")]
60− RelationAtomType attrs -> Just $ "relation" `T.append` showRelationAttributes attrs
61+ (RelationAtomType attrs) -> Just $ "relation" `T.append` showRelationAttributes attrs
61 _ -> Nothing
62 _ -> Nothing
62−
63+
63showRelationAttributes :: Attributes -> T.Text
64showRelationAttributes :: Attributes -> T.Text
64showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"
65showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"
65 where
66 where
TutorialD/Interpreter/RelationalExpr.hs+43−17
@@ -18,14 +18,17 @@ import Control.Applicative (liftA)
18import Data.ByteString.Base64 as B64
18import Data.ByteString.Base64 as B64
19import Data.Text.Encoding as TE
19import Data.Text.Encoding as TE
20
20
21+import Data.Time.Calendar (Day)
22+import Data.Time.Clock (UTCTime)
23+
21atomTypeP :: Parser AtomType
24atomTypeP :: Parser AtomType
22−atomTypeP = (reserved "char" *> return StringAtomType) <|>
25+atomTypeP = (reserved "char" *> return stringAtomType) <|>
23− (reserved "int" *> return IntAtomType) <|>
26+ (reserved "int" *> return intAtomType) <|>
24− (reserved "datetime" *> return DateTimeAtomType) <|>
27+ (reserved "datetime" *> return dateTimeAtomType) <|>
25− (reserved "date" *> return DateAtomType) <|>
28+ (reserved "date" *> return dateAtomType) <|>
26− (reserved "double" *> return DoubleAtomType) <|>
29+ (reserved "double" *> return doubleAtomType) <|>
27− (reserved "bool" *> return BoolAtomType) <|>
30+ (reserved "bool" *> return boolAtomType) <|>
28− (reserved "bytestring" *> return ByteStringAtomType) <|>
31+ (reserved "bytestring" *> return byteStringAtomType) <|>
29 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))
32 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))
30
33
31--used in projection
34--used in projection
@@ -227,8 +230,16 @@ nakedAtomExprP :: Parser AtomExpr
227nakedAtomExprP = NakedAtomExpr <$> atomP
230nakedAtomExprP = NakedAtomExpr <$> atomP
228
231
229atomP :: Parser Atom
232atomP :: Parser Atom
230−atomP = dateTimeAtomP <|> dateAtomP <|> byteStringAtomP <|>
233+atomP = dateTimeAtomP <|>
234+ dateAtomP <|>
235+ maybeTextAtomP <|>
236+ maybeIntAtomP <|>
237+ byteStringAtomP <|>
238+ stringAtomP <|>
239+ doubleAtomP <|>
240+ intAtomP <|>
241+ boolAtomP <|>
231− stringAtomP <|> doubleAtomP <|> intAtomP <|> boolAtomP <|> relationAtomP
242+ relationAtomP
232
243
233functionAtomExprP :: Parser AtomExpr
244functionAtomExprP :: Parser AtomExpr
234functionAtomExprP = do
245functionAtomExprP = do
@@ -240,7 +251,20 @@ relationalAtomExprP :: Parser AtomExpr
240relationalAtomExprP = RelationAtomExpr <$> relExprP
251relationalAtomExprP = RelationAtomExpr <$> relExprP
241
252
242stringAtomP :: Parser Atom
253stringAtomP :: 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)
244
268
245dateTimeAtomP :: Parser Atom
269dateTimeAtomP :: Parser Atom
246dateTimeAtomP = do
270dateTimeAtomP = do
@@ -249,7 +273,7 @@ dateTimeAtomP = do
249 reserved "::datetime"
273 reserved "::datetime"
250 return dateTimeString
274 return dateTimeString
251 case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" dateTimeString' of
275 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)
253 Nothing -> fail "Failed to parse datetime"
277 Nothing -> fail "Failed to parse datetime"
254
278
255dateAtomP :: Parser Atom
279dateAtomP :: Parser Atom
@@ -259,22 +283,24 @@ dateAtomP = do
259 reserved "::date"
283 reserved "::date"
260 return dateString
284 return dateString
261 case parseTimeM False defaultTimeLocale "%Y-%m-%d" dateString' of
285 case parseTimeM False defaultTimeLocale "%Y-%m-%d" dateString' of
262− Just utctime -> return $ DateAtom utctime
286+ Just todaytime -> return $ Atom (todaytime :: Day)
263 Nothing -> fail "Failed to parse date"
287 Nothing -> fail "Failed to parse date"
264
288
265doubleAtomP :: Parser Atom
289doubleAtomP :: Parser Atom
266−doubleAtomP = DoubleAtom <$> (try float)
290+doubleAtomP = Atom <$> (try float)
267
291
268intAtomP :: Parser Atom
292intAtomP :: Parser Atom
293+intAtomP = do
294+ i <- integer
269−intAtomP = (IntAtom . fromIntegral) <$> integer
295+ return $ Atom ((fromIntegral i) :: Int)
270
296
271boolAtomP :: Parser Atom
297boolAtomP :: Parser Atom
272boolAtomP = do
298boolAtomP = do
273 val <- char 't' <|> char 'f'
299 val <- char 't' <|> char 'f'
274− return $ BoolAtom (val == 't')
300+ return $ Atom (val == 't')
275
301
276relationAtomP :: Parser Atom
302relationAtomP :: Parser Atom
277−relationAtomP = RelationAtom <$> relationP
303+relationAtomP = Atom <$> relationP
278
304
279byteStringAtomP :: Parser Atom
305byteStringAtomP :: Parser Atom
280byteStringAtomP = do
306byteStringAtomP = do
@@ -284,7 +310,7 @@ byteStringAtomP = do
284 return byteString
310 return byteString
285 case B64.decode $ TE.encodeUtf8 (T.pack byteString') of
311 case B64.decode $ TE.encodeUtf8 (T.pack byteString') of
286 Left err -> fail err
312 Left err -> fail err
287− Right bsVal -> return $ ByteStringAtom bsVal
313+ Right bsVal -> return $ Atom bsVal
288
314
289--relation constructor -- no choice but to propagate relation-construction errors as parse errors. Perhaps this could be improved in the future
315--relation constructor -- no choice but to propagate relation-construction errors as parse errors. Perhaps this could be improved in the future
290relationP :: Parser Relation
316relationP :: Parser Relation
benchmark/bigrel.hs+2−3
@@ -1,7 +1,6 @@
1{-# LANGUAGE FlexibleInstances,OverloadedStrings #-}
1{-# LANGUAGE FlexibleInstances,OverloadedStrings #-}
2import ProjectM36.Base
2import ProjectM36.Base
3import ProjectM36.Relation
3import ProjectM36.Relation
4−import ProjectM36.Tuple
5import ProjectM36.Relation.Show.CSV
4import ProjectM36.Relation.Show.CSV
6import ProjectM36.Relation.Show.HTML
5import ProjectM36.Relation.Show.HTML
7import TutorialD.Interpreter.Base (displayOpResult)
6import TutorialD.Interpreter.Base (displayOpResult)
@@ -73,7 +72,7 @@ intmapMatrixRun = do
73intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)
72intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)
74intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
73intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
75 where
74 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]
77
76
78instance Hash.Hashable (IM.IntMap Atom) where
77instance Hash.Hashable (IM.IntMap Atom) where
79 hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)
78 hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)
@@ -88,7 +87,7 @@ vectorMatrixRun = do
88vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)
87vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)
89vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
88vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
90 where
89 where
91− mapper tupCount = V.replicate attributeCount (IntAtom tupCount)
90+ mapper tupCount = V.replicate attributeCount (Atom tupCount)
92
91
93instance Hash.Hashable (V.Vector Atom) where
92instance Hash.Hashable (V.Vector Atom) where
94 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)
93 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)
docs/new_datatypes.markdownnew file+20
@@ -0,0 +1,20 @@
1+# Creating New Data Types
2+
3+## Introduction
4+
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.
6+
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.
8+
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
62 Right rel -> rel
62 Right rel -> rel
63 Left _ -> undefined
63 Left _ -> undefined
64 where
64 where
65− attrs = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" StringAtomType]
65+ attrs = A.attributesFromList [Attribute "a" stringAtomType, Attribute "b" stringAtomType]
66− tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [StringAtom "spam", StringAtom "spam2"])]
66+ tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [stringAtom "spam", stringAtom "spam2"])]
67
67
68--rename tests
68--rename tests
69testRename1 :: Test
69testRename1 :: Test
@@ -77,7 +77,7 @@ testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRe
77testMkRelation1 :: Test
77testMkRelation1 :: Test
78testMkRelation1 = 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
78testMkRelation1 = 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
79 where
79 where
80− testAttrs = A.attributesFromList [Attribute "a" StringAtomType]
80+ testAttrs = A.attributesFromList [Attribute "a" stringAtomType]
81− testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],
81+ testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [stringAtom "v"],
82− mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]
82+ mkRelationTuple testAttrs $ V.fromList [intAtom 2]]
83
83
test/Relation/Export/CSV.hs+7−6
@@ -6,6 +6,7 @@ import ProjectM36.Relation.Show.CSV
6import ProjectM36.Relation.Parse.CSV
6import ProjectM36.Relation.Parse.CSV
7import qualified ProjectM36.Attribute as A
7import qualified ProjectM36.Attribute as A
8import ProjectM36.Relation
8import ProjectM36.Relation
9+import ProjectM36.Atom
9
10
10main :: IO ()
11main :: IO ()
11main = do
12main = do
@@ -15,13 +16,13 @@ main = do
15--round-trip a basic relation through CSV
16--round-trip a basic relation through CSV
16testCSVExport :: Test
17testCSVExport :: Test
17testCSVExport = TestCase $ do
18testCSVExport = TestCase $ do
18− let attrs = A.attributesFromList [Attribute "S#" StringAtomType,
19+ let attrs = A.attributesFromList [Attribute "S#" stringAtomType,
19− Attribute "SNAME" StringAtomType,
20+ Attribute "SNAME" stringAtomType,
20− Attribute "STATUS" IntAtomType,
21+ Attribute "STATUS" intAtomType,
21− Attribute "CITY" StringAtomType]
22+ Attribute "CITY" stringAtomType]
22 relOrErr = mkRelationFromList attrs [
23 relOrErr = mkRelationFromList attrs [
23− [StringAtom "S9", StringAtom "Perry", IntAtom 170, StringAtom "Londonderry"],
24+ [stringAtom "S9", stringAtom "Perry", intAtom 170, stringAtom "Londonderry"],
24− [StringAtom "S8", StringAtom "Mike", IntAtom 150, StringAtom "Boston"]]
25+ [stringAtom "S8", stringAtom "Mike", intAtom 150, stringAtom "Boston"]]
25 case relOrErr of
26 case relOrErr of
26 Left err -> assertFailure $ "export relation creation failure: " ++ (show err)
27 Left err -> assertFailure $ "export relation creation failure: " ++ (show err)
27 Right rel -> do
28 Right rel -> do
test/Relation/Import/CSV.hs+7−6
@@ -7,6 +7,7 @@ import qualified ProjectM36.Attribute as A
7import System.Exit
7import System.Exit
8import qualified Data.Text.Lazy as T
8import qualified Data.Text.Lazy as T
9import Data.Text.Lazy.Encoding
9import Data.Text.Lazy.Encoding
10+import ProjectM36.Atom
10
11
11main :: IO ()
12main :: IO ()
12main = do
13main = do
@@ -16,13 +17,13 @@ main = do
16testCSVSuccess :: Test
17testCSVSuccess :: Test
17testCSVSuccess = TestCase $ do
18testCSVSuccess = TestCase $ do
18 let sampleCSV = (encodeUtf8 . T.pack) "S#,CITY,STATUS,SNAME\n\"S8\",\"Boston\",150,\"Mike\"\nS9,Londonderry,170,Perry"
19 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+ expectedAttrs = A.attributesFromList [Attribute "S#" stringAtomType,
20− Attribute "SNAME" StringAtomType,
21+ Attribute "SNAME" stringAtomType,
21− Attribute "STATUS" IntAtomType,
22+ Attribute "STATUS" intAtomType,
22− Attribute "CITY" StringAtomType]
23+ Attribute "CITY" stringAtomType]
23 expectedRel = mkRelationFromList expectedAttrs [
24 expectedRel = mkRelationFromList expectedAttrs [
24− [StringAtom "S9", StringAtom "Perry", IntAtom 170, StringAtom "Londonderry"],
25+ [stringAtom "S9", stringAtom "Perry", intAtom 170, stringAtom "Londonderry"],
25− [StringAtom "S8", StringAtom "Mike", IntAtom 150, StringAtom "Boston"]]
26+ [stringAtom "S8", stringAtom "Mike", intAtom 150, stringAtom "Boston"]]
26 case csvAsRelation sampleCSV expectedAttrs of
27 case csvAsRelation sampleCSV expectedAttrs of
27 Left err -> assertFailure $ show err
28 Left err -> assertFailure $ show err
28 Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel)
29 Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel)
test/TutorialD/Interpreter.hs+61−52
@@ -11,6 +11,7 @@ import ProjectM36.Error
11import ProjectM36.Base
11import ProjectM36.Base
12import ProjectM36.TransactionGraph
12import ProjectM36.TransactionGraph
13import ProjectM36.Client
13import ProjectM36.Client
14+import ProjectM36.Atom
14import qualified ProjectM36.Attribute as A
15import qualified ProjectM36.Attribute as A
15import qualified Data.Map as M
16import qualified Data.Map as M
16import System.Exit
17import System.Exit
@@ -18,6 +19,8 @@ import Data.Maybe (isJust)
18import System.IO
19import System.IO
19import qualified Data.Vector as V
20import qualified Data.Vector as V
20import Data.Text.Encoding as TE
21import Data.Text.Encoding as TE
22+import Data.Typeable (Proxy(..))
23+import Data.Text (Text)
21
24
22--urgent: add group and ungroup tests- I missed the group relation type bug
25--urgent: add group and ungroup tests- I missed the group relation type bug
23main :: IO ()
26main :: IO ()
@@ -33,7 +36,7 @@ main = do
33 ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),
36 ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),
34 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
37 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
35 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
38 ("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])]),
37 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
40 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
38 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
41 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
39 ("x:=true where true", Right relationTrue),
42 ("x:=true where true", Right relationTrue),
@@ -45,54 +48,60 @@ main = do
45 ("x:=true=true", Right relationTrue),
48 ("x:=true=true", Right relationTrue),
46 ("x:=true=false", Right relationFalse),
49 ("x:=true=false", Right relationFalse),
47 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
50 ("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]]),
49 -- test nested relation constructor
52 -- 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]])])]),
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]])])]),
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])]),
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])]),
52− ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])]),
55+ ("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])]),
56+ ("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])]),
57+ ("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)),
58+ ("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])])
59+ ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 12])])
57 ]
60 ]
58− simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]
61+ simpleAAttributes = A.attributesFromList [Attribute "a" intAtomType]
59− simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]
62+ simpleBAttributes = A.attributesFromList [Attribute "d" intAtomType]
60− simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]
63+ simpleCAttributes = A.attributesFromList [Attribute "a" stringAtomType, Attribute "b" intAtomType]
61− simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]
64+ simpleDAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" intAtomType]
62− byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]
65+ simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Text))]
66+ simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Int))]
63− simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]
67+ simpleProjectionAttributes = A.attributesFromList [Attribute "c" intAtomType]
64− nestedRelationAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntAtomType])]
68+ 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)]
69+ extendTestAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]
70+ byteStringAttributes = A.attributesFromList [Attribute "y" byteStringAtomType]
66− groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]
71+ groupCountAttrs = A.attributesFromList [Attribute "z" intAtomType]
67− minMaxAttrs = A.attributesFromList [Attribute "S#" StringAtomType, Attribute "z" IntAtomType]
72+ minMaxAttrs = A.attributesFromList [Attribute "S#" stringAtomType, Attribute "z" intAtomType]
68 dateExampleRelTests = [("x:=S where true", Right suppliersRel),
73 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),
70 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
75 ("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"]]),
76+ ("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])])),
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])])),
73 --atom function tests
78 --atom function tests
74 ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),
79 ("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),
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),
76− ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel])])),
81+ ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [intAtom 5, Atom suppliersRel])])),
77 --relatom function tests
82 --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)])),
79 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),
84 ("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)])),
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)])),
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)])),
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)])),
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)])),
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)])),
83 --boolean function restriction
88 --boolean function restriction
84− ("x:=S where ^lt(@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"]]),
85− ("x:=S where ^gt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],
90+ ("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"]]),
91+ [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]),
87− ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),
92+ ("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"]]),
93+ ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"]]),
89 --test "all but" attribute inversion syntax
94 --test "all but" attribute inversion syntax
90 ("x:=S{all but S#} = S{CITY,SNAME,STATUS}", Right $ relationTrue),
95 ("x:=S{all but S#} = S{CITY,SNAME,STATUS}", Right $ relationTrue),
91 --test key syntax
96 --test key syntax
92 ("x:=S; key testconstraint {S#,CITY} x; insert x relation{tuple{CITY \"London\", S# \"S1\", SNAME \"gonk\", STATUS 50}}", Left (InclusionDependencyCheckError "testconstraint")),
97 ("x:=S; key testconstraint {S#,CITY} x; insert x relation{tuple{CITY \"London\", S# \"S1\", SNAME \"gonk\", STATUS 50}}", Left (InclusionDependencyCheckError "testconstraint")),
93 ("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),
98 ("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),
94 --test binary bytestring data type
99 --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)]])
96 ]
105 ]
97
106
98
107
@@ -183,24 +192,24 @@ transactionBranchTest = TestCase $ do
183simpleJoinTest :: Test
192simpleJoinTest :: Test
184simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP"
193simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP"
185 where
194 where
186− attrs = A.attributesFromList [Attribute "CITY" StringAtomType,
195+ attrs = A.attributesFromList [Attribute "CITY" stringAtomType,
187− Attribute "QTY" IntAtomType,
196+ Attribute "QTY" intAtomType,
188− Attribute "P#" StringAtomType,
197+ Attribute "P#" stringAtomType,
189− Attribute "S#" StringAtomType,
198+ Attribute "S#" stringAtomType,
190− Attribute "SNAME" StringAtomType,
199+ Attribute "SNAME" stringAtomType,
191− Attribute "STATUS" IntAtomType]
200+ Attribute "STATUS" intAtomType]
192− joinedRel = mkRelationFromList attrs [[StringAtom "London", IntAtom 100, StringAtom "P6", StringAtom "S1", StringAtom "Smith", IntAtom 20],
201+ 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],
202+ [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],
203+ [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],
204+ [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],
205+ [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],
206+ [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],
207+ [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],
208+ [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],
209+ [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],
210+ [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],
211+ [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]
212+ [stringAtom "London", intAtom 200, stringAtom "P2", stringAtom "S4", stringAtom "Clark", intAtom 20]
204 ]
213 ]
205
214
206dateExamplesConnection :: IO (Connection)
215dateExamplesConnection :: IO (Connection)
test/TutorialD/Interpreter/Import/TutorialD.hs+3−2
@@ -1,6 +1,7 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2import Test.HUnit
2import Test.HUnit
3import ProjectM36.Base
3import ProjectM36.Base
4+import ProjectM36.Atom
4import qualified ProjectM36.Attribute as A
5import qualified ProjectM36.Attribute as A
5import TutorialD.Interpreter.Import.TutorialD
6import TutorialD.Interpreter.Import.TutorialD
6import System.Exit
7import System.Exit
@@ -20,7 +21,7 @@ testTutdImport = TestCase $ do
20 withSystemTempFile "m.tutd" $ \tempPath handle -> do
21 withSystemTempFile "m.tutd" $ \tempPath handle -> do
21 hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"
22 hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"
22 hClose handle
23 hClose handle
23− let expectedExpr = MultipleExpr [Assign "x" (ExistingRelation (Relation expectedAttrs $ RelationTupleSet [RelationTuple expectedAttrs $ V.fromList [IntAtom 5, StringAtom "spam"]]))]
24+ 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]
25+ expectedAttrs = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" stringAtomType]
25 imported <- importTutorialD tempPath DC.empty
26 imported <- importTutorialD tempPath DC.empty
26 assertEqual "import tutd" (Right expectedExpr) imported
27 assertEqual "import tutd" (Right expectedExpr) imported
test/persistent-driver/test.hs+2−1
@@ -10,6 +10,7 @@
10import Test.HUnit
10import Test.HUnit
11import Database.Persist.ProjectM36
11import Database.Persist.ProjectM36
12import ProjectM36.Client
12import ProjectM36.Client
13+import ProjectM36.Atom
13import qualified ProjectM36.Client as C
14import qualified ProjectM36.Client as C
14import System.Exit
15import System.Exit
15import Database.Persist
16import Database.Persist
@@ -41,7 +42,7 @@ inProcSettings = InProcessConnectionInfo NoPersistence
41
42
42defPersonRel :: Connection -> IO ()
43defPersonRel :: Connection -> IO ()
43defPersonRel conn = do
44defPersonRel 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]))
45 case maybeErr of
46 case maybeErr of
46 Nothing -> return ()
47 Nothing -> return ()
47 Just err -> assertFailure $ "defPersonRel" ++ show err
48 Just err -> assertFailure $ "defPersonRel" ++ show err