------------------------------------------------------------------------------
--- This module generates the Curry code for all database operations
--- from an already transformed ERD term.
---
--- @author Michael Hanus, Marion Mueller
--- @version February 2015
------------------------------------------------------------------------------

module CodeGeneration(Option,Storage(..),ConsistencyTest(..),
                      isSQLite,erd2code) where

import AbstractCurry.Types
import AbstractCurry.Build
import Database.ERD
import Database.ERDGoodies
import List
import Char
import FiniteMap
import Maybe

type Option          = (Storage, ConsistencyTest)
data Storage         = Files DBPath | SQLite DBPath | DB
type DBPath          = String
data ConsistencyTest = WithConsistencyTest | WithoutConsistencyTest

-- Should SQLite interface be generated?
isSQLite :: Option -> Bool
isSQLite (storage,_) =
  case storage of SQLite _ -> True
                  _        -> False

-- The name of the KeyDatabase module:
keyDatabaseMod :: String
keyDatabaseMod = "KeyDatabase"

erd2code :: Option -> ERD -> CurryProg
erd2code opt@(_, consistencyTest) (ERD n es rs) =
  let imports = "ERDGeneric"  
              : keyDatabaseMod
              : fmSortBy (<) (concatMap getImports es)
      entities = filter (not . isGenerated) es
      generatedEntities = filter isGenerated es
  in
  CurryProg n
            imports
            (concatMap (entity2datatype opt n) entities 
             ++ map (entity2datatypeKey opt n) entities
             ++ concatMap (generatedEntity2datatype opt n) generatedEntities)
            (generateStorageDefinition opt n
             ++ concatMap (entity2trans opt n) entities
             ++ concatMap (generatedEntity2trans opt n) generatedEntities 
             ++ concatMap (entity2selmod opt n) es
             ++ concatMap (entity2DBcode opt n entities es rs) entities
             ++ concatMap (generatedEntity2DBcode opt n rs) generatedEntities
             ++ concatMap (rel2code opt n es) rs
             ++ (case consistencyTest of
                  WithConsistencyTest -> 
                    [checkAll n es]
                       ++ (map (\e -> checkEntity n e) es)
                       ++ (map (\e -> checkEntry n e es rs) es)
                  WithoutConsistencyTest -> [])
             ++ [saveAll    n entities generatedEntities,
                 restoreAll n entities generatedEntities])
            []


generateStorageDefinition :: Option -> String -> [CFuncDecl]
generateStorageDefinition (storage, _) n = case storage of
  SQLite dbpath -> [dbFileDef dbpath]
  _             -> []
 where
  dbFileDef path =
   cfunc (n,"dbFile") 0 Private stringType
         [simpleRule [] (string2ac (path ++ "/" ++ n ++ ".db"))]
    
generatedEntity2DBcode :: Option -> String -> [Relationship] -> Entity
                       -> [CFuncDecl]
generatedEntity2DBcode (storage, _) name allrels
                       (Entity en attrs@[Attribute a1 (KeyDom d1) _ _, 
                                         Attribute a2 (KeyDom d2) _ _]) =
  let enrels = relationshipsForEntityName en allrels
      d1rels = relationshipsForEntityName d1 enrels
      d2rels = relationshipsForEntityName d2 enrels
      e = lowerFirst en
  in
  (case storage of Files dbpath  -> [predEntry (name,en) Private dbpath]
                   SQLite dbpath -> [predEntrySQLite (name,en) attrs
                                                     Private dbpath]
                   DB            -> [predEntry1 (name,en) Private,
                                     entitySpec (name,en) attrs Private] ) ++
  [cfunc (name, e++a1) 1 Public
         ((baseType (name,en)) ~> entityKeyType (name,d1))
         [simpleRule [CPComb (name, en) [x, nix]]
                     (applyF (name, d1++"Key") [cvar "x"])],
   cfunc (name, e++a2) 1 Public
         ((baseType (name,en)) ~> entityKeyType (name,d2))
         [simpleRule [CPComb (name, en) [nix, x]]
                     (applyF (name, d2++"Key") [cvar "x"])],
   cmtfunc
     ("Dynamic predicate representing the "++en++" relation between "++
      d1++" entities and "++d2++" entities")
     (name, e) 2 Public
     ((baseType (name, d1++"Key")) ~> entityKeyType (name,d2) 
                                 ~> (baseType (db "Dynamic")))
     [simpleRule [CPComb (name, d1++"Key") [cpvar "key1"], 
                  CPComb (name, d2++"Key") [cpvar "key2"]]
                 (applyF (name,e++"Entry")
                         [constF (pre "unknown"),
                          tupleExpr [cvar "key1", cvar "key2"]])],
   let d1maxrelsA = filter (isRelWithRangeForEntityA isFiniteRange d1) d1rels
       d1maxrelsB = filter (isRelWithRangeForEntityB isFiniteRange d1) d1rels
       d2maxrelsA = filter (isRelWithRangeForEntityA isFiniteRange d2) d2rels
       d2maxrelsB = filter (isRelWithRangeForEntityB isFiniteRange d2) d2rels
       -- integrity test for maximum checking:
       maxtests = map (relToMaxTestA "key1") d1maxrelsA
                  ++ map (relToMaxTestB "key1") d1maxrelsB
                  ++ map (relToMaxTestA "key2") d2maxrelsA
                  ++ map (relToMaxTestB "key2") d2maxrelsB
       newEntryCall = applyF (erdgen "newEntryR")
                        [constF (name,e++"Entry"),
                         applyF (name,lowerFirst d1++"KeyToKey") [cvar "key1"],
                         applyF (name,lowerFirst d2++"KeyToKey") [cvar "key2"]]
   in
   cmtfunc
     ("Inserts a new "++en++" relation between a "++d1++" entity and a "++
      d2++" entity")
     (name, "new"++en) 2 Public
     ((baseType (name, d1++"Key")) ~> (baseType (name, d2++"Key")) 
                                   ~> transactType)
     [simpleRule [cpvar "key1", cpvar "key2"]
              (seqTrans
                  ([existsDBKeyCall (name,d1) (Just (cvar "key1")),
                    existsDBKeyCall (name,d2) (Just (cvar "key2")),
                    applyF (erdgen "unique2")
                      [CSymbol (name, e++"Entry"),
                       applyF (name,lowerFirst d1++"KeyToKey") [cvar "key1"],
                       applyF (name,lowerFirst d2++"KeyToKey") [cvar "key2"]]] ++
                    maxtests ++ [newEntryCall]))],
   let d1minrelsA = filter (isRelWithRangeForEntityA isMinRange d1) d1rels
       d1minrelsB = filter (isRelWithRangeForEntityB isMinRange d1) d1rels
       d2minrelsA = filter (isRelWithRangeForEntityA isMinRange d2) d2rels
       d2minrelsB = filter (isRelWithRangeForEntityB isMinRange d2) d2rels
       -- integrity test for minimum checking:
       mintests = map (relToMinTestA "key1") d1minrelsA
                  ++ map (relToMinTestB "key1") d1minrelsB
                  ++ map (relToMinTestA "key2") d2minrelsA
                  ++ map (relToMinTestB "key2") d2minrelsB
       deleteCall = applyF (erdgen "deleteEntryR")
                      [constF (name,e++"Entry"),
                       applyF (name,lowerFirst d1++"KeyToKey") [cvar "key1"],
                       applyF (name,lowerFirst d2++"KeyToKey") [cvar "key2"]]
   in
   cmtfunc
     ("Deletes an existing "++en++" relation between a "++d1++" entity and a "++
      d2++" entity")
     (name, "delete"++en) 2 Public
     ((baseType (name, d1++"Key")) ~> (baseType (name, d2++"Key")) 
                                   ~> transactType)
     [simpleRule [cpvar "key1", cpvar "key2"]
                 (foldr (\a b -> applyF (db "|>>") [a,b]) deleteCall
                        mintests)],
   cmtfunc
     ("Gets the associated "++d1++" entities for a given "++d2++" entity")
     (name, "get"++d1++d2++"s") 2 Public
     (baseType (name,d1) ~> CTCons transTC [listType (baseType (name,d2))])
     [simpleRule [cpvar "e"]
         (CLetDecl
             [CLocalPat (cpvar "ekey")
                (CSimpleRhs (applyF (name,lowerFirst d1++"Key") [cvar "e"]) [])]
             (applyF (db "|>>=")
               [applyF (db "getDB")
                 [applyF (name,"queryCond"++en)
                   [CLambda [cpvar "t"]
                     (applyF (pre "==")
                       [applyF (name,e++d1++en++"Key") [cvar "t"],
                        cvar "ekey"])]],
                applyF (pre ".")
                 [applyF (db "mapT") [constF (name,"get"++d2)],
                  applyF (pre "map") [constF (name,e++d2++en++"Key")]]]
             )
         )]  ] ++
   queryGeneratedEntity (name,en) Public
 where
  relToMaxTestA :: String -> Relationship -> CExpr
  relToMaxTestA vname (Relationship _ [REnd e1 _ _, REnd e2 _ c2]) =
    relToMinMaxTest "maxTestInsert"
                    vname (cardMaximum c2) (combineIds [e1,e2,"Key"]) e2      

  relToMaxTestB :: String -> Relationship -> CExpr
  relToMaxTestB vname (Relationship _ [REnd e1 _ c1, REnd e2 _ _]) =
    relToMinMaxTest "maxTestInsert"
                    vname (cardMaximum c1) (combineIds [e2,e1,"Key"]) e1  

  relToMinTestA :: String -> Relationship -> CExpr
  relToMinTestA vname (Relationship _ [REnd e1 _ _, REnd e2 _ c2]) =
    relToMinMaxTest "minTestDelete"
                    vname (cardMinimum c2) (combineIds [e1,e2,"Key"]) e2      

  relToMinTestB :: String -> Relationship -> CExpr
  relToMinTestB vname (Relationship _ [REnd e1 _ c1, REnd e2 _ _]) =
    relToMinMaxTest "minTestDelete"
                    vname (cardMinimum c1) (combineIds [e2,e1,"Key"]) e1  

  relToMinMaxTest :: String -> String -> Int -> String -> String -> CExpr
  relToMinMaxTest testname vname m attrName rName =
    let rname = lowerFirst rName in
    applyF (erdgen testname)
           [string2ac rName,
            CSymbol (name,rname++"Entry"),
            CSymbol (name,"keytuple2"++rName),
            CSymbol (name,rname++attrName),
            CLit (CIntc m),
            cvar vname]

