implementation module RelationalMapping import StdEnv, StdGeneric import StdMaybe, SQL, Text //Wrapper functions mapRead :: !ref !*cur -> (!(Maybe MappingError), !(Maybe val), !*cur) | relMap{|*|} ref & relMap{|*|} val & SQLCursor cur & bimap{|*|} cur mapRead ref cursor # (mbErr,_,_,tokens,cursor) = relMap{|*|} RelMapInit 0 (Just ref) [] [] cursor | isJust mbErr = (mbErr, Nothing, cursor) # (mbErr,mbVal,_,tokens,cursor) = relMap{|*|} RelMapRead 0 Nothing [] tokens cursor | isEmpty tokens = (mbErr, mbVal, cursor) = (mbErr, Nothing, cursor) mapCreate :: !val !*cur -> (!(Maybe MappingError), !(Maybe ref), !*cur) | relMap{|*|} ref & relMap{|*|} val & SQLCursor cur & bimap{|*|} cur mapCreate val cursor # (mbErr,_,_,tokens,cursor) = relMap{|*|} RelMapCreate 0 (Just val) [] [] cursor | isJust mbErr = (mbErr, Nothing, cursor) # (mbErr,mbRef,_,tokens,cursor) = relMap{|*|} RelMapRead 0 Nothing [] tokens cursor | isEmpty tokens = (mbErr, mbRef, cursor) = (mbErr, Nothing, cursor) mapUpdate :: !val !*cur -> (!(Maybe MappingError), !(Maybe ref), !*cur) | relMap{|*|} ref & relMap{|*|} val & SQLCursor cur & bimap{|*|} cur mapUpdate val cursor # (mbErr,_,_,tokens,cursor) = relMap{|*|} RelMapUpdate 0 (Just val) [] [] cursor | isJust mbErr = (mbErr, Nothing, cursor) # (mbErr,mbRef,_,tokens,cursor) = relMap{|*|} RelMapRead 0 Nothing [] tokens cursor | isEmpty tokens = (mbErr, mbRef, cursor) = (mbErr, Nothing, cursor) mapDelete :: !ref !*cur -> (!(Maybe MappingError), !(Maybe val), !*cur) | relMap{|*|} ref & relMap{|*|} val & SQLCursor cur & bimap{|*|} cur mapDelete ref cursor # (mbErr,_,_,tokens,cursor) = relMap{|*|} RelMapInit 0 (Just ref) [] [] cursor | isJust mbErr = (mbErr, Nothing, cursor) # (mbErr,mbVal,_,tokens,cursor) = relMap{|*|} RelMapDelete 0 Nothing [] tokens cursor | isEmpty tokens = (mbErr, mbVal, cursor) = (mbErr, Nothing, cursor) // Error toString instance toString MappingError where toString (TypeError e) = "TypeError " +++ e toString (DatabaseError e) = "DatabaseError " +++ toString e // Types used by the generic function that does the mapping // The separator used in representation type fieldnames FIELD_SEPARATOR :== "_" // Token type that is used in token lists with which reading and writing to // a database can be viewed as parsing/unparsing of a stream of tokens :: RelMapToken = RelMapValue SQLValue //Plain value, index in the stream determines to which field it is mapped | RelMapTerminator //Terminator token, indicates the end of a list of values | RelMapOverride String SQLValue //Field override. If there is such a token in the stream for a given field, //it's value is used instead of the 'normal' value in the stream // Mode type which determines what we want the generic function to do :: RelMapMode = RelMapCreate // C | RelMapRead // R | RelMapUpdate // U | RelMapDelete // D | RelMapInfo // Find info by traversing the structure of the type | RelMapInit // Reduce a value to a flat list of tokens to start reading or deleting an entry. // Information about the structure of types :: RelMapFieldInfo = { fld_table :: String //The database table in which this value is stored , fld_select :: Maybe String //The database field in which this value is stored , fld_match :: Maybe String //The database field on which can be matched to find the right database record , rec_table :: String //The database table of the key field of the parent record , rec_key :: String //The database field of the key field of the parent record , val_list :: Bool //Are dealing with one, or with a set of values , val_maybe :: Bool //Is the value optional , val_fields :: [RelMapFieldInfo]//Information about the fields if this value is a record , val_id :: Bool //Is the field an ID type or an entity record } // Some of the modes need to go in multiple passes over the data structure :: RelMapPass :== Int //The real generic magic! generic relMap t :: !RelMapMode !RelMapPass !(Maybe t) ![RelMapFieldInfo] ![RelMapToken] !*cur -> (!(Maybe MappingError), !(Maybe t), ![RelMapFieldInfo], ![RelMapToken], !*cur) | SQLCursor cur relMap{|Int|} RelMapInfo _ _ info tokens cursor = (Nothing, Nothing, [emptyInfo], tokens, cursor) relMap{|Int|} RelMapRead _ _ info [RelMapValue (SQLVInteger x):xs] cursor = (Nothing, Just x, info, xs, cursor) relMap{|Int|} RelMapInit _ (Just x) info tokens cursor = (Nothing, Nothing, info, [RelMapValue (SQLVInteger x):tokens], cursor) relMap{|Int|} RelMapCreate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVInteger x)], cursor) relMap{|Int|} RelMapUpdate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVInteger x)], cursor) relMap{|Int|} RelMapDelete _ _ info [RelMapValue (SQLVInteger x):xs] cursor = (Nothing, Just x, info, xs, cursor) relMap{|Int|} _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) relMap{|Real|} RelMapInfo _ _ info tokens cursor = (Nothing, Nothing, [emptyInfo], tokens, cursor) relMap{|Real|} RelMapRead _ _ info [RelMapValue (SQLVReal x):xs] cursor = (Nothing, Just x, info, xs, cursor) relMap{|Real|} RelMapInit _ (Just x) info tokens cursor = (Nothing, Nothing, info, [RelMapValue (SQLVReal x):tokens], cursor) relMap{|Real|} RelMapCreate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVReal x)], cursor) relMap{|Real|} RelMapUpdate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVReal x)], cursor) relMap{|Real|} RelMapDelete _ _ info [RelMapValue (SQLVReal x):xs] cursor = (Nothing, Just x, info, xs, cursor) relMap{|Real|} _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) relMap{|Bool|} RelMapInfo _ _ info tokens cursor = (Nothing, Nothing, [emptyInfo], tokens, cursor) relMap{|Bool|} RelMapRead _ _ info [RelMapValue (SQLVInteger x):xs] cursor = (Nothing, Just (x <> 0), info, xs, cursor) relMap{|Bool|} RelMapInit _ (Just x) info tokens cursor = (Nothing, Nothing, info, [RelMapValue (SQLVInteger (if x 1 0)):tokens], cursor) relMap{|Bool|} RelMapCreate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVInteger (if x 1 0))], cursor) relMap{|Bool|} RelMapUpdate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVInteger (if x 1 0))], cursor) relMap{|Bool|} RelMapDelete _ _ info [RelMapValue (SQLVInteger x):xs] cursor = (Nothing, Just (x <> 0), info, xs, cursor) relMap{|Bool|} _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) relMap{|Char|} RelMapInfo _ _ info tokens cursor = (Nothing, Nothing, [emptyInfo], tokens, cursor) relMap{|Char|} RelMapRead _ _ info [RelMapValue (SQLVChar x):xs] cursor = (Nothing, Just (hd (fromString x)), info, xs, cursor) relMap{|Char|} RelMapInit _ (Just x) info tokens cursor = (Nothing, Nothing, info, [RelMapValue (SQLVChar (toString [x])):tokens], cursor) relMap{|Char|} RelMapCreate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVChar (toString [x]))], cursor) relMap{|Char|} RelMapUpdate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVChar (toString [x]))], cursor) relMap{|Char|} RelMapDelete _ _ info [RelMapValue (SQLVChar x):xs] cursor = (Nothing, Just (hd (fromString x)), info, xs, cursor) relMap{|Char|} _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) relMap{|String|} RelMapInfo _ _ info tokens cursor = (Nothing, Nothing, [emptyInfo], tokens, cursor) relMap{|String|} RelMapRead _ _ info [RelMapValue (SQLVVarchar x):xs] cursor = (Nothing, Just x, info, xs, cursor) relMap{|String|} RelMapInit _ (Just x) info tokens cursor = (Nothing, Nothing, info, [RelMapValue (SQLVVarchar x):tokens], cursor) relMap{|String|} RelMapCreate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVVarchar x)], cursor) relMap{|String|} RelMapUpdate _ (Just x) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue (SQLVVarchar x)], cursor) relMap{|String|} RelMapDelete _ _ info [RelMapValue (SQLVVarchar x):xs] cursor = (Nothing, Just x, info, xs, cursor) relMap{|String|} _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) relMap{|UNIT|} RelMapInfo _ _ info tokens cursor = (Nothing, Nothing, [emptyInfo], tokens, cursor) relMap{|UNIT|} RelMapRead _ _ info tokens cursor = (Nothing, Just UNIT, info, tokens, cursor) relMap{|UNIT|} RelMapDelete _ _ info tokens cursor = (Nothing, Just UNIT, info, tokens, cursor) relMap{|UNIT|} _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) //Default function for EITHER relMap{|EITHER|} fl fr mode pass Nothing info tokens cursor = case fl mode pass Nothing info tokens cursor of (mbErr,Just x, ixs, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (LEFT x), ixs, xs, cursor) (mbErr,Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = case fr mode pass Nothing info tokens cursor of (mbErr,Just x, ixs, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (RIGHT x), ixs, xs, cursor) (mbErr,Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|EITHER|} fl fr mode pass (Just (LEFT x)) info tokens cursor # (mbErr,_,info,tokens,cursor) = fl mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|EITHER|} fl fr mode pass (Just (RIGHT x)) info tokens cursor # (mbErr,_,info,tokens,cursor) = fr mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special PAIR for RelMapInfo mode. Just combines the two info lists relMap{|PAIR|} fx fy RelMapInfo _ _ info tokens cursor # (mbErr,_, infox, _, cursor) = fx RelMapInfo 0 Nothing info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) # (mbErr,_, infoy, _, cursor) = fy RelMapInfo 0 Nothing info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) = (Nothing, Nothing, infox ++ infoy, tokens, cursor) //Default function for PAIR relMap{|PAIR|} fx fy mode pass Nothing info tokens cursor # (mbErr, resx, infox, tokx, cursor) = fx mode pass Nothing info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) # (mbErr, resy, infoy, toky, cursor) = fy mode pass Nothing infox tokx cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) | isJust resx && isJust resy = (Nothing, Just (PAIR (fromJust resx) (fromJust resy)), infoy, toky, cursor) = (Nothing, Nothing, infoy, toky, cursor) relMap{|PAIR|} fx fy mode pass (Just (PAIR x y)) info tokens cursor # (mbErr,_, infox, tokx, cursor) = fx mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) # (mbErr,_, infoy, toky, cursor) = fy mode pass (Just y) infox tokx cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) = (Nothing, Nothing, infoy, toky, cursor) //Special CONS for RelMapInfo mode. relMap{|CONS of d|} f RelMapInfo _ _ info tokens cursor | not (isEmpty d.gcd_fields) = (Nothing, Nothing, [{emptyInfo & val_fields = [setFldInfo desc emptyInfo \\ desc <- d.gcd_fields] , val_id = isID d.gcd_name }], tokens, cursor) | otherwise # (mbErr, _, info, _, cursor) = f RelMapInfo 0 Nothing info tokens cursor | isJust mbErr = (mbErr,Nothing,[],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special CONS for RelMapRead mode. relMap{|CONS of d|} f RelMapRead _ _ info tokens cursor | not (isEmpty d.gcd_fields) # (_,_,info,_,cursor) = f RelMapInfo 0 Nothing info tokens cursor //Extract info about the fields in the record # info = map (setRecInfo info) info //Add type info about this record # (mbErr,tokx,cursor) = readRecord info (hd tokens) cursor //Read the extra tokens for this record | isJust mbErr = (mbErr,Nothing, [],[],cursor) # tokens = tokx ++ (tl tokens) //Replace the head of the token list by the extra tokens = case f RelMapRead 0 Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), info, xs, cursor) | otherwise = case f RelMapRead 0 Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr,Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), info, xs, cursor) //Special CONS for RelMapCreate mode. relMap{|CONS of d|} f RelMapCreate pass (Just (CONS x)) info tokens cursor | not (isEmpty d.gcd_fields) && not (isID d.gcd_name) # (mbErr,_,info,_,cursor) = f RelMapInfo 0 (Just x) info [] cursor //Find type info of the individual fields | isJust mbErr = (mbErr,Nothing, [],[],cursor) # info = map (setRecInfo info) info //Add type info about this record # (overrides,tokens) = takeOverrides tokens # (mbErr,_,_,tokx1,cursor) = f RelMapCreate 1 (Just x) info [] cursor //First pass: Prepare the tokenstream | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,id,cursor) = insertRecord info tokx1 overrides cursor //Write the values in this record to the database | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,_,_,tokx2,cursor) = f RelMapCreate 2 (Just x) info (mkOverrides info id) cursor //Second pass: Recursive create for incoming pointers | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (_,tokx2) = takeOverrides tokx2 //Remove the overrides used in the second pass # tokx = mergeTokens info tokx1 tokx2 //Merge the tokens from both passes # (mbErr,cursor) = linkRecords info tokx id cursor //Add the link records | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, overrides ++ tokens ++ [id], cursor) | otherwise # (mbErr,_,_,tokens,cursor) = f RelMapCreate pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special CONS for RelMapUpdate mode. relMap{|CONS of d|} f RelMapUpdate pass (Just (CONS x)) info tokens cursor | not (isEmpty d.gcd_fields) && not (isID d.gcd_name) # (mbErr,_,info,_,cursor) = f RelMapInfo 0 (Just x) info [] cursor //Find type info of the individual fields | isJust mbErr = (mbErr,Nothing, [],[],cursor) # info = map (setRecInfo info) info //Add type info about this record # (overrides,tokens) = takeOverrides tokens # (mbErr,_,_,tokx1,cursor) = f RelMapUpdate 1 (Just x) info [] cursor //First pass: Prepare the tokenstream | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,orig,cursor) = readRecord info (hd tokx1) cursor //Read the original values | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,id,cursor) = updateOrInsertRecord info tokx1 overrides cursor //Update the values in this record in the database | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,_,_,tokx2,cursor) = f RelMapUpdate 2 (Just x) info (mkOverrides info id) cursor //Second pass: Recursive update for incoming pointers | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (_,tokx2) = takeOverrides tokx2 //Remove the overrides used in the second pass # tokx = mergeTokens info tokx1 tokx2 //Merge the tokens from both passes # (mbErr,cursor) = relinkRecords info tokx id cursor //Update, or add the link records | isJust mbErr = (mbErr,Nothing, [],[],cursor) # tokx = zipTokens info orig tokx //Zip the original values with the updated ones # (mbErr,cursor) = unlinkDirectRecords info tokx cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,_,_,_,cursor) = f RelMapUpdate 3 (Just x) info tokx cursor //Garbage collect, delete removed entities in the database | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing,Nothing, info, overrides ++ tokens ++ [id], cursor) | otherwise # (mbErr,_,_,tokens,cursor) = f RelMapUpdate pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special CONS for RelMapDelete mode. relMap{|CONS of d|} f RelMapDelete pass _ info tokens cursor | not (isEmpty d.gcd_fields) && not (isID d.gcd_name) # (mbErr,_,info,_,cursor) = f RelMapInfo 0 Nothing [] tokens cursor //Extract info about the fields in the record | isJust mbErr = (mbErr,Nothing, [],[],cursor) # info = map (setRecInfo info) info //Add type info about this record # id = hd tokens | pass == 0 //Read and delete # (mbErr,tokx,cursor) = readRecord info id cursor //Read the extra tokens for this record | isJust mbErr = (mbErr,Nothing, [],[],cursor) # tokens = tokx ++ (tl tokens) //Replace the head of the token list by the extra tokens # (mbErr,cursor) = unlinkRecords info id cursor //Unlink indirect pointed fields | isJust mbErr = (mbErr,Nothing, [],[],cursor) = case f RelMapDelete 0 Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,cursor) = deleteRecord info id cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,_,_,_,cursor) = f RelMapDelete 2 Nothing info tokens cursor //Garbage collect | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), info, xs, cursor) | pass == 1 //Only read # (mbErr,tokx,cursor) = readRecord info id cursor //Read the extra tokens for this record | isJust mbErr = (mbErr,Nothing, [],[],cursor) # tokens = tokx ++ (tl tokens) //Replace the head of the token list by the extra tokens # (mbErr,cursor) = unlinkRecords info id cursor //Unlink indirect pointed fields | isJust mbErr = (mbErr,Nothing, [],[],cursor) = case f RelMapDelete 0 Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,_,_,_,cursor) = f RelMapDelete 2 Nothing info tokens cursor //Garbage collect | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), info, xs, cursor) | pass == 2 //Garbage collection: construct and delete = case f RelMapDelete 1 Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) # (mbErr,cursor) = deleteRecord info id cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), info, xs, cursor) | otherwise = (Nothing, Nothing, info, tokens, cursor) | otherwise = case f RelMapDelete pass Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), info, xs, cursor) //Default function for CONS relMap{|CONS|} f mode pass Nothing info tokens cursor = case f mode pass Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, ixs, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (CONS x), ixs, xs, cursor) relMap{|CONS|} f mode pass (Just (CONS x)) info tokens cursor # (mbErr,_,info,tokens,cursor) = f mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special FIELD for RelMapInfo mode. relMap{|FIELD of d|} f RelMapInfo _ _ info tokens cursor = case f RelMapInfo 0 Nothing info tokens cursor of (mbErr,_, [x:xs], _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, [setFldInfo d x:xs], tokens, cursor) (mbErr,_, info, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special FIELD for RelMapInit mode. relMap{|FIELD of d|} f RelMapInit _ (Just (FIELD x)) info tokens cursor | d.gfd_index == 0 # (mbErr,_,info,tokens,cursor) = f RelMapInit 0 (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) | otherwise = (Nothing, Nothing, info, tokens, cursor) //Special FIELD for RelMapCreate mode. relMap{|FIELD|} f RelMapCreate 1 (Just (FIELD x)) [i:is] tokens cursor | store i # (mbErr,_,_,tokens,cursor) = f RelMapCreate 1 (Just x) [] tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) | otherwise = (Nothing, Nothing, is, tokens, cursor) relMap{|FIELD|} f RelMapCreate 2 (Just (FIELD x)) [i:is] tokens cursor | store i = (Nothing, Nothing, is, tokens, cursor) | otherwise # (mbErr,_,_,tokens,cursor) = f RelMapCreate 2 (Just x) [] tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) //Special FIELD for RelMapUpdate mode. relMap{|FIELD|} f RelMapUpdate 1 (Just (FIELD x)) [i:is] tokens cursor | store i # (mbErr,_,_,tokens,cursor) = f RelMapUpdate 1 (Just x) [] tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) | otherwise = (Nothing, Nothing, is, tokens, cursor) relMap{|FIELD|} f RelMapUpdate 2 (Just (FIELD x)) [i:is] tokens cursor | store i = (Nothing, Nothing, is, tokens, cursor) | otherwise # (mbErr,_,_,tokens,cursor) = f RelMapUpdate 2 (Just x) [] tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) relMap{|FIELD|} f RelMapUpdate 3 (Just (FIELD x)) [i:is] tokens cursor # (orig,tokens) = takeTokens i.val_list tokens # (new,tokens) = takeTokens i.val_list tokens | i.val_list # (mbErr,_,_,_,cursor) = f RelMapDelete 0 Nothing [] (removedTokens orig new) cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) | i.val_maybe | (isNullValue (hd new)) && (not (isNullValue (hd orig))) # (mbErr,_,_,_,cursor) = f RelMapDelete 0 Nothing [] orig cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) | otherwise = (Nothing, Nothing, is, tokens, cursor) | otherwise = (Nothing, Nothing, is, tokens, cursor) //Special FIELD for RelMapDelete mode. relMap{|FIELD of d|} f RelMapDelete 0 _ [i:is] tokens cursor | isOutPointer i = case f RelMapDelete 1 Nothing [] tokens cursor of (mbErr,Nothing,_,_,cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) (mbErr,Just x,_,xs,cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (FIELD x), is, xs, cursor) | otherwise = case f RelMapDelete 0 Nothing [] tokens cursor of (mbErr,Nothing,_,_,cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) (mbErr,Just x,_,xs,cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (FIELD x), is, xs, cursor) relMap{|FIELD of d|} f RelMapDelete pass _ [i:is] tokens cursor = case f RelMapDelete pass Nothing [] tokens cursor of (mbErr,Nothing,_,_,cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, is, tokens, cursor) (mbErr,Just x,_,xs,cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (FIELD x), is, xs, cursor) //Default function for FIELD relMap{|FIELD|} f mode pass Nothing info tokens cursor = case f mode pass Nothing info tokens cursor of (mbErr,Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr,Just x, ixs, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (FIELD x), ixs, xs, cursor) relMap{|FIELD|} f mode pass (Just (FIELD x)) info tokens cursor # (mbErr,_, info, tokens, cursor) = f mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Special OBJECT for RelMapInfo mode. relMap{|OBJECT|} f RelMapInfo pass Nothing info tokens cursor # (mbErr,_, info, _, cursor) = f RelMapInfo 0 Nothing info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Default function for OBJECT relMap{|OBJECT|} f mode pass Nothing info tokens cursor # (mbErr, res, info, tokens, cursor) = f mode pass Nothing info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) | isJust res = (Nothing, Just (OBJECT (fromJust res)), info, tokens, cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|OBJECT|} f mode pass (Just (OBJECT x)) info tokens cursor # (mbErr,_, info, tokens, cursor) = f mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Bullocks case, just because the compiler doesn't see this will never happen relMap{|OBJECT|} _ _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) //We don't use arrays in the representation types relMap{|{}|} f mode pass mb_val info tokens cursor = (Just (TypeError "Arrays are not representation types"), Nothing, info, tokens, cursor) relMap{|{!}|} f mode pass mb_val info tokens cursor = (Just (TypeError "Arrays are not representation types"), Nothing, info, tokens, cursor) //The maybe type is mapped to NULL values in the database //A NULL value maps to Nothing. A non-NULL value to a Just. relMap{|Maybe|} f RelMapRead _ _ info [RelMapValue (SQLVNull):xs] cursor = (Nothing, Just Nothing, info, xs, cursor) relMap{|Maybe|} f RelMapRead _ _ info tokens cursor = case f RelMapRead 0 Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (Just x), info, xs, cursor) relMap{|Maybe|} f RelMapInfo _ _ info tokens cursor = case f RelMapInfo 0 Nothing info tokens cursor of (mbErr,_, [x:xs], _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, [{x & val_maybe = True}:xs], tokens, cursor) (mbErr,_, info, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|Maybe|} f RelMapInit _ (Just Nothing) info tokens cursor = (Nothing, Nothing, info, [RelMapValue SQLVNull:tokens], cursor) relMap{|Maybe|} f RelMapInit _ (Just (Just x)) info tokens cursor # (mbErr, _,info, tokens, cursor) = f RelMapInit 0 (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|Maybe|} f RelMapCreate _ (Just Nothing) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue SQLVNull], cursor) relMap{|Maybe|} f RelMapCreate _ (Just (Just x)) info tokens cursor # (mbErr, _,_, tokens, cursor) = f RelMapCreate 0 (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|Maybe|} f RelMapUpdate _ (Just Nothing) info tokens cursor = (Nothing, Nothing, info, tokens ++ [RelMapValue SQLVNull], cursor) relMap{|Maybe|} f RelMapUpdate _ (Just (Just x)) info tokens cursor # (mbErr,_,_, tokens, cursor) = f RelMapUpdate 0 (Just x) info tokens cursor | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) relMap{|Maybe|} f RelMapDelete _ _ info [RelMapValue (SQLVNull):xs] cursor = (Nothing, Just Nothing, info, xs, cursor) relMap{|Maybe|} f RelMapDelete pass _ info tokens cursor = case f RelMapDelete pass Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just (Just x), info, xs, cursor) relMap{|Maybe|} f _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) //The list type is used for one-to-many and many-to-many relations //in the database. To construct a list of values, it expects the values //concatenated in the stream followed by a terminator token. relMap{|[]|} f RelMapRead _ _ info [RelMapTerminator:xs] cursor = (Nothing, Just [], info, xs, cursor) relMap{|[]|} f RelMapRead _ _ info tokens cursor = case f RelMapRead 0 Nothing info tokens cursor of (mbErr,Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr,Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = case relMap{|*->*|} f RelMapRead 0 Nothing info xs cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just y, _, ys, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just [x:y], info, ys, cursor) //Info case sets the list flag to true relMap{|[]|} f RelMapInfo _ _ info tokens cursor = case f RelMapInfo 0 Nothing info tokens cursor of (mbErr, _, [x:xs], _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, [{x & val_list = True}:xs], tokens, cursor) (mbErr, _, info, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) //Create case does create for each member of the list and adds a terminator token //to the token stream. relMap{|[]|} f RelMapCreate _ (Just list) info tokens cursor # (mbErr, tokens, cursor) = doList list tokens cursor = (mbErr, Nothing, info, tokens, cursor) where doList [] tokens cursor = (Nothing, tokens ++ [RelMapTerminator], cursor) doList [x:xs] tokens cursor # (mbErr, _, _, tokx, cursor) = f RelMapCreate 0 (Just x) [] tokens cursor | isJust mbErr = (mbErr,[],cursor) = doList xs tokx cursor //Update case relMap{|[]|} f RelMapUpdate _ (Just list) info tokens cursor # (mbErr, tokens, cursor) = doList list tokens cursor = (mbErr, Nothing, info, tokens, cursor) where doList [] tokens cursor = (Nothing, tokens ++ [RelMapTerminator], cursor) doList [x:xs] tokens cursor # (mbErr, _, _, tokx, cursor) = f RelMapUpdate 0 (Just x) [] tokens cursor | isJust mbErr = (mbErr,[],cursor) = doList xs tokx cursor //Delete case relMap{|[]|} f RelMapDelete _ _ info [RelMapTerminator:xs] cursor = (Nothing, Just [], info, xs, cursor) relMap{|[]|} f RelMapDelete pass _ info tokens cursor = case f RelMapDelete pass Nothing info tokens cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just x, _, xs, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = case relMap{|*->*|} f RelMapDelete pass Nothing info xs cursor of (mbErr, Nothing, _, _, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Nothing, info, tokens, cursor) (mbErr, Just y, _, ys, cursor) | isJust mbErr = (mbErr,Nothing, [],[],cursor) = (Nothing, Just [x:y], info, ys, cursor) //Default function for lists relMap{|[]|} f mode pass (Just list) info tokens cursor # (mbErr, tokens, cursor) = doList mode pass list tokens cursor = (mbErr, Nothing, info, tokens, cursor) where doList mode pass [] tokens cursor = (Nothing, [RelMapTerminator], cursor) doList mode pass [x:xs] tokens cursor # (mbErr, _,info, tokx, cursor) = f mode pass (Just x) info tokens cursor | isJust mbErr = (mbErr, [], cursor) # (mbErr, tokxs, cursor) = doList mode pass xs tokens cursor = (mbErr, tokx ++ tokxs, cursor) relMap{|[]|} f _ _ _ info tokens cursor = (Nothing, Nothing, info, tokens, cursor) // --- Helper functions for RelMapInfo mode --- // //Creates a default info record emptyInfo :: RelMapFieldInfo emptyInfo = {fld_table = undef, fld_select = Nothing, fld_match = Nothing, rec_table = undef, rec_key = undef, val_list = False, val_maybe = False, val_fields = [], val_id = False} //Sets the information that is encoded in the field name in an info record setFldInfo :: !GenericFieldDescriptor !RelMapFieldInfo -> RelMapFieldInfo setFldInfo desc info # parts = split FIELD_SEPARATOR desc.gfd_name //Determine the table # table = hd parts # parts = tl parts //Determine the select columns # select = takeWhile ((<>) "ofwhich") parts //Collect all elements before "ofwhich" # select = if (isEmpty select) Nothing (Just (hd select)) # match = (dropWhile ((<>) "ofwhich") parts) //Collect all elements after and including "ofwhich" # match = if (isEmpty match) match (tl match) //Strip the "ofwhich" element from the select list # match = if (isEmpty match) Nothing (Just (hd match)) = {info & fld_table = table, fld_select = select, fld_match = match} //Copies the table and key from the first field in a set to the info record setRecInfo :: ![RelMapFieldInfo] !RelMapFieldInfo -> RelMapFieldInfo setRecInfo fields info = {info & rec_table = getTable fields, rec_key = getKey fields} // --- Helper functions for RelMapRead mode --- // readRecord :: [RelMapFieldInfo] RelMapToken !*cur -> (Maybe MappingError, [RelMapToken], *cur) | SQLCursor cur readRecord [] id cursor = (Nothing, [], cursor) readRecord [i:is] id cursor # (mbErr, cursor) = execute (mkSelectQuery i) [fromValue id] cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), [], cursor) # (mbErr, rows, cursor) = fetchAll cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), [], cursor) # tokx = map RelMapValue (flatten rows) # (mbErr,tokxs,cursor) = readRecord is id cursor | isJust mbErr = (mbErr, [], cursor) | i.val_list = (Nothing, tokx ++ [RelMapTerminator] ++ tokxs, cursor) = (Nothing, tokx ++ tokxs, cursor) // --- Helper functions for RelMapCreate mode --- // insertRecord :: [RelMapFieldInfo] [RelMapToken] [RelMapToken] *cur -> (Maybe MappingError, RelMapToken,*cur) | SQLCursor cur insertRecord info values overrides cursor # info = filter store info # stmt = mkInsertQuery info # values = appOverrides info values overrides # keyval = hd values # (mbErr,cursor) = execute stmt (map fromValue values) cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), keyval, cursor) | isZeroValue keyval # (mbErr, idval, cursor) = fetchIDToken cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), keyval, cursor) = (Nothing, idval, cursor) | otherwise = (Nothing, keyval, cursor) //Checks the link records and adds new links where necessary linkRecords :: [RelMapFieldInfo] [RelMapToken] RelMapToken !*cur -> (Maybe MappingError, *cur ) | SQLCursor cur linkRecords [] tokens id cursor = (Nothing, cursor) linkRecords [i:is] tokens id cursor # (values,tokens) = takeTokens i.val_list tokens | isIndirect i # (mbErr, cursor) = linkRecord i (map fromValue (init values)) (fromValue id) cursor | isJust mbErr = (mbErr, cursor) = linkRecords is tokens id cursor | otherwise = linkRecords is tokens id cursor where linkRecord info [] id cursor = (Nothing, cursor) linkRecord info [x:xs] id cursor # (mbErr, cursor) = execute (mkLinkQuery info) [x,id] cursor //Create the link | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) = linkRecord info xs id cursor // --- Helper functions for RelMapUpdate mode --- // updateOrInsertRecord :: [RelMapFieldInfo] [RelMapToken] [RelMapToken] *cur -> (Maybe MappingError, RelMapToken, *cur) | SQLCursor cur updateOrInsertRecord info values overrides cursor # (mbErr,upd,id,cursor) = updateRecord info values overrides cursor | isJust mbErr = (mbErr,id,cursor) | upd = (Nothing,id,cursor) | otherwise = insertRecord info values overrides cursor updateRecord :: [RelMapFieldInfo] [RelMapToken] [RelMapToken] *cur -> (Maybe MappingError, Bool, RelMapToken, *cur) | SQLCursor cur updateRecord info values overrides cursor # info = filter store info # stmt = mkUpdateQuery info # values = appOverrides info values overrides # idval = hd values # (mbErr,cursor) = execute stmt (map fromValue (values ++ [hd values]) ) cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)),False, idval, cursor) # (mbErr,updated,cursor) = numRows cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)),False, idval, cursor) | updated == 0 = (Nothing, False, idval, cursor) = (Nothing, True, idval, cursor) //Checks the link records and adds new links where necessary relinkRecords :: [RelMapFieldInfo] [RelMapToken] RelMapToken !*cur -> (Maybe MappingError, *cur) | SQLCursor cur relinkRecords [] tokens id cursor = (Nothing, cursor) relinkRecords [i:is] tokens id cursor # (values,tokens) = takeTokens i.val_list tokens | isIndirect i # (mbErr, cursor) = relinkRecord i (map fromValue (init values)) (fromValue id) cursor | isJust mbErr = (mbErr, cursor) # (mbErr, cursor) = cleanlinkRecord i (map fromValue (init values)) (fromValue id) cursor | isJust mbErr = (mbErr, cursor) = relinkRecords is tokens id cursor | otherwise = relinkRecords is tokens id cursor where relinkRecord info [] id cursor = (Nothing, cursor) relinkRecord info [x:xs] id cursor # (mbErr, cursor) = execute (mkCheckLinkQuery info) [x,id] cursor //Check if the link already exists | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) # (mbErr, num, cursor) = numRows cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) | num > 0 = relinkRecord info xs id cursor | otherwise # (mbErr, cursor) = execute (mkLinkQuery info) [x,id] cursor //Create the link | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) = relinkRecord info xs id cursor cleanlinkRecord info values id cursor # (mbErr, cursor) = execute (mkCleanLinkQuery info values) [id:values] cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) = (Nothing, cursor) unlinkDirectRecords :: [RelMapFieldInfo] [RelMapToken] !*cur -> (Maybe MappingError, *cur) | SQLCursor cur unlinkDirectRecords [] tokens cursor = (Nothing, cursor) unlinkDirectRecords [i:is] tokens cursor # (orig,tokens) = takeTokens i.val_list tokens # (new,tokens) = takeTokens i.val_list tokens | isDirect i && i.val_id = case (map fromValue (init (removedTokens orig new))) of [] = unlinkDirectRecords is tokens cursor values # (mbErr, cursor) = execute (mkUnlinkDirectQuery i values) values cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) = unlinkDirectRecords is tokens cursor | otherwise = unlinkDirectRecords is tokens cursor // --- Helper functions for RelMapDelete mode --- // deleteRecord :: [RelMapFieldInfo] RelMapToken !*cur -> (Maybe MappingError, *cur ) | SQLCursor cur deleteRecord info id cursor # (mbErr,cursor) = execute (mkDeleteQuery (hd info)) [fromValue id] cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)),cursor) = (Nothing, cursor) unlinkRecords :: [RelMapFieldInfo] RelMapToken !*cur -> (Maybe MappingError, *cur) | SQLCursor cur unlinkRecords [] id cursor = (Nothing, cursor) unlinkRecords [i:is] id cursor | isIndirect i # (mbErr,cursor) = execute (mkUnlinkQuery i) [fromValue id] cursor | isJust mbErr = (Just (DatabaseError (fromJust mbErr)), cursor) = unlinkRecords is id cursor | otherwise = unlinkRecords is id cursor // --- Predicates about fields --- // //Checks if a record field's value should be stored now, or if it's //values are stored in a different database record. store :: RelMapFieldInfo -> Bool store info =: { fld_table, fld_select, rec_table} = (isJust fld_select) && (fld_table == rec_table) //Checks if a field which is used for an incoming pointer/relation is direct, or uses a separate link table. isDirect :: RelMapFieldInfo -> Bool isDirect info =: {fld_table, val_fields} | isEmpty val_fields = True | getTable val_fields == fld_table = True = False //Checks if a field is an indirect link isIndirect :: RelMapFieldInfo -> Bool isIndirect info =: { fld_select, fld_match} = (isJust fld_select) && (isJust fld_match) //Checks if a field is an outgoing pointer isOutPointer :: RelMapFieldInfo -> Bool isOutPointer info =: {fld_table, fld_select, rec_table, val_fields} = (fld_table == rec_table) && (isJust fld_select) && (not (isEmpty val_fields)) // --- SQL generation functions --- // mkSelectQuery :: !RelMapFieldInfo -> String mkSelectQuery info # select = if (isNothing info.fld_select) (getKey info.val_fields) (fromJust info.fld_select) # match = if (isNothing info.fld_match) info.rec_key (fromJust info.fld_match) = "SELECT " +++ select +++ " FROM " +++ info.fld_table +++ " WHERE " +++ match +++ " = ?" mkInsertQuery :: ![RelMapFieldInfo] -> String mkInsertQuery info # table = (hd info).fld_table # (fields,values) = unzip [(fromJust i.fld_select,"?") \\ i <- info] = "INSERT INTO " +++ table +++ " (" +++ (join "," fields) +++ ") VALUES (" +++ (join "," values) +++ ")" mkUpdateQuery :: ![RelMapFieldInfo] -> String mkUpdateQuery infos = "UPDATE " +++ table +++ " SET " +++ (join "," fields) +++ "WHERE " +++ match +++ " = ?" where table = (hd infos).fld_table match = fromJust (hd infos).fld_select fields = [(fromJust info.fld_select) +++ " = ? " \\ info <- infos] mkDeleteQuery :: !RelMapFieldInfo -> String mkDeleteQuery info = "DELETE FROM " +++ info.fld_table +++ " WHERE " +++ (fromJust info.fld_select) +++ " = ?" mkLinkQuery :: !RelMapFieldInfo -> String mkLinkQuery info = "INSERT INTO " +++ info.fld_table +++ " (" +++ (fromJust info.fld_select) +++ "," +++ (fromJust info.fld_match) +++ ") VALUES (?,?)" mkUnlinkQuery :: !RelMapFieldInfo -> String mkUnlinkQuery info = "DELETE FROM " +++ info.fld_table +++ " WHERE " +++ (fromJust info.fld_match) +++ " = ?" mkCheckLinkQuery :: !RelMapFieldInfo -> String mkCheckLinkQuery info = "SELECT 0 FROM " +++ info.fld_table +++ " WHERE ( " +++ (fromJust info.fld_select) +++ " = ? ) AND ( " +++ (fromJust info.fld_match) +++ " = ? )" mkCleanLinkQuery :: !RelMapFieldInfo ![SQLValue] -> String mkCleanLinkQuery info [] = "DELETE FROM " +++ info.fld_table +++ " WHERE " +++ (fromJust info.fld_match) +++ " = ?" mkCleanLinkQuery info values = "DELETE FROM " +++ info.fld_table +++ " WHERE " +++ (fromJust info.fld_match) +++ " = ? AND NOT ( " +++ (fromJust info.fld_select) +++ " IN ( " +++ fields +++ " ))" where fields = join "," ["?" \\ v <- values] mkUnlinkDirectQuery :: !RelMapFieldInfo ![SQLValue] -> SQLStatement mkUnlinkDirectQuery info values = "UPDATE " +++ info.fld_table +++ " SET " +++ (fromJust info.fld_match) +++ " = NULL WHERE " +++ (getKey info.val_fields) +++ " IN (" +++ fields +++ ")" where fields = join "," ["?" \\ v <- values] // --- Functions which manipulate token lists --- // //Merges the result token lists of two passes mergeTokens :: [RelMapFieldInfo] [RelMapToken] [RelMapToken] -> [RelMapToken] mergeTokens [] pass1 pass2 = [] mergeTokens [i:is] pass1 pass2 | store i = x ++ (mergeTokens is xs pass2) with (x,xs) = (takeTokens i.val_list pass1) | otherwise = x ++ (mergeTokens is pass1 xs) with (x,xs) = (takeTokens i.val_list pass2) //Zips two token lists on a per field basis zipTokens :: [RelMapFieldInfo] [RelMapToken] [RelMapToken] -> [RelMapToken] zipTokens [] tokx toky = [] zipTokens [i:is] tokx toky = x ++ y ++ (zipTokens is xs ys) where (x,xs) = takeTokens i.val_list tokx (y,ys) = takeTokens i.val_list toky //Takes all the tokens for one field from the list, the Bool indicates if we need to take a list or a single value takeTokens :: Bool [RelMapToken] -> ([RelMapToken],[RelMapToken]) takeTokens False [] = ([],[]) takeTokens False tokens = ([hd tokens],tl tokens) takeTokens True [] = ([],[]) takeTokens True [RelMapTerminator:xs] = ([RelMapTerminator],xs) takeTokens True [x:xs] = ([x:y],ys) where (y,ys) = takeTokens True xs //Finds the tokens from the first list that are not present in the second removedTokens :: [RelMapToken] [RelMapToken] -> [RelMapToken] removedTokens orig new = [x \\ x <- init orig | not (isMember x (init new))] ++ [RelMapTerminator] // --- Functions to piggyback overrides at the front of the tokenlist --- // //Create the override tokens mkOverrides :: [RelMapFieldInfo] RelMapToken -> [RelMapToken] mkOverrides [] id = [] mkOverrides [i:is] id | isNothing i.fld_select = [RelMapOverride (i.fld_table +++ "_" +++ (fromJust i.fld_match)) (fromValue id): mkOverrides is id] = mkOverrides is id //Remove the overrides from the front of the token list takeOverrides :: [RelMapToken] -> ([RelMapToken],[RelMapToken]) takeOverrides tokens = (takeWhile isOverride tokens, dropWhile isOverride tokens) where isOverride (RelMapOverride f o) = True isOverride _ = False //Apply the overrides on a list of tokens appOverrides :: [RelMapFieldInfo] [RelMapToken] [RelMapToken] -> [RelMapToken] appOverrides info values overrides = [appOverride i v overrides \\ (i,v) <- (zip (info,values))] where appOverride i v [] = v appOverride i v [x:xs] | (isNothing i.fld_select) = v | otherwise = case x of (RelMapOverride f o) = if ( f == (i.fld_table +++ "_" +++ (fromJust i.fld_select))) (RelMapValue o) v _ = v // --- General helper functions --- // instance == RelMapToken where (==) (RelMapValue x) (RelMapValue y) = x == y (==) (RelMapTerminator) (RelMapTerminator) = True (==) (RelMapOverride xs xv) (RelMapOverride ys yv) = xs == ys && xv == yv (==) _ _ = False //Tests if a given record is an ID (or an object) isID :: String -> Bool isID s = (s % ((size s) - 2, size s)) == "ID" //Tests if a token is a value isValue :: RelMapToken -> Bool isValue (RelMapValue x) = True isValue _ = False //Tests if a token is a value and is zero isZeroValue :: RelMapToken -> Bool isZeroValue (RelMapValue (SQLVInteger x)) = x == 0 isZeroValue _ = False //Tests if a token is null value isNullValue :: RelMapToken -> Bool isNullValue (RelMapValue SQLVNull) = True isNullValue _ = False fromValue :: RelMapToken -> SQLValue fromValue (RelMapValue x) = x fromValue _ = SQLVNull getValues :: [RelMapToken] -> [SQLValue] getValues tokens = map fromValue (takeWhile isValue tokens) getKey :: [RelMapFieldInfo] -> String getKey fields = fromJust (hd fields).fld_select getTable :: [RelMapFieldInfo] -> String getTable fields = (hd fields).fld_table fetchIDToken :: *cur -> (Maybe SQLError, RelMapToken, *cur) | SQLCursor cur fetchIDToken cursor # (err, val, cursor) = insertId cursor = (err, RelMapValue (SQLVInteger val), cursor) //--- debug functions --// instance toString RelMapToken where toString (RelMapValue v) = "RelMapValue " +++ (toString v) toString (RelMapTerminator) = "RelMapTerminator" toString (RelMapOverride f v) = "RelMapOverride " +++ f +++ " " +++ (toString v) tokenString :: [RelMapToken] -> String tokenString [] = "" tokenString [x] = toString x tokenString [x:xs] = toString x +++ ", " +++ tokenString xs