[Haskell] Announce: Haskell ACID Relational DBMS v0.1
S. Alexander Jacobson
alex at alexjacobson.com
Tue Apr 13 19:35:25 EDT 2004
In thinking about a data storage model for a web
app I wanted to develop, and in finding Haskell so
concise and expressive, I wondered if one could
write a relational DBMS in Haskell in under 1000
lines of code. The answer appears to be yes!
Features:
* non-destructive-update Haskell DBMS (can use a
relational database without escaping to the IO
monad!)
* supports user defined types
* supports user defined relations and functions
* command pattern structure for write-ahead logging
* Inner,Outer,Left,Right joins on arbitrary
(user-defined) relations (not just "=")
* in-memory/in-process means no disk/marshalling overhead
Risks include:
* functions/aggregates not yet implemented e.g.
(a<b+c) or (a<max(b))
* no performance testing -- joins expensive!
* no proof of correctness
* written by non-academic new haskell developer
* Not SQL. No Sockets. -- should be part of the
app wrapper used to maintain consistency!
* License: GPL
Note: I am an expert neither in Haskell, nor in
relational databases, nor in
relational algebra/set theory/category theory. So
comments/suggestions/recommendations on any aspect
of this code are welcome.
Comment on Haskell: WOW!!!!!! I basically wrote
this without testing just thinking about my
program in terms of transformations between types.
I wrote the test/example code at the end and had
almost no implementation errors in the code! The
compiler/type-system is really really good at
preventing you from making coding mistakes! I've
never in my life had a block of code this big work
on the first try!!! I am WAYYY impressed. Note:
Code working means doing what I think it will do.
I might be wrong about relational theory, but that
is a separate class of problem.
-Alex-
_________________________________________________________________
S. Alexander Jacobson mailto:me at alexjacobson.com
tel:917-770-6565 http://alexjacobson.com
-------------- next part --------------
{-# 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 (<val)) $
keysFM backward
else mkSet $ keysFM_GE backward val
'>' -> if not is then mkSet (takeWhile (if relTok==">=" then (<val)
else (<=val)) $ keysFM backward)
else let keys = keysFM_GE backward val in
mkSet (if relTok==">=" || 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")]
]
More information about the Haskell
mailing list