-- Generate code for querying relationship entities
queryGeneratedEntity :: QName -> CVisibility -> [CFuncDecl]
queryGeneratedEntity (s,eName) v =
  let e = lowerFirst eName
  in
  [cmtfunc
    ("Gets all "++eName++" relationship entities stored in the database.")
    (s,"queryAll"++eName++"s") 0 v
    (CTCons (db "Query") [CTCons (pre "[]") [baseType (s,eName)]])
    [simpleRule []
             (applyF (db "transformQ")
                     [applyF (pre "map")
                       [applyF (pre "uncurry")
                           [CSymbol (s,"keytuple2"++eName)]],
                      applyF (db "allDBKeyInfos") [CSymbol (s,e++"Entry")]])],
   cmtfunc
    ("Gets all "++eName++" relationship entities satisfying a given condition.")
    (s,"queryCond" ++ eName) 1 v
    ((baseType (s,eName) ~> boolType)
     ~> CTCons (db "Query") [listType (baseType (s,eName))])
    [simpleRule [cpvar "econd"]
                (applyF (db "transformQ")
                        [applyF (pre "filter") [cvar "econd"],
                         constF (s,"queryAll"++eName++"s")])]]


getImports :: Entity -> [String]
getImports (Entity _ attrs) = getImportsAttrs attrs
  where
   getImportsAttrs :: [Attribute] -> [String]
   getImportsAttrs [] = []
   getImportsAttrs ((Attribute _ t _ _) : ats) =
     case t of UserDefined s _ -> takeWhile (/= '.') s : getImportsAttrs ats
               DateDom _       -> "Time" : getImportsAttrs ats
               _               -> getImportsAttrs ats

-- Create data type definitions for an entity:
entity2datatype :: Option -> String -> Entity -> [CTypeDecl]
entity2datatype _ ername (Entity name attrs) =
  [CType (ername,name) Public [] [CCons (ername,name) Private argTypes],
   CTypeSyn (ername,name++"Tuple") Private [] (tupleType (tail argTypes))]
 where
  arity = length attrs
  argTypes = map attrType attrs

-- Create transformation between entity type and tuple representation:
entity2trans :: Option -> String -> Entity -> [CFuncDecl]
entity2trans _ ername (Entity name attrs) =
  [cmtfunc
    ("Transforms entity "++name++" into tuple representation.")
    (ername,lowerFirst name++"2tuple")
    1
    Private
    (baseType (ername,name) ~> baseType (ername,name++"Tuple"))
    [simpleRule [CPComb (ername,name) (replace nix 0 (map xn [1..arity]))]
                (tupleExpr (map (\i->cvar ("x"++show i)) [2..arity]))],
   cmtfunc
    ("Transforms key and tuple into a "++name++" entity.")
    (ername,"keytuple2"++name)
    2
    Private
    (baseType (erdgen "Key") ~> baseType (ername,name++"Tuple")
     ~> baseType (ername,name))
    [simpleRule [xn 1, tuplePattern (map xn [2..arity])]
             (applyF (ername,name) (map (\i->cvar ("x"++show i)) [1..arity]))]]
 where
  arity = length attrs

-- Create transformation between generated entity type and tuple representation:
generatedEntity2trans :: Option -> String -> Entity -> [CFuncDecl]
generatedEntity2trans _ ername (Entity name attrs) =
  [cmtfunc
    ("Transforms relationship entity "++name++" into tuple representation.")
    (ername,lowerFirst name++"2tuple")
    1
    Private
    (baseType (ername,name) ~> baseType (ername,name++"Tuple"))
    [simpleRule [CPComb (ername,name) (map xn [1..arity])]
                (tupleExpr (map (\i->cvar ("x"++show i)) [1..arity]))],
   cmtfunc
    ("Transforms key and tuple into a "++name++" relationship entity.")
    (ername,"keytuple2"++name)
    2
    Private
    (baseType (erdgen "Key") ~> baseType (ername,name++"Tuple")
     ~> baseType (ername,name))
    [simpleRule [nix, tuplePattern (map xn [1..arity])]
             (applyF (ername,name) (map (\i->cvar ("x"++show i)) [1..arity]))]]
 where
  arity = length attrs


entity2datatypeKey :: Option -> String -> Entity -> CTypeDecl
entity2datatypeKey _ ername (Entity name attrs) =
  datatypeKey (ername, name) (getKeyType attrs)
  where
    getKeyType :: [Attribute] -> CTypeExpr
    getKeyType [] = error "entity2datatypeKey: missing key!"
    getKeyType (a@(Attribute _ _ key _) : atr) 
      | key == PKey = attrType a
      | otherwise   = getKeyType atr

datatypeKey :: QName -> CTypeExpr -> CTypeDecl
datatypeKey (s, name) argType =
  let n = (s, name ++ "Key")
  in
  CType n Public [] [CCons n Private [argType]] 

generatedEntity2datatype :: Option -> String -> Entity -> [CTypeDecl]
generatedEntity2datatype _ n (Entity name attrs) =
  [CType (n,name) Public [] 
         [CCons (n,name) Private
                (replicate (length attrs) (baseType (erdgen "Key")))],
   CTypeSyn (n,name++"Tuple") Private []
            (tupleType (replicate (length attrs) (baseType (erdgen "Key"))))]


---------------------------------------------------------------
-- Generate getter + setter operations for an entity:
---------------------------------------------------------------
entity2selmod :: Option -> String -> Entity -> [CFuncDecl]  
entity2selmod _ ername (Entity name attrs) =
  f (ername, name) 
    (length attrs) 
    1
    attrNames
    (map ((\y -> (ername,y)) . ((lowerFirst name) ++)) attrNames)
    (map ((\y -> (ername,y)) . (("set"++name) ++))     attrNames)
    (map getAType attrs)
    (map getNull attrs)
    (map isPKey attrs)
    (map getFKeyDom attrs)
  where
    getANames :: [Attribute] -> [String]
    getANames [] = []
    getANames ((Attribute an _ _ _): ats) = an : getANames ats

    attrNames = getANames attrs

    getAType :: Attribute -> QName
    getAType (Attribute _ t k _) =
      case t of IntDom _        -> if k==PKey then erdgen "Key" else pre "Int"
                FloatDom _      -> pre "Float"
                StringDom _     -> pre "String"
                BoolDom _       -> pre "Bool"
                DateDom _       -> ("Time","CalendarTime")
                UserDefined s _ -> userMod s
                KeyDom s        -> (ername,s++"Key")
                _               -> pre "" -- should not occur

    -- null values are only handled in a specific way (i.e., as Maybe types)
    -- if they are not strings
    getNull :: Attribute -> Bool
    getNull (Attribute _ t _ null) = null && not (isStringDom t)

    isPKey :: Attribute -> Bool
    isPKey (Attribute _ _ key _) = key == PKey 

    getFKeyDom :: Attribute -> String
    getFKeyDom (Attribute _ t _ _) =
      case t of KeyDom kd -> kd
                _         -> "" 

    f :: QName -> Int -> Int -> [String]
        -> [QName] -> [QName] -> [QName]
        -> [Bool] -> [Bool] -> [String] -> [CFuncDecl]
    f _ _ _ [] [] [] [] [] [] [] = []
    f n l nth (attr:attrnames) (s:selnames) (m:modnames) (t:types)
              (null:nulls) (key:keys) (fkeydom:fkeydoms) 
      --| fkey      = (selector n l nth s t null Private) :
      --              (f n l (nth+1) selnames modnames types nulls keys fkeys)             
      | key       = (mutator n l nth attr m t null Private fkeydom)
         : (f n l (nth+1) attrnames selnames modnames types nulls keys fkeydoms)
      | otherwise = (selector n l nth attr s t null Public fkeydom) 
         : (mutator n l nth attr m t null Public fkeydom)
         : (f n l (nth+1) attrnames selnames modnames types nulls keys fkeydoms)

-- enAttrName :: EN -> (Maybe) AttrType
-- enAttrName (EN x _ ... _) = x
selector :: QName -> Int -> Int -> String -> QName -> QName -> Bool
         -> CVisibility -> String -> CFuncDecl
selector consname arity nth attr selname nthType isnull v fKeyDom = 
  cmtfunc
    ("Gets the value of attribute \""++attr++"\" of a "++snd consname++
     " entity.")
    selname 1 v selType
    (if null fKeyDom
     then [simpleRule
             [CPComb consname (replace x (nth-1) (replicate arity nix))] 
             (cvar "x")]
     else
      if isnull
      then [simpleRule [CPComb consname (replace (CPComb (pre "Nothing") [])
                                                 (nth-1)
                                                 (replicate arity nix))] 
                       (constF (pre "Nothing")),
            simpleRule [CPComb consname (replace (CPComb (pre "Just") [x])
                                                 (nth-1)
                                                 (replicate arity nix))] 
                       (applyJust
                             (applyF (fst selname,fKeyDom++"Key") [cvar "x"]))]
      else [simpleRule
              [CPComb consname (replace x (nth-1) (replicate arity nix))] 
              (applyF (fst selname,fKeyDom++"Key") [cvar "x"])])
  where
    selType =
      if isnull then baseType consname ~> maybeType (baseType nthType)
                else baseType consname ~> baseType nthType

--setStudentName :: Student -> String -> Student
--setStudentName (Student x1 _ x3 x4) x = Student x1 x x3 x4
--setStudentName :: Student -> Maybe String -> Student
--setStudentName (Student x1 _ x3 x4) x = Student x1 x x3 x4
mutator :: QName -> Int -> Int -> String -> QName
        -> QName -> Bool -> CVisibility -> String -> CFuncDecl
