{-# OPTIONS -fglasgow-exts #-} {-- Haskell ACID Relational Database Management System v.01 Copyright (C) 2004 S. Alexander Jacobson This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --} ------------------------------------------------------------------------- {-- Assumptions: * All data fit in memory (at least in this version!) * We want an in-process Haskell DBMS * Atomicity via app level definition of transaction (e.g. prevayler.org) * Consistency via the app wrapper around database * Isolation via haskell's referential integrity * Durability via write-ahead logging of update requests and state serialization --} --see test example at the end!! import Maybe import Data.Set import Data.FiniteMap import Data.Typeable import List hiding (union,intersect) import Control.Monad import Random --Conceptual model: --A database is a set of records (tableId is just a property of a record.) --A record is a mapping from propertyIds to propertyValues with a unique identity. type RecordSet = Set Record type Record = FiniteMap PropId PropVal newtype RecordId= RecordId String deriving (Eq,Ord) newtype PropId = PropId String deriving (Eq,Ord,Show) newtype PropVal = PropVal {propVal::String} deriving (Eq,Ord,Show) --A value has meaning only w/r/t the type of its identifier (is "2" < "100"?) data PropTypeId = PropTypeId {ptName::String,ptArgs::PropTypeArgs} deriving (Eq,Ord) type PropTypeArgs = [String] --Abstract representation of database class DBImpl db => DBInterface db where --You need to define propId types before you assign them values in records! putPropId::db -> PropId -> PropTypeId -> db getPropId::db -> PropId -> Maybe PropTypeId delPropId::db -> PropId -> db indPropId::db -> FiniteMap PropId PropTypeId --SQLish interpretation of basic interface dbInsert::db-> [Record] -> ([RecordId],db) -- 201 created location dbSelect::db -> SelectExpr -> WhereExpr -> GroupBy -> OrderBy -> [Result] dbDelete::db -> Set SetId -> WhereExpr -> db dbUpdate::db -> UpdateExpr -> SelectExpr -> WhereExpr -> GroupBy -> db --support functions (default implementation can use these) ----dbInsertRecord::db -> Record -> (RecordId,db) dbWhereExpr:: db -> WhereExpr -> Set JoinedRecordIds dbGroupBy:: db -> GroupBy -> Set JoinedRecordIds -> Set (Set JoinedRecordIds) dbSelectExpr::db -> SelectExpr -> Set (Set JoinedRecordIds) -> ResultSet dbOrderByPairs:: db -> OrderBy -> ResultSet -> [(JoinedRecordIds,Result)] dbOrderBy::db -> OrderBy -> ResultSet -> [Result] -- dbSelect=defaultDBSelect dbInsert=defaultDBInsert dbDelete=defaultDBDelete dbUpdate=defaultDBUpdate dbOrderBy=defaultDBOrderBy {-- A relational database allows declarative manipulation of sets of records based on the relation of their property values to specified constants and on the relation of their property values to those of other records. --} type JoinedRecordIds = FiniteMap SetId RecordId --recordIds related in some way newtype SetId = SetId String deriving (Eq,Ord,Show) type Result = FiniteMap SetIdPropId (Maybe PropVal) --recordid is property of record type SetIdPropId = (SetId,PropId) type ResultSet = Set (JoinedRecordIds,Result) data SelectExpr = SelectExpr (FiniteMap SetIdPropId Expr) | SelectAll data Expr = EVal PropVal | EPropId SetIdPropId -- | EFun FunId Expr -- currying assumed -- | ENull newtype FunId = FunId String data WhereExpr = QExists SetIdPropId Bool | QPair SetIdPropId Bool RelationId PropVal | QJoin JoinType SetIdPropId RelationId SetIdPropId | QAnd WhereExpr WhereExpr | QOr WhereExpr WhereExpr -- | QRecordIds {qpRecordIds::Set JoinedRecordIds} --record is part of record set -- | QPair SetIdPropId RelationId (Set PropVal) -- | QExpr e.g. propId + propId < value -- | QSubQ (PropId -> PropVal) -> (QuerySet,Prop) data JoinType = InnerJoin --both vals Just record | LeftJoin -- left val Just record | RightJoin --right val Just record | OuterJoin -- left or right is Just record deriving (Eq,Show,Read,Ord) newtype RelationId = RelationId String deriving (Eq,Ord,Read,Show) -- this is a *RELATIONAL* database type OrderBy = [SetIdPropId] type GroupBy = [SetIdPropId] --data UpdateExpr = Insert SetId | Update SelectExpr | Delete SetId data UpdateExpr = UpdateExpr {uInserts::Set SetId ,uUpdates::Set SetId ,uDeletes::Set SetId} class DBImpl db where --record level stuff dbCreateRecordId::db -> (RecordId,db) dbDelRecordId::db -> RecordId -> db dbSetRecordProp::db -> RecordId -> PropId -> PropVal -> db dbDelRecordProp::db -> RecordId -> PropId -> db defaultDBResultPairs db selectExpr whereExpr groupByExpr = dbSelectExpr db selectExpr $ dbGroupBy db groupByExpr $ dbWhereExpr db whereExpr defaultDBSelectPairs db selectExpr whereExpr groupByExpr orderBy = dbOrderByPairs db orderBy $ defaultDBResultPairs db selectExpr whereExpr groupByExpr defaultDBSelect db selectExpr whereExpr groupByExpr orderBy = dbOrderBy db orderBy $ defaultDBResultPairs db selectExpr whereExpr groupByExpr defaultDBOrderBy db orderByExpr resultSet = map snd $ dbOrderByPairs db orderByExpr resultSet defaultDBInsert db records = foldl doFold ([],db) records where doFold (recordIds,db) record = (recordId:recordIds,newdb) where (recordId,newdb) = dbInsertRecord db record dbInsertRecord db record = (recordId,foldl setRecordProp ndb (fmToList record)) where (recordId,ndb) = dbCreateRecordId db setRecordProp db' (propId,propVal) = dbSetRecordProp db' recordId propId propVal defaultDBDelete db setIds whereExpr = defaultDBDelete' db setIds $ setToList $ dbWhereExpr db whereExpr defaultDBDelete' db setIds jrecList =foldl delJRec db jrecList where delJRec db jrec= foldl (delRec jrec) db setIdList delRec jrec db setId = maybe db (dbDelRecordId db) $ lookupFM jrec setId setIdList = setToList setIds defaultDBUpdate db (UpdateExpr inserts updates deletes) selectExpr whereExpr groupByExpr = updated $ inserted $ deleted db where deleted db = if isEmptySet deletes then db else defaultDBDelete' db deletes jrecList jrecList = map fst rset rset = defaultDBSelectPairs db selectExpr whereExpr groupByExpr [] inserted db = foldl insRec db $ map snd rset insRec db result = snd $ dbInsert db records where records = map resultToRecord $ setToList inserts resultToRecord setId = foldl jPartToRec emptyFM $ onlyJust $ filterOnlySetId setId result jPartToRec fm ((setId,propId),propVal) = addToFM fm propId propVal onlyJust = map (\ (x,mbPropVal)-> (x,mayErr "updatepropval!" mbPropVal)) . filter (\ ((setId,propId),mbPropVal) -> isJust mbPropVal) filterOnlySetId setId result = (filter (onlySetId setId) $ fmToList result) onlySetId setId ((setId',propId),propVal) = setId'==setId updated db = foldl updateRec db rset updateRec db (jrec,result) = foldl updateSetId db $ setToList updates where updateSetId db setId = foldl updatePart db $ filterOnlySetId setId result updatePart db ((setId,propId),mbPropVal) = maybe (dbDelRecordProp db recId propId) (dbSetRecordProp db recId propId) mbPropVal where recId = mayErr "should have matching recordId for set!" $ lookupFM jrec setId {----------------------------------------------------------------- Implementation --} data BasicDatabase = BDB {propIdTypeId::FiniteMap PropId PropTypeId ,propTypes::FiniteMap PropTypeId PropTypeHolder ,recordIdPropIds::FiniteMap RecordId (Set PropId) ,recordIdGen::StdGen} emptyBDB = BDB emptyFM emptyFM emptyFM (mkStdGen 1000) data PropTypeHolder = forall value. PTH (PropType value) data PropType value = forall property. -- function relation value. Property property value -- function relation value => PropType PropTypeArgs (FiniteMap PropId (property value)) class IPropTypeHolder a where emptyPropType::PropTypeId -> a instance IPropTypeHolder PropTypeHolder where emptyPropType pti@(PropTypeId typename args)= case typename of --ADD TYPES HERE "String" -> PTH ((newPropType (emptyProp args::BasicProp String) args)::PropType String) "Integer" -> PTH ((newPropType (emptyProp args::BasicProp Integer) args)::PropType Integer) --"Double" -> newPropType (emptyProp args::BasicProp Double) args class IPropType ipt where insertPropIdRecordId::ipt->PropId -> RecordId -> PropVal -> ipt deletePropIdRecordId::ipt->PropId -> RecordId -> ipt getPropIdRecordIds::ipt -> PropId -> Set RecordId getPropIdValRecordIds::ipt -> PropId -> PropVal -> Set RecordId getPropIdRelVals::ipt -> PropId -> Bool -> RelationId -> PropVal -> Set PropVal getPropIdRevRelVals::ipt -> PropId -> Bool -> RelationId -> PropVal -> Set PropVal getPropIdVals::ipt -> PropId -> Set PropVal getPropIdRecordIdVal::ipt -> PropId -> RecordId -> Maybe PropVal comparePropIdRecordIds::ipt -> PropId -> RecordId -> RecordId -> Ordering instance IPropType PropTypeHolder where insertPropIdRecordId (PTH x) pid rid pv = PTH (insertPropIdRecordId x pid rid pv) deletePropIdRecordId (PTH x) pid rid = PTH (deletePropIdRecordId x pid rid) getPropIdRecordIds (PTH x) = getPropIdRecordIds x getPropIdValRecordIds (PTH x) = getPropIdValRecordIds x getPropIdRelVals (PTH x) = getPropIdRelVals x getPropIdVals (PTH x) = getPropIdVals x getPropIdRevRelVals (PTH x) = getPropIdRelVals x getPropIdRecordIdVal (PTH x) = getPropIdRecordIdVal x comparePropIdRecordIds (PTH x) = comparePropIdRecordIds x class Property prop value where newPropType::prop value -> PropTypeArgs -> PropType value insertRecordId::prop value -> RecordId -> PropVal -> prop value deleteRecordId::prop value -> RecordId -> prop value emptyProp::PropTypeArgs -> prop value -- there might be some parameters it uses getRecordIds::prop value ->Set RecordId getPropValRecordIds::prop value -> PropVal -> Set RecordId --getPropRelValRecordIds::prop value -> RelationId -> PropVal -> Set RecordId getPropRelVals::prop value -> Bool -> RelationId -> PropVal -> Set PropVal getPropRevRelVals::prop value -> Bool -> RelationId -> PropVal -> Set PropVal getPropVals::prop value -> Set PropVal getPropRecordIdVal::prop value -> RecordId -> Maybe PropVal comparePropRecordIds::prop value -> RecordId -> RecordId -> Ordering getValSets::prop value -> FiniteMap value (Set RecordId) isRelation::prop value -> RelationId -> value -> value -> Bool -- newPropType s args = PropType args (emptyFM::FiniteMap PropId (prop value)) instance IPropType (PropType val) where insertPropIdRecordId (PropType ptArgs idMap) propId recordId propVal = PropType ptArgs (addToFM idMap propId prop') where prop = maybe (emptyProp ptArgs) id $ lookupFM idMap propId prop' = insertRecordId prop recordId propVal deletePropIdRecordId (PropType ptArgs idMap) propId recordId = PropType ptArgs idMap' where prop = mayErr "!!!!no prop for id?" $ lookupFM idMap propId prop' = deleteRecordId prop recordId idMap'=addToFM idMap propId prop' getPropIdRecordIds (PropType _ idMap) propId = maybe emptySet getRecordIds $ lookupFM idMap propId getPropIdValRecordIds (PropType ptArgs idMap) propId val = getPropValRecordIds prop val where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) --getPropIdRelValRecordIds (PropType ptArgs idMap) propId relationId val = --getPropRelValRecordIds prop relationId val --where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) getPropIdRelVals (PropType ptArgs idMap) propId is relationId val = getPropRelVals prop is relationId val where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) getPropIdRevRelVals (PropType ptArgs idMap) propId is relationId val = getPropRevRelVals prop is relationId val where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) getPropIdVals (PropType ptArgs idMap) propId = getPropVals prop where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) getPropIdRecordIdVal (PropType ptArgs idMap) propId recordId = getPropRecordIdVal prop recordId where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) comparePropIdRecordIds (PropType ptArgs idMap) propId recId recId2 = comparePropRecordIds prop recId recId2 where prop= maybe (emptyProp ptArgs) id (lookupFM idMap propId) instance DBImpl BasicDatabase where dbCreateRecordId (BDB piti pt ipids gen) = (recordId, BDB piti pt ipids' gen') where (recordNum,gen')=next gen recordId=RecordId $ show recordNum ipids'=addToFM ipids recordId emptySet dbSetRecordProp db@(BDB piti pt ipids gen) recordId propId propVal = BDB piti pt' ipids' gen where --errors from propId or recordId not exist or propval parse error propTypeId = mayErr ("no propId created" ++ (show propId)) $ lookupFM piti propId propIds = mayErr "no recordId" (lookupFM ipids recordId) propType = mayErr "Should not err! has proptype!" $ lookupFM pt propTypeId propType' = insertPropIdRecordId propType propId recordId propVal pt' = addToFM pt propTypeId propType' ipids' = addToFM ipids recordId $ addToSet propIds propId dbDelRecordProp db@(BDB piti pt ipids gen) recordId propId = BDB piti pt' ipids' gen where ipids' = addToFM ipids recordId (delFromSet propIds propId) propTypeId = mayErr "no propIdDel" $ lookupFM piti propId propIds = mayErr "no recordId" $ lookupFM ipids recordId propId' = if not $ elementOf propId propIds then error "no propId for record" else propId propType = mayErr "should not err has proptype2" $ lookupFM pt propTypeId propType'= deletePropIdRecordId propType propId' recordId pt' = addToFM pt propTypeId propType' dbDelRecordId db@(BDB piti pt ipids gen) recordId = BDB piti pt' ipids' gen where propIds = maybe emptySet id $ lookupFM ipids recordId ipids'=delFromFM ipids recordId db' = foldl (\db propId-> dbDelRecordProp db recordId propId) db (setToList propIds) pt' = propTypes db' instance DBInterface BasicDatabase where putPropId (BDB piti pt ipids gen) propId pti@(PropTypeId typename args) = BDB piti' pt' ipids gen where piti'= addToFM piti propId pti pt' = if isNothing (lookupFM piti propId) then addToFM pt pti (emptyPropType pti)-- (PropType args emptyMap) else pt getPropId (BDB piti _ _ gen) propId = lookupFM piti propId delPropId (BDB piti pt ipids gen) propId = BDB piti' pt' ipids gen where piti' = (delFromFM piti propId) mbPT' = do propTypeId <- lookupFM piti propId PTH (PropType args propType) <- lookupFM pt propTypeId return $ addToFM pt propTypeId $ PTH $ PropType args (delFromFM propType propId) pt' = maybe pt id mbPT' indPropId (BDB piti _ _ _) = piti --- dbSelectExpr db selectExpr joinedSetSet = concatMapSet (\set -> mapSet evalItem set) joinedSetSet where --selectList::JoinedRecordIds->[(SetIdPropId,Expr)] selectList jrecId = fmToList $ case selectExpr of SelectExpr selectFM -> selectFM _ -> foldl addSetProps emptyFM $ fmToList jrecId where propList::RecordId -> [PropId] propList recId = maybe [] setToList (lookupFM (recordIdPropIds db) recId) --addProps::SetId -> FiniteMap SetIdPropId Expr -> PropId -> FiniteMap SetIdPropId Expr addProps setId fm propId = addToFM fm (setId,propId) (EPropId (setId,propId)) addSetProps fm (setId,recId) = foldl (addProps setId) fm $ propList recId evalItem jRecId = (jRecId,foldl (selectItem jRecId) emptyFM (selectList jRecId)) selectItem jrecId fm (leftId@(lSetId,lPropId),rightSide) = case rightSide of EVal propVal -> addToFM fm leftId (Just propVal) EPropId (rSetId,rPropId) -> addToFM fm leftId (do prop <- mbGetProp rPropId recId <- lookupFM jrecId rSetId (getPropIdRecordIdVal prop rPropId recId) ) prop fn propId = fn (getProp propId) propId getProp propId = mayErr ("haspropId!"++show propId) $ mbGetProp propId mbGetProp propId = lookupFM (propIdTypeId db) propId >>= lookupFM (propTypes db) --dbOrderBy db [] resultSet= setToList resultSet dbOrderByPairs db orderByExpr resultSet = --map snd $ sortBy (orderer orderByExpr) $ setToList resultSet where orderer [] a b = EQ orderer ((setId,propId):tail) a b = if comp==EQ then orderer tail a b else comp where mbARecId = lookupFM (fst a) setId mbBRecId = lookupFM (fst b) setId comp | isNothing mbARecId && isNothing mbBRecId = EQ | isNothing mbARecId = LT | isNothing mbBRecId = GT | otherwise = prop comparePropIdRecordIds propId (mayErr "order1" mbARecId) (mayErr "order2" mbBRecId) val fm = map (\ (setId,propId) -> fmap (prop getPropIdRecordIdVal propId) (lookupFM fm setId)) orderByExpr prop fn propId = fn (getProp propId) propId getProp propId = mayErr "order mbGetProp" $ mbGetProp propId mbGetProp propId = lookupFM (propIdTypeId db) propId >>= lookupFM (propTypes db) {-- [setidpropid of result or original? yes because we want to sort of fields that may not be apparent! ] --} dbGroupBy db [] joinedItemSet = unitSet joinedItemSet dbGroupBy db groupByExpr joinedItemSet = mkSet $ map (mkSet.map fst) $ groupBy grouper sorted where sorted = sortBy orderer $ map (\x->(x,val x)) $ setToList joinedItemSet grouper a b = snd a == snd b orderer a b = compare (snd a) (snd b) val fm = map (\ (setId,propId) -> fmap (prop getPropIdRecordIdVal propId) (lookupFM fm setId)) groupByExpr prop fn propId = fn (getProp propId) propId getProp propId = mayErr "group prop missing" $ mbGetProp propId mbGetProp propId = lookupFM (propIdTypeId db) propId >>= lookupFM (propTypes db) dbWhereExpr db q = filterRequired (impl q) where filterRequired::(Set SetId,Set InternalJRec) -> Set JoinedRecordIds filterRequired (required,jset) = filterSet hasRequired (toRecIds jset) where hasRequired::JoinedRecordIds -> Bool hasRequired fm = isJust $ sequence $ map (lookupFM fm) (setToList required) toRecIds jset = concatMapSet ijrecToSetJrec jset where ijrecToSetJrec = ijRec2ToSetJrec . ijRecToijRec2 ijRec2ToSetJrec setRecFM = toRec (tail setRecList) $ mapSet (\x->unitFM firstSetId x) $ snd $ head setRecList where setRecList = fmToList setRecFM firstSetId = fst $ head setRecList toRec [] set = set toRec ((hSetId,hSetRecIds):t) set = union (toRec t set) (concatMapSet (fmToSet hSetId hSetRecIds) set) fmToSet setId setRecIds fm = mapSet (\recId -> addToFM fm setId recId) setRecIds ijRecToijRec2 rec = foldl fmFunc emptyFM recList where recList = map getRecs $ fmToList rec getRecs::((SetId,PropId),Either Bool (Set PropVal)) -> (SetId,Set RecordId) getRecs ((setId,propId),vals) = (setId, getPropRecIds propId vals) fmFunc fm (setId,recIds)=addToFM fm setId $ maybe recIds (intersect recIds) (lookupFM fm setId) {--ijRecToijRec2 rec = mapFM pairFM2RecIdSet rec pairFM2RecIdSet _ pairFM = foldl pairIntersect emptySet (fmToList pairFM) pairIntersect s (propId,propVal) = intersect s (getPropRecIds propId propVal) --} prop fn propId = fn (getProp propId) propId getProp propId = mayErr ("PropId not yet created!"++show propId) $ mbGetProp propId mbGetProp propId = lookupFM (propIdTypeId db) propId >>= lookupFM (propTypes db) getPropRecIds propId (Left exists) = (if exists then id else minusSet (listToSet $ keysFM (recordIdPropIds db))) $ maybe emptySet (\prop-> getPropIdRecordIds prop propId) $ mbGetProp propId getPropRecIds propId (Right propVals) = concatMapSet (getPropIdValRecordIds (getProp propId) propId) propVals --impl::WhereExpr -> (Set SetId,Set InternalJRec) impl (QExists (setId,propId) exists) = (emptySet,unitSet (unitFM (setId,propId) (Left exists))) impl (QPair (setId,propId) is relationId val) = (emptySet, unitSet (unitFM (setId,propId) (Right $ getPropIdRelVals (getProp propId) propId is relationId val))) impl (QJoin joinType spLeft@(setIdLeft,propIdLeft) relationId spRight@(setIdRight,propIdRight))= (requiredSets joinType, union leftSet rightSet) where requiredSets InnerJoin = mkSet [setIdLeft,setIdRight] requiredSets LeftJoin = mkSet [setIdLeft] requiredSets RightJoin = mkSet [setIdRight] requiredSets _ = emptySet leftVals = prop getPropIdVals propIdLeft rightVals = prop getPropIdVals propIdRight leftSet = concatMapSet leftVal2Set leftVals rightSet = concatMapSet rightVal2Set rightVals leftVal2Set lval | False && isEmptySet rVals = if joinType `elem` [InnerJoin,RightJoin] then emptySet else unitSet $ mkPair (return lval) mzero | otherwise = mapSet (\rval-> mkPair (return lval) (return rval)) rVals where rVals = getRevVals propIdRight True relationId lval rightVal2Set rval | False && isEmptySet lVals = if joinType `elem` [InnerJoin,LeftJoin] then emptySet else unitSet $ mkPair mzero (return rval) | otherwise = mapSet (\lval-> mkPair (return lval) (return rval)) lVals where lVals = getVals propIdLeft True relationId rval mkPair mbLeftVal mbRightVal = plusFM (maybe emptyFM leftFM mbLeftVal) (maybe emptyFM rightFM mbRightVal) where leftFM leftVal = unitFM spLeft $ Right $ unitSet $ leftVal rightFM rightVal= unitFM spRight $ Right $ unitSet $ rightVal getRevVals propId = getPropIdRevRelVals (getProp propId) propId getVals propId = getPropIdRelVals (getProp propId) propId impl (QOr wexpr wexpr2) = (intersect leftReq rightReq,union leftSet rightSet) where (leftReq,leftSet) = impl wexpr (rightReq,rightSet) = impl wexpr2 impl (QAnd wexpr wexpr2) = (union leftReq rightReq,combine) where (leftReq,leftSet) = impl wexpr (rightReq,rightSet) = impl wexpr2 combine = concatMapSet crossSets rightSet crossSets fm = mapSet (plusFM_C addThem fm) leftSet addThem (Right x) (Right y) = Right $ intersect x y addThem (Left True) (Right y) = Right y addThem (Left False) (Right y) = Right emptySet addThem (Left False) (Left True) = Right emptySet addThem (Left False) (Left False) = Left False addThem (Left True) (Left False) = Right emptySet addThem (Left True) (Left True) = Left True addThem (Right x) (Left True) = Right x addThem (Right x) (Left False) = Right emptySet isExists (QExists _ _) = True isExists _ = False isPair (QPair _ _ _ _) = True isPair _ = False isJoin (QJoin _ _ _ _) =True isJoin _ = False isAnd (QAnd _ _) = True isAnd _ = False isOr (QOr _ _)= True isOr _ = False type RequiredSets = Set SetId type InternalJRec = FiniteMap (SetId,PropId) (Either Bool (Set PropVal)) type InternalJRec2 = FiniteMap SetId (Set RecordId) type InternalJSet = Set InternalJRec unitJoin setId = mapSet (unitFM setId) data BasicProp value = BP {bpForward::FiniteMap RecordId value ,bpBackWard::FiniteMap value (Set RecordId) } deriving (Eq,Ord) bpEmpty = BP emptyFM emptyFM newtype BPRelation = BPRelation String deriving (Read,Show,Ord,Eq) newtype BPFunction = BPFunction String deriving (Read,Show,Ord,Eq) bpDeleteRecordId bp@(BP forward backward) recordId = BP forward' backward' where forward' = delFromFM forward recordId backward' = maybe backward id $ do val <- lookupFM forward recordId oldSet <- lookupFM backward val newSet <- return $ delFromSet oldSet recordId if cardinality oldSet ==1 then return $ delFromFM backward val else return $ addToFM backward val newSet bpFromPropVal (PropVal x) | val==[] && val2==[] = (error ("Can't parse val: "++ (show $ typeOf val)++" "++(show x))) | val==[] = fst $ head val2 | otherwise = fst $ head val where val=reads x val2=reads ('\"':x++['\"']) bpToPropVal x = PropVal $ show x bpInsertRecordId bp recordId pv = BP forward' backward' where value = bpFromPropVal pv BP forward backward = bpDeleteRecordId bp recordId forward' = addToFM forward recordId value backward' = addToFM backward value (addToSet oldSet recordId) oldSet = maybe emptySet id $ lookupFM backward value bpGetPropValRecordIds bp@(BP forward backward) propVal = maybeSet $ lookupFM backward (bpFromPropVal propVal) bpGetPropVals (BP forward backward) = mkSet $ map bpToPropVal $ keysFM backward bpComparePropRecordIds (BP forward backward) recId recId2 = maybe EQ id (do val <- lookupFM forward recId val2 <- lookupFM forward recId2 return $ compare val val2) {-- bpGetPropRelValRecordIds bp@(BP forward backward) (RelationId relTok) propVal = foldl union emptySet $ case relTok of "=" -> maybe mzero return $ lookupFM backward val "<" -> map snd $ takeWhile (\ (x,y)-> x < val) (fmToList backward) "<=" -> map snd $ takeWhile (\ (x,y)-> x <= val) (fmToList backward) ">=" -> ge ">" -> (if isJust (lookupFM backward val) then tail else id) ge where val = (bpFromPropVal propVal) ge = eltsFM_GE backward val --} bpGetPropRevRelVals bp is r@(RelationId relTok) propVal = bpGetPropRelVals bp is (RelationId r2) propVal where r2 = case relTok of "=" -> "=" "<" -> ">" ">" -> "<" "<=" -> ">=" ">=" -> "<=" bpGetPropRelVals bp@(BP forward backward) is r@(RelationId relTok) propVal = mapSet bpToPropVal $ case head relTok of '=' -> if is then maybe emptySet (\_->unitSet val) $ lookupFM backward val else delFromSet (mkSet $ keysFM backward) val '<' -> if is then mkSet $ (if relTok=="<=" then takeWhile (<=val) else takeWhile (' -> if not is then mkSet (takeWhile (if relTok==">=" then (=" || null keys then keys else if head keys == val then tail keys else keys) --"<=" -> if is then bpGetPropRelVals bp (RelationId "<") propVal --is && "<" -> map snd $ takeWhile (\ (x,y)-> x < val) (fmToList backward) --"<" -> map snd $ takeWhile (\ (x,y)-> x < val) (fmToList backward) --"<=" -> map snd $ takeWhile (\ (x,y)-> x <= val) (fmToList backward) --">=" -> ge --">" -> (if isJust (lookupFM backward val) then tail else id) ge where val = bpFromPropVal propVal ge = eltsFM_GE backward val bpIsRelation (RelationId relTok) val val2 = rel val val2 where rel = case relTok of "=" -> (==) "<" -> (<) "<=" -> (<=) ">=" -> (>=) ">" -> (>) --bpUpdateRecordId bp@(BP forward backward) funId bpGetRecordIds (BP forward backward) = listToSet $ keysFM forward bpGetPropRecordIdVal (BP forward backward) recordId = fmap bpToPropVal $ lookupFM forward recordId bpGetValSets (BP forward backward) = backward --bpEnumRelations x = listToSet $ map (toRelationId x . BPRelation) -- ["<",">","=","<=",">="] --substring,etc. --is there a way of consolidating these?-- instance Property BasicProp String where emptyProp x = bpEmpty deleteRecordId = bpDeleteRecordId insertRecordId = bpInsertRecordId getRecordIds = bpGetRecordIds getPropValRecordIds = bpGetPropValRecordIds getPropRelVals = bpGetPropRelVals getPropRevRelVals = bpGetPropRevRelVals getValSets = bpGetValSets getPropVals = bpGetPropVals getPropRecordIdVal = bpGetPropRecordIdVal isRelation bp = bpIsRelation comparePropRecordIds = bpComparePropRecordIds instance Property BasicProp Integer where emptyProp x = bpEmpty deleteRecordId = bpDeleteRecordId insertRecordId = bpInsertRecordId getRecordIds = bpGetRecordIds getPropValRecordIds = bpGetPropValRecordIds getPropRelVals = bpGetPropRelVals getPropRevRelVals = bpGetPropRevRelVals getPropVals = bpGetPropVals getPropRecordIdVal = bpGetPropRecordIdVal getValSets = bpGetValSets isRelation bp = bpIsRelation comparePropRecordIds = bpComparePropRecordIds instance Property BasicProp Double where emptyProp x = bpEmpty deleteRecordId = bpDeleteRecordId insertRecordId = bpInsertRecordId getRecordIds = bpGetRecordIds getPropValRecordIds = bpGetPropValRecordIds getPropRelVals = bpGetPropRelVals getPropRevRelVals = bpGetPropRevRelVals getPropVals = bpGetPropVals getPropRecordIdVal = bpGetPropRecordIdVal getValSets = bpGetValSets isRelation bp = bpIsRelation comparePropRecordIds = bpComparePropRecordIds {-- Represent Interaction w/ DB via HTTP GET PUT POST DELETE Four levels of operations property,record,recordset,joinrecset. URL translation is: * /joins/joinId -- joinrecset operations * /sets/setId --PUT RecordQuery at Setid | RecordSet --GET /setid returns extensional set --DELETE deletes all records in the set and the set --POST modifies all records in the set --Ambiguity about deleting the set concept? --no it just another record in the database! --give location! * /records/recordId -- update an record * /records/recordId/propId * /properties/types --} -------------- --stuff that really belongs in data.Set listToSet = mkSet --foldl addToSet emptySet list filterSet f set = mkSet $ filter f $ setToList set instance (Eq x,Eq y,Ord x,Ord y) =>Ord (FiniteMap x y) where compare fm1 fm2 = compare (fmToList fm1) (fmToList fm2) instance (Eq b,Ord b) => Ord (Set b) where compare set1 set2 = compare (setToList set1) (setToList set2) concatSets sets = foldr union emptySet (setToList sets) concatMapSet f = concatSets . mapSet f ---- --utils -- mayErr msg val = maybe (error msg) id val mLookupFM fm key = maybe mzero return $ lookupFM fm key maybeSet val = maybe emptySet id val ------------------------------------- test2="f\nf" test = concatMap layout $ dbSelect inserted selectExpr whereExpr groupByExpr orderByExpr where layout fm = (foldr (\ ((SetId setId,PropId propId),value) text-> (setId++'.':propId)++": "++(maybe "" propVal value)++"\t"++text) "" $ fmToList fm)++"\n" whereExpr = QAnd (QAnd (QPair (SetId "1",PropId "id") True (RelationId ">") (PropVal "0")) (QPair (SetId "2",PropId "age") True (RelationId "<") (PropVal "60"))) (QJoin InnerJoin (SetId "1",PropId "id") (RelationId "=") (SetId "2",PropId "id")) --selectExpr = SelectAll selectExpr' = SelectExpr $ listToFM [((SetId "",PropId "name"), EPropId (SetId "",PropId "name")) ,((SetId "",PropId "food"), EPropId (SetId "",PropId "food"))] selectExpr = SelectExpr $ listToFM [((SetId "1",PropId "id"), EPropId (SetId "1",PropId "id")) ,((SetId "2",PropId "id"), EPropId (SetId "2",PropId "id")) ,((SetId "1",PropId "food"), EPropId (SetId "1",PropId "food"))] groupByExpr = [(SetId "2",PropId "id")] orderByExpr = [(SetId "1",PropId "food")] propsMade = foldl (\db (propName,typeName,typeArgs) -> putPropId db (PropId propName) (PropTypeId typeName typeArgs)) emptyDB props inserted =snd $ dbInsert propsMade $ map (listToFM . map (\ (x,y)->(PropId x,PropVal y))) records emptyDB = emptyBDB props = [("name","String",[]) ,("food","String",[]) ,("id","Integer",[]) ,("age","Integer",[])] records= [[("id","10"),("name","john doe"),("age","40")] ,[("id","20"),("name","jane doe"),("age","50")] ,[("id","30"),("name","bill fal"),("age","60")] ,[("id","10"),("food","broc")] ,[("id","10"),("food","spaggher")] ,[("id","10"),("food","pepsi")] ,[("id","20"),("food","broc2")] ,[("id","20"),("food","spaggher2")] ,[("id","20"),("food","pepsi")] ]