ampersand-3.0.2: src/lib/DatabaseDesign/Ampersand/Fspec/ToFspec/ADL2Plug.hs
{-# OPTIONS_GHC -Wall #-}
module DatabaseDesign.Ampersand.Fspec.ToFspec.ADL2Plug
(makeGeneratedSqlPlugs
,makeUserDefinedSqlPlug
)
where
import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree hiding (sortWith)
import DatabaseDesign.Ampersand.Core.Poset as Poset hiding (sortWith)
import Prelude hiding (Ord(..))
import DatabaseDesign.Ampersand.Basics
import DatabaseDesign.Ampersand.Classes
import DatabaseDesign.Ampersand.ADL1
import DatabaseDesign.Ampersand.Fspec.Fspec
import DatabaseDesign.Ampersand.Misc
import DatabaseDesign.Ampersand.Fspec.ShowHS --for debugging
import Data.Maybe
import Data.Char
import Data.List (nub,intercalate,intersect,partition,group,delete)
import GHC.Exts (sortWith)
--import Debug.Trace
fatal :: Int -> String -> a
fatal = fatalMsg "Fspec.ToFspec.ADL2Plug"
makeGeneratedSqlPlugs :: Options
-> A_Context
-> [Expression]
-> [Declaration] -- ^ relations to be saved in generated database plugs.
-> [PlugSQL]
makeGeneratedSqlPlugs flags context totsurs entityDcls = gTables
where
vsqlplugs = [ (makeUserDefinedSqlPlug context p) | p<-ctxsql context] --REMARK -> no optimization like try2specific, because these plugs are user defined
gTables = gPlugs ++ gLinkTables
gPlugs :: [PlugSQL]
gPlugs = --trace "---\nStart makeEntityTables " $
--trace ("with "++show (length entityDcls)++" relations and "++show(length vsqlplugs)++" userdefined plugs.\n")
(makeEntityTables flags context entityDcls (gens context) (ctxgenconcs context) (relsUsedIn vsqlplugs))
-- all plugs for relations not touched by definedplugs and gPlugs
gLinkTables :: [PlugSQL]
gLinkTables = [ makeLinkTable context dcl totsurs
| dcl<-entityDcls
, Inj `notElem` multiplicities dcl
, Uni `notElem` multiplicities dcl]
-----------------------------------------
--makeLinkTable
-----------------------------------------
-- makeLinkTable creates associations (BinSQL) between plugs that represent wide tables.
-- Typical for BinSQL is that it has exactly two columns that are not unique and may not contain NULL values
--
-- this concerns relations that are not univalent nor injective, i.e. flduniq=False for both columns
-- Univalent relations and injective relations cannot be associations, because they are used as attributes in wide tables.
-- REMARK -> imagine a context with only one univalent relation r::A*B.
-- Then r can be found in a wide table plug (TblSQL) with a list of two columns [I[A],r],
-- and not in a BinSQL with a pair of columns (I/\r;r~, r)
--
-- a relation r (or r~) is stored in the trgFld of this plug
-- | Make a binary sqlplug for a relation that is neither inj nor uni
makeLinkTable :: A_Context -> Declaration -> [Expression] -> PlugSQL
makeLinkTable context dcl totsurs =
case dcl of
Sgn{}
| isInj dcl || isUni dcl
-> fatal 55 $ "unexpected call of makeLinkTable("++show dcl++"), because it is injective or univalent."
| otherwise
-> BinSQL
{ sqlname = name dcl
, columns = ( -- The source field:
Fld { fldname = concat["Src" | isEndo dcl]++name (source trgExpr)
, fldexpr = srcExpr
, fldtype = sqlTypeOf context (target srcExpr)
, flduse = if suitableAsKey (sqlTypeOf context (target srcExpr))
then ForeignKey (target srcExpr)
else PlainAttr
, fldnull = isTot trgExpr
, flduniq = isUni trgExpr
}
, -- The target field:
Fld { fldname = concat["Tgt" | isEndo dcl]++name (target trgExpr)
, fldexpr = trgExpr
, fldtype = sqlTypeOf context (target trgExpr)
, flduse = if suitableAsKey (sqlTypeOf context (target trgExpr))
then ForeignKey (target trgExpr)
else PlainAttr
, fldnull = isSur trgExpr
, flduniq = isInj trgExpr
}
)
, cLkpTbl = [] --in case of TOT or SUR you might use a binary plug to lookup a concept (don't forget to nub)
, mLkp = trgExpr
-- , sqlfpa = NO
}
_ -> fatal 90 "Do not call makeLinkTable on relations other than Sgn{}"
where
r_is_Tot = isTot dcl || dcl `elem` [ d | EDcD d <- totsurs]
r_is_Sur = isSur dcl || dcl `elem` [ d | EFlp (EDcD d) <- totsurs]
--the expr for the source of r
srcExpr
| r_is_Tot = EDcI (source dcl)
| r_is_Sur = EDcI (target dcl)
| otherwise = let er=EDcD dcl in EDcI (source dcl) ./\. (er .:. flp er)
--the expr for the target of r
trgExpr
| not r_is_Tot && r_is_Sur = flp (EDcD dcl)
| otherwise = EDcD dcl
suitableAsKey :: SqlType -> Bool
suitableAsKey st =
case st of
SQLChar{} -> True
SQLBlob -> False
SQLPass -> False
SQLSingle -> True
SQLDouble -> True
SQLText -> False
SQLuInt{} -> True
SQLsInt{} -> True
SQLId{} -> True
SQLVarchar{} -> True
SQLBool{} -> True
-----------------------------------------
--rel2fld
-----------------------------------------
-- Each relation yields one field f1 in the plug...
-- r is the relation from some kernel field k1 to f1
-- (fldexpr k1) is the relation from the plug's imaginary ID to k1
-- (fldexpr k1);r is the relation from ID to f1
-- the rule (fldexpr k1)~;(fldexpr k1);r = r holds because (fldexpr k1) is uni and sur, which means that (fldexpr k1)~;(fldexpr k1) = I
-- REMARK -> r may be tot or sur, but not inj. (fldexpr k1) may be tot.
--
-- fldnull and fldunique are based on the multiplicity of the relation (kernelpath);r from ID to (target r)
-- it is given that ID is unique and not null
-- fldnull=not(isTot (kernelpath);r)
-- flduniq=isInj (kernelpath);r
--
-- (kernel++plugAtts) defines the name space, making sure that all fields within a plug have unique names.
-- | Create field for TblSQL or ScalarSQL plugs
rel2fld :: A_Context
-> [Expression] -- ^ all relations (in the form either EDcD r, EDcI or EFlp (EDcD r)) that may be represented as attributes of this entity.
-> [Expression] -- ^ all relations (in the form either EDcD r or EFlp (EDcD r)) that are defined as attributes by the user.
-> Expression -- ^ either EDcD r, EDcI c or EFlp (EDcD r), representing the relation from some kernel field k1 to f1
-> SqlField
rel2fld context
kernel
plugAtts
e
= Fld { fldname = fldName
, fldexpr = e
, fldtype = sqlTypeOf context (target e)
, flduse =
let f expr =
case expr of
EDcI c -> if suitableAsKey (sqlTypeOf context c)
then TableKey ((not.maybenull) e) c
else PlainAttr
EDcD _ -> PlainAttr
EFlp e' -> f e'
_ -> fatal 144 ("No flduse defined for "++show expr)
in f e
, fldnull = maybenull e
, flduniq = isInj e -- all kernel fldexprs are inj
-- Therefore, a composition of kernel expr (I;kernelpath;e) will also be inj.
-- It is enough to check isInj e
}
where
fldName = case [nm | (r',nm)<-table, e==r'] of
[] -> fatal 117 $ "null names in table for e: " ++ show (e,table)
n:_ -> n
where
table :: [(Expression, String)]
table = [ entry
| cl<-eqCl (map toLower.niceidname) (kernel++plugAtts)
, entry<-if length cl==1 then [(rel,niceidname rel) |rel<-cl] else tbl cl]
tbl rs = [ entry
| cl<-eqCl (map toLower.name.source) rs
, entry<-if length cl==1
then [(rel,niceidname rel++name (source rel)) |rel<-cl]
else [(rel,niceidname rel++show i)|(rel,i)<-zip cl [(0::Int)..]]]
niceidname (EFlp x) = niceidname x
niceidname (EDcD d) = name d
niceidname (EDcI c) = name c
niceidname rel = fatal 162 ( "Unexpected relation found:\n"++
intercalate "\n "
[ "***rel:"
, show rel
, "***kernel:"
, show kernel
, "***plugAtts:"
, show plugAtts
]
)
--in a wide table, m can be total, but the field for its target may contain NULL values,
--because (why? ...)
--A kernel field may contain NULL values if
-- + its field expr is not total OR
-- + its field expr is not the identity relation AND the (kernel) field for its source may contain NULL values
--(if the fldexpr of a kernel field is the identity,
-- then the fldexpr defines the relation between this kernel field and this kernel field (fldnull=not(isTot I) and flduniq=isInj I)
-- otherwise it is the relation between this kernel field and some other kernel field)
maybenull expr
| length(map target kernel) > length(nub(map target kernel))
= fatal 146 $"more than one kernel field for the same concept:\n expr = " ++(show expr)++
intercalate "\n *** " ( "" : (map (name.target) kernel))
| otherwise = case expr of
EDcD dcl
| (not.isTot) dcl -> True
| otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isTot k || target k==target dcl && isSur k ]
EFlp (EDcD dcl)
| (not.isSur) dcl -> True
| otherwise -> (not.null) [()|k<-kernelpaths, target k==source dcl && isSur k || target k==target dcl && isTot k]
EDcI _ -> False
_ -> fatal 152 ("Illegal Plug Expression: "++show expr ++"\n"++
" ***kernel:*** \n "++
intercalate "\n " (map show kernel)++"\n"++
" ***Attributes:*** \n "++
intercalate "\n " (map show plugAtts)++"\n"++
" ***e:*** \n "++
( show e)
)
kernelpaths = clos kernel
where
-- Warshall's transitive closure algorithm, adapted for this purpose:
clos :: [Expression] -> [Expression]
clos xs
= [ foldr1 (.:.) expr | expr<-exprList ]
where
exprList :: [[Expression]]
-- SJ 20131117. The following code (exprList and f) assumes no ISA's in the A-structure. Therefore, this works due to the introduction of EEps.
exprList = foldl f [[x] | x<-nub xs]
(nub [c | c<-nub (map source xs), c'<-nub (map target xs), c==c'])
f :: [[Expression]] -> A_Concept -> [[Expression]]
f q x = q ++ [ls ++ rs | ls <- q, x == target (last ls)
, rs <- q, x == source (head rs), null (ls `isc` rs)]
-- ^ Explanation: rel is a relation from some kernel field k to f
-- ^ (fldexpr k) is the relation from the plug's ID to k
-- ^ (fldexpr k);rel is the relation from ID to f
-----------------------------------------
--makeEntityTables (formerly called: makeTblPlugs)
-----------------------------------------
{- makeEntityTables computes a set of plugs to obtain tables in a transactional database with minimal redundancy.
We call them "wide tables".
makeEntityTables computes entities with their attributes.
It is based on the principle that each concept is represented in at most one plug,
and each relation in at most one plug.
First, we determine the kernels for all plugs.
A kernel contains the concept table(s) for all concepts that are administered in the same entity.
For that, we collect all relations that are univalent, injective, and surjective (the kernel relations).
By the way, that includes all isa-relations, since they are univalent, injective, and surjective by definition.
Since isa-relations are not declared explicitly, they are generated separately.
If two concepts a and b are in the same entity, there is a concept g such that a isa g and b isa g.
Of all concepts in an entity, one most generic concept is designated as root, and is positioned in the first column of the table.
Secondly, we take all univalent relations that are not in the kernel, but depart from this kernel.
These relations serve as attributes. Code: [a| a<-attRels, source a `elem` concs kernel]
Then, all these relations are made into fields. Code: plugFields = [rel2fld plugMors a| a<-plugMors]
We also define two lookup tables, one for the concepts that are stored in the kernel, and one for the attributes of these concepts.
For the fun of it, we sort the plugs on length, the longest first. Code: sortWith ((0-).length.fields)
By the way, parameter allRels contains all relations that are declared in context, enriched with extra multiplicities.
This parameter allRels was added to makePlugs to avoid recomputation of the extra multiplicities.
The parameter exclusions was added in order to exclude certain concepts and relations from the process.
-}
-- | Generate non-binary sqlplugs for relations that are at least inj or uni, but not already in some user defined sqlplug
makeEntityTables :: Options
-> A_Context
-> [Declaration] -- ^ all relations in scope
-> [A_Gen]
-> [[A_Concept]] -- ^ concepts `belonging' together.
-- for each class<-conceptss: c,c'<-class: c `join` c' exists (although there is not necessarily a concept d=c `join` c' ...)
-> [Declaration] -- ^ relations that should be excluded, because they wil not be implemented using generated sql plugs.
-> [PlugSQL]
makeEntityTables flags context allDcls isas conceptss exclusions
= sortWith ((0-).length.plugFields)
(map kernel2Plug kernelsWithAttributes)
where
diagnostics
= "\nallDcls:" ++ concat ["\n "++showHSName r | r<-allDcls]++
"\nallDcls:" ++ concat ["\n "++showHS flags "\n " r | r<-allDcls]++
"\nconceptss:" ++ concat ["\n "++showHS flags " " cs | cs<-conceptss]++
"\nexclusions:" ++ concat ["\n "++showHSName r | r<-exclusions]++
"\nattRels:" ++ concat ["\n "++showHS flags " " e | e<-attRels]++
"\n"
-- | kernels are computed, starting with the set of concepts, on the basis of generalization tuples.
kernPartition :: [A_Gen] -> [[A_Concept]] -- ^ This function contains the recipe to derive a set of kernels from a set of isa-pairs.
kernPartition specialzs
= foldl f (group (delete ONE (concs context))) specialzs
where f disjuncLists g = concat haves : nohaves
where
(haves,nohaves) = partition (not.null.intersect (concs g)) disjuncLists
preKernels = kernPartition (gens context) -- Step 1: compute the kernels from the isa-pairs from the context
extraIsas -- Step 2: Maybe extra isa-pairs are needed to ensure that each kernel has precisely one largest concept
= concat
[ case [c | c<-kernel, null (largerConcepts isas c)] of -- determine how many concepts in one kernel are largest
[_] -> []
rs -> [ Isa{gengen=rootConcept, genspc=c} | c<-rs ]
| (rootConcept,kernel) <- zip [rc | i<-[0::Int ..]
, let rc=PlainConcept ("rootConcept"++show i)
, rc `notElem` concs context ]
preKernels
]
kernls -- Step 3: compute the kernels
= [ largerCs++[ c | c<-kernel, c `notElem` largerCs ] -- put the largest element up front
| kernel <- kernPartition (extraIsas++gens context) -- recompute the kernels with the extra isa-pairs.
, let largerCs = [c | c<-kernel, null (largerConcepts isas c)] -- get the set of largest concepts (each kernel has precisely one)
]
kernelsWithAttributes = dist attRels kernls []
where
dist :: (Association attrib, Show attrib) => [attrib] -> [[A_Concept]] -> [([A_Concept], [attrib])] -> [([A_Concept], [attrib])]
dist [] [] result = result
dist atts [] _ = fatal 246 ("No kernel found for atts: "++show atts++"\n"++diagnostics)
dist atts (kernel:ks) result = dist otherAtts ks ([(kernel,attsOfK)] ++ result)
where (attsOfK,otherAtts) = partition belongsInK atts
belongsInK att = source att `elem` kernel
-- | converts a kernel into a plug
kernel2Plug :: ([A_Concept],[Expression]) -> PlugSQL
kernel2Plug (kernel, attsAndIsaRels)
= TblSQL
{ sqlname = name (head kernel) -- ++ " !!Let op: De ISA relaties zie ik hier nergens terug!! (TODO. HJO 20131201"
, fields = map fld plugMors -- Each field comes from a relation.
, cLkpTbl = conceptLookuptable
, mLkpTbl = attributeLookuptable ++ isaLookuptable
}
where
(isaAtts,atts) = partition isISA attsAndIsaRels
where isISA (EDcI _) = True
isISA _ = False
mainkernel = map EDcI kernel
plugMors :: [Expression]
plugMors = mainkernel++atts
conceptLookuptable :: [(A_Concept,SqlField)]
conceptLookuptable = [(target r,fld r) | r <-mainkernel]
attributeLookuptable :: [(Expression,SqlField,SqlField)]
attributeLookuptable = -- kernel attributes are always surjective from left to right. So do not flip the lookup table!
[(e,lookupC (source e),fld e) | e <-plugMors]
lookupC cpt = head [f |(c',f)<-conceptLookuptable, cpt==c']
fld a = rel2fld context mainkernel atts a
isaLookuptable = [(e,lookupC (source e),lookupC (target e)) | e <- isaAtts ]
-- attRels contains all relations that will be attribute of a kernel.
-- The type is the largest possible type, which is the declared type, because that contains all atoms (also the atoms of subtypes) needed in the operation.
attRels :: [Expression]
attRels = mapMaybe attExprOf (allDcls>- exclusions)
where
attExprOf :: Declaration -> Maybe Expression
attExprOf d =
case d of --make explicit what happens with each possible decl...
Isn{} -> Nothing -- These relations are already in the kernel
Vs{} -> Nothing -- Vs are not implemented at all
Sgn{} ->
case (isInj d, isUni d, isTot d, isSur d) of
(False , False , _ , _ ) --Will become a link-table
-> Nothing
(True , False , _ , _ )
-> Just $ flp (EDcD d)
(True , True , True , False ) --Equivalent to CLASSIFY s ISA t, however, it is named, so it must be stored in a plug!
-> Just $ flp (EDcD d)
_ -> Just $ EDcD d
-----------------------------------------
--makeUserDefinedSqlPlug
-----------------------------------------
--makeUserDefinedSqlPlug is used to make user defined plugs. One advantage is that the field names and types can be controlled by the user.
--
--TODO151210 -> (see also Instance Object PlugSQL)
-- cLkpTbl TblSQL{} can have more than one concept i.e. one for each kernel field
-- a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug (i.e. fldnull=False)
-- When is an ObjectDef a ScalarPlug or BinPlug?
-- When do you want to define your own Scalar or BinPlug
--rel2fld (identities context) kernel plugAtts r
-- | Make a sqlplug from an ObjectDef (user-defined sql plug)
makeUserDefinedSqlPlug :: A_Context -> ObjectDef -> PlugSQL
makeUserDefinedSqlPlug context obj
| null(attributes obj) && isIdent(objctx obj)
= ScalarSQL { sqlname = name obj
, sqlColumn = rel2fld context [EDcI c] [] (EDcI c)
, cLkp = c
}
| null(attributes obj) --TODO151210 -> assuming objctx obj is Rel{} if it is not I{}
= fatal 2372 "TODO151210 -> implement defining binary plugs in ASCII"
| isIdent(objctx obj) --TODO151210 -> a kernel may have more than one concept that is uni,tot,inj,sur with some imaginary ID of the plug
= {- The following may be useful for debugging:
error
("\nc: "++show c++
"\nrels:"++concat ["\n "++show r | r<-rels]++
"\nkernel:"++concat ["\n "++show r | r<-kernel]++
"\nattRels:"++concat ["\n "++show e | e<-attRels]++
"\nplugfields:"++concat ["\n "++show plugField | plugField<-plugfields]
) -}
TblSQL { sqlname = name obj
, fields = plugfields
, cLkpTbl = conceptLookuptable
, mLkpTbl = attributeLookuptable
}
| otherwise = fatal 279 "Implementation expects one concept for plug object (SQLPLUG tblX: I[Concept])."
where
c -- one concept from the kernel is designated to "lead" this plug, this is user-defined.
= source(objctx obj)
rels --fields are user-defined as one deep objats with objctx=r. note: type incorrect or non-relation objats are ignored
= [(objctx att,sqltp att) | att<-attributes obj, source (objctx att)==c]
kernel --I[c] and every non-endo r or r~ which is at least uni,inj,sur are kernel fields
--REMARK -> endo r or r~ which are at least uni,inj,sur are inefficient in a way
-- if also TOT than r=I => duplicates,
-- otherwise if r would be implemented as GEN (target r) ISA C then (target r) could become a kernel field
= [(EDcI c,sqltp obj)]
++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isSur r]
++ [(r,tp) |(r,tp)<-rels,not (isEndo r),isUni r, isInj r, isTot r, not (isSur r)]
attRels --all user-defined non-kernel fields are attributes of (rel2fld context (objctx c))
= (rels >- kernel) >- [(flp r,tp) |(r,tp)<-kernel] --note: r<-rels where r=objctx obj are ignored (objctx obj=I)
plugMors = kernel++attRels
plugfields = [fld r tp | (r,tp)<-plugMors]
fld r tp = (rel2fld context (map fst kernel) (map fst attRels) r){fldtype=tp} --redefine sqltype
conceptLookuptable = [(target e,fld e tp) |(e,tp)<-kernel]
attributeLookuptable = [(er,lookupC (source er),fld er tp) | (er,tp)<-plugMors]
lookupC cpt = head [f |(c',f)<-conceptLookuptable, cpt==c']
sqltp :: ObjectDef -> SqlType
sqltp att = head $ [sqlTypeOf' sqltp' | strs<-objstrs att,('S':'Q':'L':'T':'Y':'P':'E':'=':sqltp')<-strs]
++[SQLVarchar 255]
sqlTypeOf :: A_Context -> A_Concept -> SqlType
sqlTypeOf _ ONE = SQLBool -- TODO (SJ): Martijn, why should ONE have a representation? Or should this rather be a fatal?
sqlTypeOf context c
= case nub [ cdtyp cdef | cdef<-ctxcds context, name c==name cdef ] of
[str] -> sqlTypeOf' str
[] -> sqlTypeOf' ""
_ -> fatal 396 ("Multiple SQL types defined for concept "++name c)
sqlTypeOf' :: String -> SqlType
sqlTypeOf' str = case str of
('V':'a':'r':'c':'h':'a':'r':_) -> SQLVarchar 255 --TODO number
"Pass" -> SQLPass
('C':'h':'a':'r':_) -> SQLChar 255 --TODO number
"Blob" -> SQLBlob
"Single" -> SQLSingle
"Double" -> SQLDouble
('u':'I':'n':'t':_) -> SQLuInt 4 --TODO number
('s':'I':'n':'t':_) -> SQLsInt 4 --TODO number
"Id" -> SQLId
('B':'o':'o':'l':_) -> SQLBool
"" -> SQLVarchar 255
_ -> fatal 335 ("Unknown type: "++str)