mutator consname arity nth attr modname nthType isnull v fKeyDom =
  cmtfunc
    ("Sets the value of attribute \""++attr++"\" in a "++snd consname++
     " entity.")
    modname 1 v
    (modType consname nthType isnull)
    [simpleRule [CPComb consname (replace nix (nth-1) (map xn [1..arity])),
                 if True --null fKeyDom
                 then x
                 else CPComb (fst modname,fKeyDom++"Key") [x]]
             (applyF consname
                     (replace (rhsArg (cvar "x")) (nth-1)
                              (map (\i->cvar ("x"++show i)) [1..arity])))]
  where
    modType typeCons typeArg n
      | n         = (baseType typeCons) ~> maybeType (baseType typeArg) 
                                      ~> baseType typeCons
      | otherwise = (baseType typeCons) ~> (baseType typeArg) ~> (baseType typeCons)

    rhsArg arg = if null fKeyDom
                 then arg
                 else applyF (fst modname,
                              if isnull
                              then "maybe" ++  fKeyDom ++ "KeyToKey"
                              else lowerFirst fKeyDom ++ "KeyToKey")
                             [arg]


entityKey :: QName -> [Attribute] -> CVisibility -> CFuncDecl
entityKey (s,eName) attrs v =
  cmtfunc
    ("Gets the key of a "++eName++" entity.")
    (s,(lowerFirst eName) ++ "Key") 1 v
    ((baseType (s,eName)) ~> (baseType (s,eName ++ "Key")))
    [simpleRule [CPComb (s,eName) 
                        (replace x (key attrs) 
                                 (replicate (length attrs) nix))]
                (applyF (s, eName ++ "Key") [cvar "x"])]
  where 
    key :: [Attribute] -> Int
    key ((Attribute _ _ k _) : ats) 
      | k == PKey = 0 
      | otherwise = 1 + key ats

-- Generate "show" function for database keys.
showEntityKey :: QName -> CVisibility -> CFuncDecl
showEntityKey (s,eName) v =
 cmtfunc
   ("Shows the key of a "++eName++" entity as a string.\n"++
    "This is useful if a textual representation of the key is necessary\n"++
    "(e.g., as URL parameters in web pages), but it should no be used\n"++
    "to store keys in other attributes!")
   (s,"show"++eName++"Key") 1 v
   (baseType (s,eName) ~> stringType)
   [simpleRule [cpvar "obj"]
               (applyF (erdgen "showDatabaseKey")
                       [string2ac eName,
                        constF (s,(lowerFirst eName) ++ "KeyToKey"),
                        applyF (s,(lowerFirst eName) ++ "Key")
                               [cvar "obj"]])]

-- Generate "read" function for database keys.
readEntityKey :: QName -> CVisibility -> CFuncDecl
readEntityKey (s,eName) v =
 cmtfunc
   ("Transforms a string into a key of a "++eName++" entity.\n"++
    "Nothing is returned if the string does not represent a reasonable key.")
   (s,"read"++eName++"Key") 1 v
   (stringType ~> maybeType (baseType (s,eName++"Key")))
   [simpleRule [cpvar "s"]
               (applyF (erdgen "readDatabaseKey")
                       [string2ac eName,
                        constF (s,eName ++ "Key"),
                        cvar "s"])]

entityKeyToKey :: QName -> CVisibility -> CFuncDecl
entityKeyToKey (s,eName) v =
 cfunc (s,(lowerFirst eName) ++ "KeyToKey") 1 v
       ((baseType (s,eName ++ "Key")) ~> (baseType (erdgen "Key")))
       [simpleRule [CPComb (s,eName ++ "Key") [cpvar "k"]] (cvar "k")]

entityMaybeKeyToKey :: QName -> CVisibility -> CFuncDecl
entityMaybeKeyToKey (s,eName) v =
 cfunc (s,"maybe" ++ eName ++ "KeyToKey") 1 v
       (maybeType (baseType (s,eName ++ "Key"))
        ~> maybeType (baseType (erdgen "Key")))
       [simpleRule [CPComb (pre "Nothing") []] (constF (pre "Nothing")),
        simpleRule [CPComb (pre "Just") [CPComb (s,eName ++ "Key") [cpvar "k"]]]
                   (applyJust (cvar "k"))]

------------------------------------------------------------------------
-- dynamic predicates for tables
----------------------------------------------------------------------

-- Generate dynamic predicate definition for an entity.
-- en :: ENKey -> EN -> Dynamic
-- en (ENKey i) (EN x1 ... xn) | i =:= x1 = enEntry (EN i x2 ... xn)
pred :: QName -> Int -> CVisibility -> CFuncDecl
pred (s,eName) _ v = let ename = lowerFirst eName in
  cmtfunc
    ("Dynamic predicate representing the relation\nbetween keys and "++eName++
     " entities.")
    (s,ename) 1 v 
    (baseType (s,eName++"Key") ~> baseType (s,eName) ~> baseType (db "Dynamic"))
    [CRule [cpvar "key",cpvar "obj"]
           (CGuardedRhs
             [(applyF (pre "=:=")
                      [cvar "key",
                       applyF (s,ename++"Key") [cvar "obj"]],
               applyF (s,ename++"Entry")
                 [applyF (s,ename++"KeyToKey") [cvar "key"],
                  applyF (s,ename++"2tuple")   [cvar "obj"]])]
             [])]

-- Generate persistent dynamic predicate for an entity using file-based
-- implementation of PAKCS.
-- enEntry :: Key -> ENTuple -> Dynamic
-- enEntry = persistent "file:enDB"
predEntry :: QName -> CVisibility -> String -> CFuncDecl
predEntry (s, eName) v dbpath =
  cmtfunc
    ("Database predicate representing the relation between keys and "++eName++
     " tuple entities.")
    (s,(lowerFirst eName) ++ "Entry") 2 v 
    (baseType (erdgen "Key") ~> baseType (s,eName++"Tuple")
     ~> baseType (db "Dynamic"))
    [simpleRule []
             (applyF (db "persistent") 
                     [cvar ("\"file:" ++ dbpath ++ "/" ++ eName ++ "DB\"")])]

-- Generate persistent dynamic predicate for an entity using DB implementation
-- of Sebastian Fischer.
-- enEntry :: EN -> Dynamic
-- enEntry = persistent1 "db:file" enSpec
predEntry1 :: QName -> CVisibility -> CFuncDecl
predEntry1 (s, eName) v =
  cmtfunc
    ("Database predicate representing "++eName++" entities.")
    (s,(lowerFirst eName) ++ "Entry") 1 v 
    (baseType (s,eName) ~> baseType (db "Dynamic"))
    [simpleRule []
       (applyF (db "persistent1") 
               [cvar ("\"db:" ++ eName ++ "DB\""),
                CSymbol (s, (lowerFirst eName) ++ "Spec")])]

entitySpec :: QName -> [Attribute] -> CVisibility -> CFuncDecl
entitySpec (s,eName) attrs v = 
  cfunc (s,(lowerFirst eName) ++ "Spec") 0 v
        (CTCons (db "DBSpec") [baseType (s,eName)]) 
        [simpleRule [] (applyCons (s, eName) (length attrs) (reverse attrs))]
  where 
    applyCons :: QName -> Int -> [Attribute] -> CExpr
    applyCons (m, cons) i [] = applyF (db ("cons" ++ show i))
                                      [CSymbol (m, cons)]
    applyCons (m, cons) i ((Attribute n d _ _):ats) =
      CApply (applyCons (m, cons) i ats)
             (applyF (db (typeF d)) [cvar ("\""++n++"\"")])  

    typeF :: Domain -> String
    typeF (IntDom _) = "int"
    typeF (FloatDom _) = "float"
    typeF (StringDom _ ) = "string"
    typeF (BoolDom _) = "bool"
    typeF (DateDom _) = "date"
    typeF (KeyDom _) = "int"
    typeF (UserDefined str _) = 
       let (m,f) = userMod str
        in m ++ "." ++ lowerFirst f

-- Generate persistent dynamic predicate for an entity using SQLite3 DB
-- of Sebastian Fischer's KeyDatabase module.
predEntrySQLite :: QName -> [Attribute] -> CVisibility -> String -> CFuncDecl
predEntrySQLite (s,eName) attrs v dbpath = 
  cmtfunc
    ("Database predicate representing the relation between keys and "++eName++
     " tuple entities.")
    (s, lowerFirst eName ++ "Entry") 2 v
    (baseType (erdgen "Key") ~> baseType (s,eName++"Tuple")
     ~> baseType (db "Dynamic"))
    [simpleRule [] 
               (applyF (db "persistentSQLite")
                  [constF (s,"dbFile"),
                   string2ac eName,
                   list2ac (map att2string attrs)])]
  where 
    att2string :: Attribute -> CExpr
    att2string (Attribute n _ _ _) = string2ac n

--------------------------------------------------------------------

-- DB operations
-------------------------------------------------------------------
--- Generates a get-Operation for an entity.
-- getDozent :: DozentKey -> IO Dozent
-- getDozent key = getEntry key dozent
getEntity :: QName -> CVisibility -> [CFuncDecl]
getEntity (s,eName) v =
  let e = lowerFirst eName
  in
  [cmtfunc
    ("Gets a "++eName++" entity stored in the database with the given key.")
    (s,"get" ++ eName) 1 v
    ((baseType (s, eName ++ "Key")) ~> (CTCons transTC [baseType (s,eName)])) 
    [simpleRule [cpvar "key"]
                (applyF (erdgen "getEntry")
                        [CSymbol (s,e++"Entry"),
                         CSymbol (s,"keytuple2"++eName),
                         applyF (s,e++"KeyToKey") [cvar "key"]])],
   cmtfunc
    ("Gets all "++eName++" entities stored in the database.")
    (s,"queryAll"++eName++"s") 0 v
    (CTCons (db "Query") [listType (baseType (s,eName))])
    [simpleRule []
             (applyF (db "transformQ")
                     [applyF (pre "map")
                       [applyF (pre "uncurry")
                           [CSymbol (s,"keytuple2"++eName)]],
                      applyF (db "allDBKeyInfos") [CSymbol (s,e++"Entry")]])],
   cmtfunc
    ("Gets all "++eName++" entities satisfying a given condition.")
    (s,"queryCond" ++ eName) 1 v
    ((baseType (s,eName) ~> baseType (pre "Bool"))
     ~> CTCons (db "Query") [listType (baseType (s,eName))])
    [simpleRule [cpvar "econd"]
                (applyF (db "transformQ")
                        [applyF (pre "filter") [cvar "econd"],
                         constF (s,"queryAll"++eName++"s")])]]

-------------------------------------------------------------------
entity2DBcode :: Option -> String -> [Entity] -> [Entity] -> [Relationship]
              -> Entity -> [CFuncDecl]
entity2DBcode (storage,_) ername es esAll rsAll e@(Entity name attrs) = 
  let n = (ername, name)
  in
  (case storage of Files dbpath  -> [predEntry n Private dbpath]
                   SQLite dbpath -> [predEntrySQLite n (tail attrs)
                                                     Private dbpath]
                   DB            -> [predEntry1 n Private,
                                     entitySpec n attrs Private]) ++
  [pred n (length attrs) Public,
   entityKey n attrs Public,
   showEntityKey n Public,
   readEntityKey n Public,
   entityKeyToKey n Private,
   entityMaybeKeyToKey n Private,
   newEntity n attrs es (relationshipsForEntityName (entityName e) rsAll)
             Public esAll rsAll,
   updateEntity n es rsAll Public,
   deleteEntity n es esAll rsAll Public] ++
   getEntity n Public

-- newEntity (emod,ename) attrs ens rels vis allens allrels
-- (emod,ename): qualified name of entity
-- attrs: attributes that are provided as parameters to the new operation
--        (of type Maybe if attribute has a default value)
-- ens:  entities that are not generated for relationships
-- rels: relationships related to this entity
-- vis: visibility
-- allens: all entities
-- allrels: all relationships
newEntity :: QName -> [Attribute] -> [Entity] -> [Relationship] -> CVisibility 
         -> [Entity] -> [Relationship] -> CFuncDecl
newEntity (str,eName) attrs ens rels v esAll rsAll =
  let e = lowerFirst eName

      generatedRs = filter isGeneratedR rels
      exactRs  = filter isExactB  generatedRs --(i,i), i>1
      maxRs    = filter isMaxB    generatedRs --(0,i), i>1
      minMaxRs = filter isMinMaxB generatedRs --(i,j), i>0, j>i
      newFunType = newType (str,eName) (filter notPKey attrs)
                           exactRs maxRs minMaxRs rsAll

      l = length (exactRs ++ maxRs ++ minMaxRs)
      attributeP = map ((++"_p") . lowerFirst . attributeName)
                       (filter notPKey attrs)
      exactP = duplicate exactRs (map (("k"++) . show) [1 .. length exactRs])
      maxP = map (("ks"++) . show)
                 [length exactRs + 1 .. length (exactRs ++ maxRs)]
      minMaxP = duplicate' minMaxRs 
                  (map (("k" ++) . show) [length (exactRs ++ maxRs) + 1 .. l])
                  (map (("ks"++) . show) [length (exactRs ++ maxRs) + 1 .. l])
      parameter = attributeP ++ exactP ++ maxP ++ minMaxP
                  
      ts = tests (str,eName) ens rels
                 (New exactRs exactP maxRs maxP minMaxRs minMaxP rsAll) 

      entryCall =
          applyF (erdgen "newEntry")
                 [CSymbol (str, e++"Entry"),
                  CSymbol (str, "keytuple2"++eName),
                  tupleExpr (map (keyToKeyCvar str)
                                 (zipWith (\a b -> (a,b))
                                          (filter notPKey attrs)
                                          parameter))]

      newSuffix = concatMap ("With"++)
                            (map attributeName (filter isForeignKey attrs)) ++
                  if l==0
                  then ""
                  else concatMap (\k->"With"++k++"Keys")
                                 (map (relatedRelation eName)
                                      (exactRs++maxRs++minMaxRs))
  in
  cmtfunc
    ("Inserts a new "++eName++" entity.")
    (str,"new" ++ eName ++ newSuffix) (length attrs) v
    newFunType
    [simpleRule
      (map cpvar parameter)
      (foldr (\a b -> applyF (db "|>>") [a,b])
          (if null (exactP++maxP++minMaxP)
           then entryCall
           else applyF (db "|>>=")
                  [entryCall,
                   CLambda 
                     [cpvar "entry"]
                     (foldr
                        (\a b -> applyF (db "|>>") [a,b])
                        (applyF (db "returnT") [cvar "entry"]) 
                        (newEntryExact exactRs exactP (str,e) esAll rsAll ++
                         newEntryMax maxRs maxP (str,e) esAll rsAll ++
                         newEntryMinMax minMaxRs minMaxP (str,e) esAll rsAll))])
          ts)]

 where
   -- extracts the name of the relationship related to a given entity name
   relatedRelation :: String -> Relationship -> String
   relatedRelation en (Relationship _ [REnd en1 _ _, REnd en2 _ _]) =
     if en==en1 then en2 else en1

   correctOrder :: String -> String -> [Entity] -> Bool
   correctOrder _ _ [] = error "entity not found" --False
   correctOrder en en1 (Entity name atts :es) 
     | en == name = case atts of
         [Attribute _ (KeyDom e1) _ _, _] -> e1==en1 
         [_, Attribute _ (KeyDom _) _ _] -> False
         _                                -> error "correctOrder: wrong attributes"
     | otherwise = correctOrder en en1 es

   -- extract the lowercase domain names of a derived relationship entity:
   lcDomainsOfRelEntity :: [Entity] -> String -> (String,String)
   lcDomainsOfRelEntity allens derivedename =
     maybe (error $ "Entity "++derivedename++" not found!")
           (\e -> let domnames = map ((\ (KeyDom kdn) -> kdn) . attributeDomain)
                                     (entityAttributes e)
                   in (lowerFirst (head domnames), lowerFirst (domnames!!1)))
           (find (\e -> entityName e == derivedename) allens)

   newEntryExact [] _ _ _ _ = []
   newEntryExact (Relationship _ [REnd en _ _, REnd rn _ (Exactly i)]:exactRs) exactP (s,e) es rs = 
     let (ip,restp) = splitAt i exactP
         (d1,d2) = lcDomainsOfRelEntity es rn
     in
     (map (\p -> applyF (erdgen "newEntryR") 
                        (if correctOrder rn en es
                         then [constF (s, lowerFirst rn++"Entry"),
                               applyF (s,d1++"KeyToKey")
                                      [applyF (s,e++"Key") [cvar "entry"]], 
                               applyF (s,d2++"KeyToKey") [cvar p]] 
                         else [constF (s,lowerFirst rn++"Entry"),
                               applyF (s,d1++"KeyToKey") [cvar p],
                               applyF (s,d2++"KeyToKey")
                                      [applyF (s,e++"Key") [cvar "entry"]]]))
          ip)
       ++ (newEntryExact exactRs restp (s,e) es rs)

   newEntryMax [] _ _ _ _ = []
   newEntryMax (Relationship _ [REnd en _ _, REnd rn _ _]:maxRs) (p:maxP) (s,e) es rs = 
     let (d1,d2) = lcDomainsOfRelEntity es rn
     in
     [applyF (pre "mapT_")
             [CLambda [cpvar "a"]
                      (applyF (erdgen "newEntryR")
                              (if correctOrder rn en es
                               then [constF (s, lowerFirst rn++"Entry"),
                                     applyF (s,d1++"KeyToKey")
                                       [applyF (s,e++"Key") [cvar "entry"]], 
                                     applyF (s,d2++"KeyToKey") [cvar "a"]] 
                               else [constF (s, lowerFirst rn++"Entry"),
                                     applyF (s,d1++"KeyToKey") [cvar "a"],
                                     applyF (s,d2++"KeyToKey")
                                       [applyF (s,e++"Key") [cvar "entry"]]])),
              cvar p]]
        ++ newEntryMax maxRs maxP (s,e) es rs
  
   newEntryMinMax [] _ _ _ _ = []
   newEntryMinMax
          (Relationship _ [REnd en _ _, REnd rn _ (Between i _)] : minMaxRs)
          minMaxP (s,e) es rs = 
     let (ip,(p:restp)) = splitAt i minMaxP
         (d1,d2) = lcDomainsOfRelEntity es rn
     in
     (map (\a -> applyF (erdgen "newEntryR") 
                        (if correctOrder rn en es
                         then [constF (s, lowerFirst rn++"Entry"),
                               applyF (s,d1++"KeyToKey")
                                      [applyF (s,e++"Key") [cvar "entry"]], 
                               applyF (s,d2++"KeyToKey") [cvar a]]
                         else [constF (s, lowerFirst rn++"Entry"),
                               applyF (s,d1++"KeyToKey") [cvar a],
                               applyF (s,d2++"KeyToKey")
                                      [applyF (s,e++"Key") [cvar "entry"]]]))
          ip)
       ++ [applyF (pre "mapT_")
                  [CLambda [cpvar "a"]
                           (applyF (erdgen "newEntryR")
                              (if correctOrder rn en es
                               then [constF (s, lowerFirst rn++"Entry"),
                                     applyF (s,d1++"KeyToKey")
                                       [applyF (s,e++"Key") [cvar "entry"]],
                                     applyF (s,d2++"KeyToKey") [cvar "a"]] 
                               else [constF (s, lowerFirst rn++"Entry"),
                                     applyF (s,d1++"KeyToKey") [cvar "a"],
                                     applyF (s,d2++"KeyToKey")
                                       [applyF (s,e++"Key") [cvar "entry"]]])),
                   cvar p]]
        ++ newEntryMinMax minMaxRs restp (s,e) es rs


   isExactB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
     case c of Exactly i -> i>1
               _         -> False
   isMaxB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
     case c of (Between 0 (Max i)) -> i>1
               _                   -> False
   isMinMaxB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
     case c of (Between i (Max j)) -> i>0 && j>i
               _                   -> False

   getExactB (Relationship _ [REnd _ _ _, REnd _ _ (Exactly i)]) = i 
   getMinB (Relationship _ [REnd _ _ _, REnd _ _ (Between i _)]) = i

   duplicate [] [] = []
   duplicate (Relationship _ [REnd _ _ _, REnd _ _ (Exactly i)]:exactRs) (p:ps) =
     (map ((p++) . show) [1..i]) ++ (duplicate exactRs ps)

   duplicate' [] [] [] = []
   duplicate' (Relationship _ [REnd _ _ _, REnd _ _ (Between i _)]:minMaxRs) (p:ps) (kp:kps) =
     (map ((p++) . show) [1..i]) ++ (kp:(duplicate' minMaxRs ps kps))

   newType :: QName -> [Attribute] -> [Relationship] -> [Relationship]
             -> [Relationship] -> [Relationship] -> CTypeExpr
   newType (m,n) [] exactRs maxRs minMaxRs rs 
     | null exactRs && null maxRs && null minMaxRs = CTCons transTC [baseType (m,n)] 
     | length exactRs > 0 = nTExact (m,n) exactRs maxRs minMaxRs rs
     | length maxRs > 0 = nTMax (m,n) maxRs minMaxRs rs
     | otherwise = nTMinMax (m,n) minMaxRs rs
   newType n (a@(Attribute _ d _ nu):ats) exactRs maxRs minMaxRs rs = 
     let t = case d of KeyDom s -> if nu 
                                   then maybeType (ctvar (s++"Key"))
                                   else ctvar (s++"Key")
                       _        -> attrTypeNew a 
     in
     CFuncType t  (newType n ats exactRs maxRs minMaxRs rs) 
   
   nTExact (m,n) [] maxRs minMaxRs rs = nTMax (m,n) maxRs minMaxRs rs
   nTExact (m,n) (Relationship _ [REnd en1 _ _, REnd en2 _ (Exactly e)]:exactRs) maxRs minMaxRs rs =
     let keyType = (startsIn en1 en2 rs) ++ "Key"
     in
     foldr (~>) (nTExact (m,n) exactRs maxRs minMaxRs rs) (replicate e (ctvar keyType))

   nTMax (m,n) [] minMaxRs rs = nTMinMax (m,n) minMaxRs rs
   nTMax (m,n) (Relationship _ [REnd en1 _ _, REnd en2 _ _]:maxRs) minMaxRs rs =
     let keyType = (startsIn en1 en2 rs) ++ "Key"
     in
     (listType (ctvar keyType)) ~> (nTMax (m,n) maxRs minMaxRs rs) 

   nTMinMax (m,n) [] _ = CTCons transTC [baseType (m,n)] 
   nTMinMax (m,n) (Relationship _ [REnd en1 _ _,REnd en2 _ (Between min _)]:minMaxRs) rs =
     let keyType = (startsIn en1 en2 rs) ++ "Key"
     in
     foldr (~>) (nTMinMax (m,n) minMaxRs rs) 
           ((replicate min (ctvar keyType)) ++ [listType (ctvar keyType)])

   startsIn :: String -> String -> [Relationship] -> String
   startsIn _ _ [] = error "missing relationship"
   startsIn n en (Relationship _ [REnd en1 _ _, REnd en2 _ _]:rs) 
     | en == en2 && en1 /= n = en1
     | otherwise = startsIn n en rs

   keyToKeyCvar :: String -> (Attribute,String) -> CExpr
   keyToKeyCvar name (Attribute _ d _ isnull, p) =  case d of
     KeyDom s -> applyF (name, if isnull then "maybe"++s++"KeyToKey"
                                         else lowerFirst s++"KeyToKey")
                        [cvar p]
     _  -> if hasDefault d 
           then let defaultmaybe = if isStringDom d
                                   then applyF (erdgen "defaultString")
                                               [getDefault d, cvar p]
                                   else applyMaybe (getDefault d)
                                                   (constF (pre "id")) (cvar p)
                 in if isnull && not (isStringDom d)
                    then applyF (pre "Just") [defaultmaybe]
                    else defaultmaybe
           else cvar p

   -- Maybe if null values allowed or default values provided
   -- (except for string types!)
   attrTypeNew :: Attribute -> CTypeExpr  
   attrTypeNew (Attribute _ t k False) =
     case t of (IntDom Nothing)        -> if k==PKey 
                                          then baseType (erdgen "Key")
                                          else intType
               (IntDom (Just _))       -> maybeType intType
               (FloatDom Nothing)      -> floatType
               (FloatDom (Just _))     -> maybeType floatType
               (StringDom Nothing)     -> stringType
               (StringDom (Just _))    -> stringType
               (BoolDom Nothing)       -> boolType
               (BoolDom (Just _))      -> maybeType boolType
               (DateDom Nothing)       -> baseType ("Time","CalendarTime")
               (DateDom (Just _))      -> maybeType
                                            (baseType ("Time","CalendarTime"))
               (UserDefined s Nothing) -> baseType (userMod s)
               (UserDefined s (Just _))-> maybeType (baseType (userMod s))
               (KeyDom _)              -> baseType (erdgen "Key")
   attrTypeNew (Attribute _ t k True) = 
     case t of (IntDom _)       -> if k==PKey 
                                   then maybeType (baseType (erdgen "Key"))
                                   else maybeType intType
               (FloatDom _)     -> maybeType floatType
               (StringDom _)    -> stringType
               (BoolDom _)      -> maybeType boolType
               (DateDom _)      -> maybeType (baseType ("Time","CalendarTime"))
               (UserDefined s _)-> maybeType (baseType (userMod s))
               (KeyDom _)       -> maybeType (baseType (erdgen "Key"))
          

updateEntity :: QName -> [Entity] -> [Relationship] -> CVisibility -> CFuncDecl
updateEntity (s,eName) es rs v =
  let e = lowerFirst eName
      p = e ++ "_p"
      ts = tests (s,eName) es rs Update
      f = applyF (db "updateDBEntry")
                 [CSymbol (s,e++"Entry"),
                  applyF (s,e++"KeyToKey")
                         [applyF (s,e++"Key") [cvar p]],
                  applyF (s,e++"2tuple") [cvar p]]
  in
  cmtfunc ("Updates an existing "++eName++" entity.")
        (s,"update" ++ eName) 1 v
        ((baseType (s,eName)) ~> transactType)
        [simpleRule [cpvar p] (foldr (\a b -> applyF (db "|>>") [a,b]) f ts)]

deleteEntity :: QName -> [Entity] -> [Entity] -> [Relationship] -> CVisibility
             -> CFuncDecl
deleteEntity (s,eName) es esAll rsAll v =
  let e = lowerFirst eName
      p = e ++ "_p"
      ts = tests (s,eName) es rsAll (Delete esAll)
      f = applyF (db "deleteDBEntry")
                 [CSymbol (s,e++"Entry"),
                  applyF (s,e++"KeyToKey")
                         [applyF (s,e++"Key") [cvar p]]]
  in
  cmtfunc ("Deletes an existing "++eName++" entity.")
        (s,"delete" ++ eName) 1 v
        ((baseType (s,eName)) ~> transactType)
        [simpleRule [cpvar p] (foldr (\a b -> applyF (db "|>>") [a,b]) f ts)]

data TestType = New [Relationship] [String] [Relationship] [String] [Relationship] [String] [Relationship]
              | Update 
              | Delete [Entity]
              | Consistency

tests :: QName -> [Entity] -> [Relationship] -> TestType -> [CExpr]
tests (str,enName) entities rels tt = 
  let entity  = head (filter (isEntityNamed enName) entities)
      uas     = filter isUnique (entityAttributes entity)
      fkas    = filter isForeignKey (entityAttributes entity)
      ers     = relationshipsForEntityName (entityName entity) rels
      maxrsA  = filter (isMaxRelForEntityA enName) ers 
      maxrsB  = filter (isMaxRelForEntityB enName) ers
      maxrsAC = filter (isMaxRelForEntityAC enName) ers
      maxrsBC = filter (isMaxRelForEntityBC enName) ers
      minrsA  = filter (isRelWithRangeForEntityA isMinRange enName) ers
      minrsB  = filter (isRelWithRangeForEntityB isMinRange enName) ers
  in
  case tt of New exactRs exactP maxRs maxP minMaxRs minMaxP rsAll
                    -> (map (attributeToUniqueTest (str,enName)) uas)
                         ++ (map (fKeyExistTest (str,enName)) fkas)
                         ++ (map (relToMaxTestA (str,enName)) maxrsA)
                         ++ (map (relToMaxTestB (str,enName)) maxrsB)
                         ++ (dupTestExact exactRs exactP)
                         ++ (dupTestMax maxP)
                         ++ (dupTestMinMax minMaxRs minMaxP)
                         ++ (fKeyExistExact exactRs exactP str rsAll)
                         ++ (fKeyExistMax maxRs maxP str rsAll)
                         ++ (fKeyExistMinMax minMaxRs minMaxP str rsAll)
                         ++ (maxTestMax maxRs maxP)
                         ++ (maxTestMinMax minMaxRs minMaxP)

             Update -> (map (attributeToUniqueTestUpdate (str,enName)) uas)
                         ++ (map (fKeyExistTestUpdate (str,enName)) fkas)
                         ++ (map (relToMaxTestUpdateA (str,enName)) maxrsA)
                         ++ (map (relToMaxTestUpdateB (str,enName)) maxrsB)

             Delete esAll ->
               let entinfk = filter (hasForeignKey enName) esAll
                in (map (fKeyExistTestDelete (str,enName)) entinfk)

             Consistency -> (dupKeyTest (str,enName)
                              : (map (attributeToUniqueTestC (str,enName)) uas)
                              ++ (map (fKeyExistTestUpdate (str,enName)) fkas)
                              ++ (map (relToMaxTestAC (str,enName)) maxrsAC)
                              ++ (map (relToMaxTestBC (str,enName)) maxrsBC)
                              ++ (map (relToMinTestA (str,enName)) minrsA)
                              ++ (map (relToMinTestB (str,enName)) minrsB))

  where
    startsIn :: String -> String -> [Relationship] -> String
    startsIn _ _ [] = error "missing relationship"
    startsIn n en (Relationship _ [REnd en1 _ _, REnd en2 _ _]:rs) 
      | en == en2 && n/=en1 = en1
      | otherwise = startsIn n en rs

    dupTestExact :: [Relationship] -> [String] -> [CExpr]
    dupTestExact [] _ = []
    dupTestExact (Relationship _ [_, REnd _ _ (Exactly i)]:exactRs) exactP =
      let (ip, restp) = splitAt i exactP
      in
      applyF (erdgen "duplicatePTest")
             [foldr (\a b -> applyF (pre ":") [a, b])
                    (constF (pre "[]"))
                    (map cvar ip)]
        : dupTestExact exactRs restp
   
    dupTestMax :: [String] -> [CExpr]
    dupTestMax [] = []
    dupTestMax (p:maxP) =
      applyF (erdgen "duplicatePTest")
             [cvar p]
        : dupTestMax maxP

    dupTestMinMax :: [Relationship] -> [String] -> [CExpr]
    dupTestMinMax [] _ = []
    dupTestMinMax (Relationship _ [_, REnd _ _ (Between i _)]:minMaxRs) minMaxP =
      let (ip, (p:restp)) = splitAt i minMaxP
      in
      applyF (erdgen "duplicatePTest")
             [foldr (\a b -> applyF (pre ":") [a, b]) (cvar p) (map cvar ip)]
        : dupTestMinMax minMaxRs restp

    maxTestMax :: [Relationship] -> [String] -> [CExpr]
    maxTestMax [] _ = []
    maxTestMax (Relationship _ [_, REnd _ _ (Between _ (Max max))]:maxRs) (p:maxP) =
      applyF (erdgen "maxPTest") [CLit (CIntc max), cvar p]
        : maxTestMax maxRs maxP

    maxTestMinMax :: [Relationship] -> [String] -> [CExpr]
    maxTestMinMax [] _ = []
    maxTestMinMax (Relationship _ [_, REnd _ _ (Between min (Max max))]
                    : minMaxRs) minMaxP =
      let (_, (p:restp)) = splitAt min minMaxP
      in
      applyF (erdgen "maxPTest") [CLit (CIntc (max-min)), cvar p]
        : maxTestMinMax minMaxRs restp
   

    fKeyExistExact :: [Relationship] -> [String] -> String -> [Relationship]-> [CExpr]
    fKeyExistExact [] _ _ _ = []
    fKeyExistExact (Relationship _ [REnd n _ _, REnd rn _ (Exactly i)]:exactRs) exactP s rs =
      let (ip, restp) = splitAt i exactP
          eN = startsIn n rn rs
       in map (\v -> existsDBKeyCall (s,eN) (Just (cvar v))) ip ++
          fKeyExistExact exactRs restp s rs

    fKeyExistMax :: [Relationship] -> [String] -> String -> [Relationship]-> [CExpr]
    fKeyExistMax [] _ _ _ = []
    fKeyExistMax (Relationship _ [REnd n _ _, REnd rn _ _]:maxRs) (p:maxP) s rs =
      let eN = startsIn n rn rs
      in
      applyF (pre "mapT_") [existsDBKeyCall (s,eN) Nothing, cvar p]
        : fKeyExistMax maxRs maxP s rs
 
    fKeyExistMinMax :: [Relationship] -> [String] -> String -> [Relationship]-> [CExpr]
    fKeyExistMinMax [] _ _ _ = []
    fKeyExistMinMax (Relationship _ [REnd n _ _, REnd rn _ (Between i _)]:minMaxRs) minMaxP s rs =
      let (ip, (p:restp)) = splitAt i minMaxP
          eN = startsIn n rn rs
      in
      (map (\v -> existsDBKeyCall (s,eN) (Just (cvar v))) ip)    
        ++ [applyF (pre "mapT_") [existsDBKeyCall (s,eN) Nothing, cvar p]]    
        ++ (fKeyExistMinMax minMaxRs restp s rs)
              

    isUnique :: Attribute -> Bool
    isUnique (Attribute _ _ k _) = k == Unique

    isMaxRelForEntityA :: EName -> Relationship -> Bool
    isMaxRelForEntityA e (Relationship _ [REnd e1 _ c1, _]) = e==e1 &&
      case c1 of Between _ (Max i) -> i>1
                 _                 -> False

    isMaxRelForEntityB :: EName -> Relationship -> Bool
    isMaxRelForEntityB e (Relationship _ [_, REnd e2 _ c2]) = e==e2 &&
      case c2 of Between _ (Max i) -> i>1
                 _                 -> False

    isMaxRelForEntityAC :: EName -> Relationship -> Bool
    isMaxRelForEntityAC e (Relationship _ [REnd e1 _ _, REnd _ _ c2]) = e==e1 &&
      case c2 of Between _ (Max i) -> i>1
                 Exactly i         -> i>1
                 _                 -> False

    isMaxRelForEntityBC :: EName -> Relationship -> Bool
    isMaxRelForEntityBC e (Relationship _ [REnd _ _ c1, REnd e2 _ _]) = e==e2 &&
      case c1 of Between _ (Max i) -> i>1
                 Exactly i         -> i>1
                 _                 -> False

    fKeyExistTest :: QName -> Attribute -> CExpr
    fKeyExistTest (s,_) (Attribute an (KeyDom kd) _ isnull) =
      let existsKeyCall = existsDBKeyCall (s,kd)
          keyvar = cvar (lowerFirst an ++"_p")
       in if isnull
          then applyMaybe (constF (db "doneT")) (existsKeyCall Nothing) keyvar
          else existsKeyCall (Just keyvar)

    fKeyExistTestUpdate :: QName -> Attribute -> CExpr
    fKeyExistTestUpdate (s,eName) (Attribute an (KeyDom kd) _ isnull) =
      let existsKeyCall = existsDBKeyCall (s,kd)
          keyarg = applyF (s,lowerFirst eName ++ an) 
                          [cvar (lowerFirst eName ++"_p")]
       in if isnull
          then applyMaybe (constF (db "doneT")) (existsKeyCall Nothing) keyarg
          else existsKeyCall (Just keyarg)

    fKeyExistTestDelete :: QName -> Entity -> CExpr
    fKeyExistTestDelete (s,eName) (Entity feName attrs) =
      let fkattrs = map (\a -> (attributeName a, isNullAttribute a))
                        (foreignKeyAttributes eName attrs)
          fkarg = applyF (s,lowerFirst eName++"Key") 
                         [cvar (lowerFirst eName ++"_p")]
       in seqTrans (map (\ (fkaName,fkisnull) ->
                           applyF (erdgen "requiredForeignDBKey")
                                  [string2ac feName,
                                   CSymbol (s,lowerFirst feName ++"Entry"),
                                   CSymbol (s,"keytuple2"++feName),
                                   CSymbol (s,lowerFirst feName ++ fkaName),
                                   if fkisnull
                                   then applyJust fkarg
                                   else fkarg ])
                        fkattrs)

    attributeToUniqueTest :: QName -> Attribute -> CExpr
    attributeToUniqueTest (s,eName) (Attribute an dom _ _) =
      let ename = lowerFirst eName in
      applyF (erdgen "unique")
             [string2ac s,
              CSymbol (s,ename++"Entry"),
              CSymbol (s,"keytuple2"++eName),
              CSymbol (s,ename++an),
              let cv = cvar (lowerFirst an ++"_p")
               in if hasDefault dom
                  then applyMaybe (getDefault dom) (constF (pre "id")) cv
                  else cv]

    attributeToUniqueTestUpdate :: QName -> Attribute -> CExpr
    attributeToUniqueTestUpdate (s,eName) (Attribute an _ _ _) =
      let ename = lowerFirst eName in
      applyF (erdgen "uniqueUpdate")
             [string2ac s,
              CSymbol (s,ename++"Entry"),
              CSymbol (s,"keytuple2"++eName),
              applyF (pre ".") [CSymbol (s,ename++"KeyToKey"),
                                CSymbol (s,ename++"Key")],
              CSymbol (s,ename++an),
              cvar (ename++"_p")]

    {- different unique for update,
       and instead of cvar (lowerFirst an ++"_p") : 
       applyF (s, lowerFirst eName ++an) [cvar (lowerFirst eName++"_p")]-}

    attributeToUniqueTestC :: QName -> Attribute -> CExpr
    attributeToUniqueTestC (s,eName) (Attribute an _ _ _) =
      let ename = lowerFirst eName in
      applyF (erdgen "uniqueC") 
             [string2ac s,
              CSymbol (s,ename++"Entry"),
              CSymbol (s,"keytuple2"++eName),
              CSymbol (s,ename++an),
              cvar (ename++"_p")]

    relToMaxTestA :: QName -> Relationship -> CExpr
    relToMaxTestA (s,eName) (Relationship rn [REnd _ _ c1, REnd e2 _ _]) =
      relToMaxTest (s,eName) (cardMaximum c1) (combineIds [e2,rn,"Key"])

    relToMaxTestB :: QName -> Relationship -> CExpr
    relToMaxTestB (s,eName) (Relationship rn [REnd e1 _ _, REnd _ _ c2]) =
      relToMaxTest (s,eName) (cardMaximum c2) (combineIds [e1,rn,"Key"])

    relToMaxTest :: QName -> Int -> String -> CExpr
    relToMaxTest (s,eName) m attrName =
      let ename = lowerFirst eName in
      applyF (erdgen "maxTest")
             [string2ac eName,
              CSymbol (s,ename++"Entry"),
              CSymbol (s,"keytuple2"++ename),
              CSymbol (s,ename++attrName),
              CLit (CIntc m), 
              cvar (lowerFirst attrName++"_p")]
      
    relToMaxTestUpdateA :: QName -> Relationship -> CExpr
    relToMaxTestUpdateA (s,eName) (Relationship rn [REnd _ _ c1, REnd e2 _ _]) =
      relToMaxTestUpdate (s,eName) (cardMaximum c1) (combineIds [e2,rn,"Key"])

    relToMaxTestUpdateB :: QName ->  Relationship -> CExpr
    relToMaxTestUpdateB (s,eName) (Relationship rn [REnd e1 _ _, REnd _ _ c2]) =
      relToMaxTestUpdate (s,eName) (cardMaximum c2) (combineIds [e1,rn,"Key"])

    relToMaxTestUpdate :: QName -> Int -> String -> CExpr
    relToMaxTestUpdate (s,eName) m attrName =
      let ename = lowerFirst eName in
      applyF (erdgen "maxTestUpdate")
             [string2ac eName,
              CSymbol (s,ename++"Entry"),
              CSymbol (s,"keytuple2"++ename),
              CSymbol (s,ename++"Key"),
              CSymbol (s,ename++attrName),
              CLit (CIntc m),
              cvar (ename++"_p")]

    relToMaxTestAC :: QName -> Relationship -> CExpr
    relToMaxTestAC (s,eName) (Relationship _ [REnd e1 _ _, REnd e2 _ c2]) =
      relToMaxTestC (s,eName)
                    (cardMaximum c2)
                    (combineIds [e1,e2,"Key"])         
                    e2        
    relToMaxTestBC :: QName -> Relationship -> CExpr
    relToMaxTestBC (s,eName) (Relationship _ [REnd e1 _ c1, REnd e2 _ _]) =
      relToMaxTestC (s,eName)
                    (cardMaximum c1)
                    (combineIds [e2,e1,"Key"])         
                    e1
    relToMaxTestC :: QName -> Int -> String -> String -> CExpr
    relToMaxTestC (s,eName) m attrName eN =
      let en = lowerFirst eN in
      applyF (erdgen "maxTestC")
             [string2ac eN,
              CSymbol (s,en++"Entry"),
              CSymbol (s,"keytuple2"++eN),
              CSymbol (s,en++attrName),
              CLit (CIntc m), 
              applyF (s, lowerFirst eName ++ "Key")
                     [cvar (lowerFirst eName++"_p")]]

    dupKeyTest :: QName -> CExpr
    dupKeyTest (s,eName) = 
      applyF (erdgen "duplicateKeyTest")
             [CSymbol (s, lowerFirst eName ++"Entry")]

    relToMinTestA :: QName -> Relationship -> CExpr
    relToMinTestA (s,eName) (Relationship rn [REnd e1 _ _, REnd e2 _ c2]) =
      relToMinTest (s,eName)
                   (cardMinimum c2)
                   (combineIds [e1,if null rn then e2 else rn,"Key"])
                   e2
    relToMinTestB :: QName -> Relationship -> CExpr
    relToMinTestB (s,eName) (Relationship rn [REnd e1 _ c1, REnd e2 _ _]) =
      relToMinTest (s,eName)
                   (cardMinimum c1)
                   (combineIds [e2,if null rn then e1 else rn,"Key"])
                   e1
    relToMinTest :: QName -> Int -> String -> String -> CExpr
    relToMinTest (s,eName) m attrName eN =
      let en = lowerFirst eN in
      applyF (erdgen "minTestC")
             [string2ac eN,
              CSymbol (s,en++"Entry"),
              CSymbol (s,"keytuple2"++eN),
              CSymbol (s,en++attrName),
              CLit (CIntc m), 
              applyF (s, lowerFirst eName ++ "Key")
                     [cvar (lowerFirst eName++"_p")]]


------------------------------------------------------------------
-- Generation of dynamic predicates for relationships
rel2code :: Option -> String -> [Entity] -> Relationship -> [CFuncDecl]
rel2code option name es r = 
  if isGeneratedR r 
  then rolesR option name r es
  else roles name r

isGeneratedR (Relationship n _) = n == ""

--generierte Beziehung als Teil der Umsetzung einer n:m Beziehung
--Pfeil zeigt auf generierte Entitaet, also steht der Rollenname immer im 2. REnd
-- bei (Exactly i), i>1, i Parameter fuer die Fremdschluessel
rolesR :: Option -> String -> Relationship -> [Entity] -> [CFuncDecl]
rolesR option name (Relationship _ [REnd e1 _ _, REnd e2 r2 c2]) es =
  let e = head (filter (\en -> isEntityNamed e2 en) es)
      (f1,f2) = (nthFK 1 e, nthFK 2 e)
      exactly = case c2 of Exactly i -> i>1
                           _         -> False
      rolecmt = "Dynamic predicate representing role \""++r2++"\"."
  in
  if exactly
  then
   if isSQLite option
   then [] -- TODO: add some implementation for SQLite database
           -- (e.g., instead of Dynamic, implement a Query for this task)
   else let i = exact c2
            f = if f1 == e1 then f2 else f1
        in
        [cmtfunc rolecmt
          (name, r2) (i+1) Public 
          ((baseType (name, e1++"Key")) 
             ~> (foldr (\a b -> a ~> b)
                      (baseType (db "Dynamic"))
                      (replicate i (baseType (name, f++"Key")))))  
          [simpleRule (cpvar "key" : map (cpvar . ("key"++) . show) [1..i])
              (applyF (db "|>")
                 [foldr1 (\a b -> applyF (db "<>") [a,b])
                         (map ((\k -> applyF (name, lowerFirst e2)
                                             [k, cvar "key"]) . 
                                    cvar . ("key"++) . show) 
                              [1..i]),
                  foldr1 (\a b -> applyF (pre "&&") [a,b]) 
                         (map (\ (a,b) -> 
                                  applyF (pre "/=") 
                                         (map (cvar . ("key"++) . show) [a,b]))
                              [(a,b) | a <- [1..i], b <- [a ..i], a /= b])])]]
  else if (f1 == e1)
       then [cmtfunc rolecmt (name,r2) 2 Public
              ((baseType (name, f1 ++ "Key")) ~> (baseType (name, f2 ++ "Key"))
                 ~> (baseType (db "Dynamic")))
              [simpleRule [] (CSymbol (name, lowerFirst e2))]]
       else [cmtfunc rolecmt (name,r2) 2 Public
              ((baseType (name, f2 ++ "Key")) ~> (baseType (name, f1 ++ "Key"))
                 ~> (baseType (db "Dynamic")))
              [simpleRule []
                     (applyF (pre "flip") [CSymbol (name, lowerFirst e2)])]]
  where
    exact (Exactly i) = i      
    
    nthFK :: Int -> Entity -> EName
    nthFK _ (Entity _ []) = error "Keine Fremdschluessel mehr vorhanden"
    nthFK nth (Entity n ((Attribute _ t  _ _):attrs)) = 
       case t of KeyDom ename -> if nth == 1 
                                 then ename
                                 else nthFK (nth-1) (Entity n attrs)
                 _            -> nthFK nth (Entity n attrs)
          
    

-- generate code for a relationship that is implemented by a foreign key
roles :: String -> Relationship -> [CFuncDecl]
roles name (Relationship rname [REnd en1 role1 range1, REnd en2 role2 range2]) =
  let rtype = entityKeyType (name,en1) ~> entityKeyType (name,en2)
               ~> baseType (db "Dynamic")
      len1 = lowerFirst en1
      len2 = lowerFirst en2
  in
  [cmtfunc
    ("Dynamic predicate representing the "++rname++" relation\nbetween "++
     en1++" entities and "++en2++" entities.")
    (name, lowerFirst rname) 2 Public rtype
    [CRule
     [cpvar "key1", cpvar "key2"]
     (CGuardedRhs
      [if isExactRange range1
       then (applyF (pre "=:=")
               [applyF (name,len2 ++ combineIds [en1,rname,"Key"]) [cvar "en"],
                (if isNullRange range1 then applyJust else id) (cvar "key1")],
             applyF (name,len2++"Entry")
               [applyF (name,len2++"KeyToKey") [cvar "key2"],
                applyF (name,len2++"2tuple")   [cvar "en"]])
       else (applyF (pre "=:=")
               [applyF (name,len1 ++ combineIds [en2,rname,"Key"]) [cvar "en"],
                (if isNullRange range2 then applyJust else id) (cvar "key2")],
             applyF (name,len1++"Entry")
               [applyF (name,len1++"KeyToKey") [cvar "key1"],
                applyF (name,len1++"2tuple")   [cvar "en"]])]
      [CLocalVars [(1,"en")]])],  -- where en free
   cmtfunc
     ("Dynamic predicate representing role \""++role2++"\".")
     (name, role2) 2 Public rtype
     [simpleRule [] (CSymbol (name, lowerFirst rname))],    
   cmtfunc
    ("Dynamic predicate representing role \""++role2++"\".")
     (name, role1) 2 Public
     (entityKeyType (name,en2) ~> entityKeyType (name,en1)
        ~> (baseType (db "Dynamic")))
     [simpleRule [] (applyF (pre "flip") [CSymbol (name, role2)])]]
 where
  isNullRange range = case range of
    (Between 0 _) -> True
    _             -> False
    
  isExactRange range = case range of
    (Exactly _) -> True
    _           -> False          

relationshipsForEntityName :: String -> [Relationship] -> [Relationship]
relationshipsForEntityName ename rels = filter endsIn rels
 where
  endsIn (Relationship _ ends) = any (\ (REnd n _ _) -> ename == n) ends

-- all attributes are foreign keys
isGenerated :: Entity -> Bool
isGenerated (Entity _ attrs) = length (filter (not . isForeignKey) attrs) == 0

notPKey :: Attribute -> Bool
notPKey (Attribute _ _ k _) = k /= PKey


attrType :: Attribute -> CTypeExpr         -- Null: Maybe
attrType (Attribute _ t k False) =
  case t of (IntDom _)       -> if k==PKey 
                                then baseType (erdgen "Key") 
                                else intType
            (FloatDom _)     -> floatType
            (StringDom _ )   -> stringType
            (BoolDom _)      -> boolType
            (DateDom _)      -> baseType ("Time","CalendarTime")
            (UserDefined s _)-> baseType (userMod s)
            (KeyDom _)       -> baseType (erdgen "Key")
            _                -> intType
attrType (Attribute _ t k True) = 
  case t of (IntDom _)       -> if k==PKey 
                                then maybeType (baseType (erdgen "Key"))
                                else maybeType intType
            (FloatDom _)     -> maybeType floatType
             -- string null values are not handles as Maybe types
            (StringDom _ )   -> stringType
            (BoolDom _)      -> maybeType boolType
            (DateDom _)      -> maybeType (baseType ("Time","CalendarTime"))
            (UserDefined s _)-> maybeType (baseType (userMod s))
            (KeyDom _)       -> maybeType (baseType (erdgen "Key"))
            _                -> maybeType intType


-------------------------------------------------------------------------------
-- Generation of operations for global consistency tests

checkAll :: String -> [Entity] -> CFuncDecl
checkAll name es = 
  cmtfunc "Checks the consistency of the complete database."
          (name, "checkAllData") 0 Public
          transactType
          [simpleRule [] (seqTrans (map (checkFunction name) es))]

checkFunction :: String -> Entity -> CExpr
checkFunction name (Entity en _) = CSymbol (name, "check"++en)


checkEntity :: String -> Entity -> CFuncDecl
checkEntity name (Entity en _) =
  cmtfunc ("Checks the consistency of the database for "++en++" entities.")
        (name, "check"++en) 0 Public
        transactType
        [simpleRule []
            (applyF (db "|>>=")
                    [applyF (db "getDB")
                            [applyF (db "allDBKeyInfos")
                                    [CSymbol (name, lowerFirst en++"Entry")]],
                     applyF (pre ".")
                       [applyF (db "mapT_")
                               [CSymbol (name, "check"++en++"Entry")],
                        applyF (pre "map")
                          [applyF (pre "uncurry")
                                  [CSymbol (name, "keytuple2"++en)]]]])]

checkEntry :: String -> Entity -> [Entity] -> [Relationship] -> CFuncDecl
checkEntry name entity@(Entity en _) es rs =
  let e = lowerFirst en
      t = if (isGenerated entity)
          then generatedEntityTests name entity
          else tests (name, en) es rs Consistency
      argvar = e++"_p"
      arginrhs = any (containsCVar argvar) t
  in
  cfunc (name, "check"++en++"Entry") 1 Private
        ((baseType (name,en)) ~> transactType)
        [simpleRule [cpvar (if arginrhs then argvar else "_")]
                    (if null t then constF (db "returnT")
                               else seqTrans t)]

generatedEntityTests :: String -> Entity -> [CExpr]
generatedEntityTests name (Entity en [Attribute a1 (KeyDom d1) _ _, 
                                      Attribute a2 (KeyDom d2) _ _]) =
  let e = lowerFirst en
  in
  [existsDBKeyCall (name,d1)
                   (Just (applyF (name, e++a1) [cvar (e++"_p")])),
   existsDBKeyCall (name,d2) 
                   (Just (applyF (name, e++a2) [cvar (e++"_p")])),
   applyF (erdgen "unique2C")
          [CSymbol (name, e++"Entry"),
           applyF (name,lowerFirst d1 ++ "KeyToKey")
                  [applyF (name, e++a1) [cvar (e++"_p")]],
           applyF (name,lowerFirst d2 ++ "KeyToKey")
                  [applyF (name, e++a2) [cvar (e++"_p")]]]]


-------------------------------------------------------------------------------
-- functions for saving and restoring all data

saveAll :: String -> [Entity] -> [Entity] -> CFuncDecl
saveAll name entities relentities = 
  cmtfunc ("Saves the complete database as Curry terms.\n"++
           "The first argument is the directory where the term files should be stored.")
   (name, "saveAllData") 0 Public
   (stringType ~> ioType unitType)
   [simpleRule [cpvar "path"]
               (CDoExpr (map CSExpr (map saveFunction
                                         (entities ++ relentities))))]
 where
  saveFunction (Entity en _) =
    applyF (erdgen "saveDBTerms")
           [cvar "path",
            string2ac en,
            CSymbol (name, lowerFirst en++"Entry"),
            CSymbol (name, "keytuple2"++en)]

restoreAll :: String -> [Entity] -> [Entity] -> CFuncDecl
restoreAll name entities relentities = 
  cmtfunc ("Restore the complete database from files containing Curry terms.\n"++
     "The first argument is the directory where the term files are stored.")
    (name, "restoreAllData") 0 Public
    (stringType ~> ioType unitType)
    [simpleRule [cpvar "path"]
                (CDoExpr (map CSExpr (map restoreFunction entities ++
                                          map rRestoreFunction relentities)))]
 where
  restoreFunction (Entity en _) = let e = lowerFirst en in
    applyF (erdgen "restoreDBTerms")
           [cvar "path",
            string2ac en,
            CSymbol (name,e++"Entry"),
            applyF (pre ".") [CSymbol (name,e++"KeyToKey"),
                              CSymbol (name,e++"Key")],
            CSymbol (name,e++"2tuple")]

  rRestoreFunction (Entity en _) = let e = lowerFirst en in
    applyF (erdgen "restoreDBRelTerms")
           [cvar "path",
            string2ac en,
            CSymbol (name,e++"Entry"),
            CSymbol (name,e++"2tuple")]


---------------------------------------------------------------
-- Auxiliary operations on ERD structures
---------------------------------------------------------------

-- Is the attribute domain a string domain?
isStringDom :: Domain -> Bool
isStringDom dom = case dom of
                   StringDom _ -> True
                   _           -> False

-- Has an attribute domain a default value?
hasDefault :: Domain -> Bool
hasDefault (KeyDom    _) = False
hasDefault (IntDom    d) = isJust d
hasDefault (FloatDom  d) = isJust d
hasDefault (StringDom d) = isJust d
hasDefault (BoolDom   d) = isJust d
hasDefault (DateDom   d) = isJust d
hasDefault (UserDefined _ d) = isJust d

-- Get the default value of the attribute domain:
getDefault (IntDom    (Just d)) = CLit (CIntc d)
getDefault (FloatDom  (Just d)) = CLit (CFloatc d)
getDefault (StringDom (Just d)) = string2ac d
getDefault (BoolDom   (Just d)) =
  CSymbol (pre (if d then "True" else "False"))
getDefault (DateDom   (Just _)) = error "Date default not yet implemented!"
getDefault (UserDefined _ (Just _)) =
  error "UserDefined default not yet implemented!"

--- Checks a range property in a relationship for left entity.
isRelWithRangeForEntityA :: (Cardinality->Bool) -> EName -> Relationship -> Bool
isRelWithRangeForEntityA isc e (Relationship _ [REnd e1 _ _, REnd _ _ c2]) =
  e==e1 && isc c2

--- Checks a range property in a relationship for right entity.
isRelWithRangeForEntityB :: (Cardinality->Bool) -> EName -> Relationship -> Bool
isRelWithRangeForEntityB isc e (Relationship _ [REnd _ _ c1, REnd e2 _ _]) =
  e==e2 && isc c1

--- Is a cardinality with a maximum that must be checked?
isFiniteRange :: Cardinality -> Bool
isFiniteRange card = case card of Between _ Infinite -> False
                                  _                  -> True
    
--- Is a cardinality with a minimum that must be checked?
isMinRange :: Cardinality -> Bool
isMinRange card = case card of Exactly i   -> i>1
                               Between j _ -> j>0

---------------------------------------------------------------
-- Auxiliary functions for AbstractCurry
---------------------------------------------------------------

x :: CPattern
x = CPVar (1,"x")

xn :: Int -> CPattern
xn i = CPVar (1,"x"++(show i))

nix :: CPattern
nix = CPVar (1,"_")

--- Construct type "Transaction ()"
transactType :: CTypeExpr
transactType = CTCons transTC [unitType]

-- Construct the key type for an entity from a qualified entitiy name.
entityKeyType :: QName -> CTypeExpr
entityKeyType (modname,ename) = baseType (modname, ename ++ "Key")

-- A symbol from module Database.
db :: String -> QName
db f = (keyDatabaseMod, f)

-- Extract a qualified string into a QName:
userMod :: String -> QName
userMod name = let (modname,rname) = break (=='.') name
                in if null rname then ("Prelude",name)
                                 else (modname,tail rname)

transTC :: QName
transTC = db "Transaction"

erdgen :: String -> QName
erdgen f = ("ERDGeneric", f)

lowerFirst :: String -> String
lowerFirst [] = []
lowerFirst (y:ys) = (toLower y) : ys

-- does an expression contain a variable with a given name?
containsCVar :: String -> CExpr -> Bool
containsCVar v cexp = case cexp of
  CVar (_,n)   -> v==n
  CLit _       -> False
  CSymbol _    -> False
  CApply e1 e2 -> containsCVar v e1 ||  containsCVar v e2
  CLambda _ e  -> containsCVar v e -- we ingore shadowing for simplicity
  _            -> True -- for simplicity we ignore the other case
                       -- since they don't occur in our context

-- AbstractCurry call to existsDBKey for an entity and a last key argument:
existsDBKeyCall :: QName -> Maybe CExpr -> CExpr
existsDBKeyCall (mname,eName) Nothing =
  let ename = lowerFirst eName
   in CLambda [cpvar "x"]
        (applyF (erdgen "existsEntryWithDBKey")
                [string2ac eName,
                 CSymbol (mname,ename++"Entry"),
                 applyF (mname,ename++"KeyToKey") [cvar "x"]])
existsDBKeyCall (mname,eName) (Just lastarg) =
  let ename = lowerFirst eName
   in applyF (erdgen "existsEntryWithDBKey")
             [string2ac eName,
              CSymbol (mname,ename++"Entry"),
              applyF (mname,ename++"KeyToKey") [lastarg]]

-- Sequential composition of a non-empty list of AbstractCurry calls with "|>>"
seqTrans :: [CExpr] -> CExpr
seqTrans = foldr1 (\a b -> applyF (db "|>>") [a,b])