ampersand-3.0.2: src/lib/DatabaseDesign/Ampersand/Fspec/Plug.hs
{-# OPTIONS_GHC -Wall #-}
-- SJC: is it possible to move this to the prototype part of ampersand? I mean,
-- do functions like plugFields and plug-path really need to be here?
-- perhaps we can at least move the largest part?
module DatabaseDesign.Ampersand.Fspec.Plug
(Plugable(..), PlugInfo(..)
,SqlField(..)
,SqlFieldUsage(..)
,SqlType(..)
,showSQL
,requiredFields,requires,plugpath,eLkpTbl
,tblcontents
,fldauto
,isPlugIndex,kernelrels,attrels,bijectivefields
,PlugSQL(..)
)
where
import DatabaseDesign.Ampersand.ADL1
import DatabaseDesign.Ampersand.Classes (fullContents,atomsOf,Relational(..))
import DatabaseDesign.Ampersand.Basics
import Data.List(nub,transpose)
import GHC.Exts (sortWith)
import DatabaseDesign.Ampersand.Fspec.Fspec
import Prelude hiding (Ordering(..))
fatal :: Int -> String -> a
fatal = fatalMsg "Fspec.Plug"
----------------------------------------------
--Plug
----------------------------------------------
--TODO151210 -> define what a plug is and what it should do
--Plugs are of the class Object just like Activities(??? => PHP plug isn't an instance of Object)
--An Object is an entity to do things with like reading, updating, creating,deleting.
--A Interface is an Object using only Plugs for reading and writing data; a Plug is a data service maintaining the rules for one object:
-- + GEN Interface,Plug ISA Object
-- + cando::Operation*Object
-- + uses::Interface*Plug [TOT].
-- + maintains::Plug*Rule.
-- + signals::Interface*SignalRule.
--
--Plugs can currently be implemented in PHP or SQL.
--type Plugs = [Plug]
--data Plug = PlugSql PlugSQL | PlugPhp PlugPHP deriving (Show,Eq)
class (Identified p, Eq p, Show p) => Plugable p where
makePlug :: PlugInfo -> p
instance Plugable PlugSQL where
makePlug (InternalPlug p) = p
makePlug (ExternalPlug _) = fatal 112 "external plug is not Plugable"
----------------------------------------------
--PlugSQL
----------------------------------------------
--TblSQL, BinSQL, and ScalarSQL hold different entities. See their definition Fspec.hs
-- all kernel fields can be related to an imaginary concept ID for the plug (a SqlField with type=SQLID)
-- i.e. For all kernel fields k1,k2, where concept k1=A, concept k2=B, fldexpr k1=r~, fldexpr k2=s~
-- You can imagine :
-- - a relation value::ID->A[INJ] or value::ID->A[INJ,SUR]
-- - a relation value::ID->B[INJ] or value::ID->B[INJ,SUR]
-- such that s~=value~;value;r~ and r~=value~;value;s~
-- because value is at least uni,tot,inj, all NULL in k0 imply NULL in k1 xor v.v.
-- if value also sur then all NULL in k0 imply NULL in k1 and v.v.
-- Without such an ID, the surjective or total property between any two kernel fields is required.
-- Because you can imagine an ID concept the surjective or total property between two kernel field has become a design choice.
--
-- With or without ID we choose to keep kernel = A closure of concepts A,B for which there exists a r::A->B[INJ] instead of r::A*B[UNI,INJ]
-- By making this choice:
-- - nice database table size
-- - we do not need the imaginary concept ID (and relation value::ID->A[INJ] or value::ID->A[INJ,SUR]), because:
-- with ID -> there will always be one or more kernel field k1 such that (value;(fldexpr k1)~)[UNI,INJ,TOT,SUR].
-- any of those k1 can serve as ID of the plug (a.k.a. concept p / source p)
-- without ID -> any of those k1 can still serve as ID of the plug (a.k.a. concept p / source p)
-- In other words, the imaginary concept is never needed
-- because there always is an existing one with the correct properties by definition of kernel.
-- Implementation without optional ID:
-- -> fldexpr of some kernel field k1 will be r~
-- k1 holds the target of r~
-- the source of r~ is a kernel concept too
-- r~ may be I
-- -> fldexpr of some attMor field a1 will be s
-- a1 holds the target of s
-- the source of s is a kernel concept
-- -> sqlRelFields r = (r,k1,a1) (or (r,k1,k2)) in mLkpTbl
-- is used to generate SQL code and PHP-objects without needing the ID field.
-- The ID field can be ignored and does not have to be generated because r=(fldexpr k1)~;(fldexpr a1)
-- You could generate the ID-field with autonum if you want, because it will not be used
-- -> TODO151210 -> sqlRelFields e where e is not in mLkpTbl
-- option1) Generate the ID field (see entityfield)
-- sqlRelFields e = (e, idfld;k1, idfld;a1) where e=(fldexpr k1)~;value~;value;(fldexpr a1)
-- remark: binary tables can be binary tables without kernels, but with ID field
-- (or from a different perspective: ID is the only kernel field)
-- sqlRelFields r = (r,idfld/\r;r~,idfld;m1) where r = (idfld/\r;r~)~;idfld;(fldexpr m1)
-- (sqlRelFields r~ to get the target of r)
-- (scalar tables can of course also have an ID field)
-- option2) sqlRelFields e = (e, k1;k2;..kn, a1)
-- where e=(fldexpr kn)~;..;(fldexpr k2)~;(fldexpr k1)~;(fldexpr k1)(fldexpr k2);..;(fldexpr kn);(fldexpr a1)
-- If I am right the function isTrue tries to support sqlRelFields e by ignoring the type error in kn;a1.
-- That is wrong!
--the entityfield is not implemented as part of the data type PlugSQL
--It is a constant which may or may not be used (you may always imagine it)
--TODO151210 -> generate the entityfield if options = --autoid -p
--REMARK151210 -> one would expect I[entityconcept p],
-- but any p (as instance of Object) has one always existing concept p suitable to replace entityconcept p.
-- concept p and entityconcept p are related uni,tot,inj,sur.
--the entity stored in a plug is an imaginary concept, that is uni,tot,inj,sur with (concept p)
--REMARK: there is a (concept p) because all kernel fields are related SUR with (concept p)
--Maintain rule: Object ObjectDef = Object (makeUserDefinedSqlPlug :: ObjectDef -> PlugSQL)
--TODO151210 -> Build a check which checks this rule for userdefined/showADL generated plugs(::[ObjectDef])
--TODO151210 -> The ObjectDef of a BinSQL plug for relation r is that:
-- 1) SQLPLUG mybinplug: r , or
-- 2) SQLPLUG labelforsourcem : I /\ r;r~ --(or just I if r is TOT)
-- = [labelfortargetm : r]
-- The first option has been implemented in instance ObjectPlugSQL i.e. attributes=[], ctx=ERel r _
instance Object PlugSQL where
concept p = case p of
TblSQL{mLkpTbl = []} -> fatal 263 $ "empty lookup table for plug "++name p++"."
TblSQL{} -> --TODO151210-> deze functieimplementatie zou beter moeten matchen met onderstaande beschrijving
-- nu wordt aangenomen dat de source van het 1e rel in mLkpTbl de source van de plug is.
--a relation between kernel concepts r::A*B is at least [UNI,INJ]
--to be able to point out one concept to be the source we are looking for one without NULLs in its field
-- i.e. there is a concept A such that
-- for all kernel field expr (s~)::B*C[UNI,INJ]:
-- s~ is total and there exists an expr::A*B[UNI,INJ,TOT,SUR] (possibly A=B => I[A][UNI,INJ,TOT,SUR])
--If A is such a concept,
-- and A is not B,
-- and there exist an expr::A*B[UNI,INJ,TOT,SUR]
--then (concept PlugSQL{}) may be A or B
--REMARK -> (source p) used to be implemented as (source . fldexpr . head . fields) p. That is different!
head [source r |(r,_,_)<-mLkpTbl p]
BinSQL{} -> source (mLkp p) --REMARK151210 -> the concept is actually ID such that I[ID]=I[source r]/\r;r~
ScalarSQL{} -> cLkp p
-- Usually source a==concept p. Otherwise, the attribute computation is somewhat more complicated. See ADL2Fspec for explanation about kernels.
attributes p@TblSQL{}
= [ Obj (fldname tFld) -- objnm
(Origin "This object is generated by attributes (Object PlugSQL)") -- objpos
(if source a==concept p then a else f (source a) [[a]]) -- objctx
Nothing [] -- objats and objstrs
| (a,_,tFld)<-mLkpTbl p]
where
f c mms
= case sortWith length stop of
[] -> f c mms' -- a path from c to a is not found (yet), so add another step to the recursion
(hd:_) -> case hd of
[] -> fatal 201 "Empty head should be impossible."
_ -> case [(l,r) | (l,r)<-zip (init hd) (tail hd), target l/=source r] of
[] -> foldr1 (.:.) hd -- pick the shortest path and turn it into an expression.
lrs -> fatal 204 ("illegal compositions " ++show lrs)
where
mms' = if [] `elem` mms
then fatal 295 "null in mms."
else [a:ms | ms<-mms, (a,_,_)<-mLkpTbl p, target a==source (head ms)]
stop = if [] `elem` mms'
then fatal 298 "null in mms'."
else [ms | ms<-mms', source (head ms)==c] -- contains all found paths from c to a
attributes _ = [] --no attributes for BinSQL and ScalarSQL
contextOf p@BinSQL{} = mLkp p
contextOf p = EDcI (concept p)
fldauto::SqlField->Bool -- is the field auto increment?
fldauto f = (fldtype f==SQLId) && not (fldnull f) && flduniq f -- && isIdent (fldexpr f)
showSQL :: SqlType -> String
showSQL (SQLChar n) = "CHAR("++show n++")"
showSQL (SQLBlob ) = "BLOB"
showSQL (SQLPass ) = "VARCHAR(255)"
showSQL (SQLSingle ) = "FLOAT" -- todo
showSQL (SQLDouble ) = "FLOAT"
showSQL (SQLText ) = "TEXT"
showSQL (SQLuInt n) = "INT("++show n++") UNSIGNED"
showSQL (SQLsInt n) = "INT("++show n++")"
showSQL (SQLId ) = "INT"
showSQL (SQLVarchar n) = "VARCHAR("++show n++")"
showSQL (SQLBool ) = "BOOLEAN"
-- Every kernel field is a key, kernel fields are in cLkpTbl or the column of ScalarSQL (which has one column only)
-- isPlugIndex refers to UNIQUE key -- TODO: this is wrong
--isPlugIndex may contain NULL, but their key (the entityfield of the plug) must be unique for a kernel field (isPlugIndex=True)
--the field that is isIdent and isPlugIndex (i.e. concept plug), or any similar (uni,inj,sur,tot) field is also UNIQUE key
--IdentityDefs define UNIQUE key (fld1,fld2,..,fldn)
--REMARK -> a kernel field does not have to be in cLkpTbl, in that cast there is another kernel field that is
-- thus I must check whether fldexpr isUni && isInj && isSur
isPlugIndex :: PlugSQL->SqlField->Bool
isPlugIndex plug f =
case plug of
ScalarSQL{} -> sqlColumn plug==f
BinSQL{} --mLkp is not uni or inj by definition of BinSQL, if mLkp total then the (fldexpr srcfld)=I/\r;r~=I i.e. a key for this plug
| isUni(mLkp plug) || isInj(mLkp plug) -> fatal 366 "BinSQL may not store a univalent or injective rel, use TblSQL instead."
| otherwise -> False --binary does not have key, but I could do a SELECT DISTINCT iff f==fst(columns plug) && (isTot(mLkp plug))
TblSQL{} -> elem f (fields plug) && isUni(fldexpr f) && isInj(fldexpr f) && isSur(fldexpr f)
--mLkpTbl stores the relation of some target field with one source field
--an isPlugIndex target field is a kernel field related to some similar or larger kernel field
--any other target field is an attribute field related to its kernel field
kernelrels::PlugSQL ->[(SqlField,SqlField)]
kernelrels plug@ScalarSQL{} = [(sqlColumn plug,sqlColumn plug)]
kernelrels (BinSQL{}) = fatal 375 "Binary plugs do not know the concept of kernel fields."
kernelrels plug@TblSQL{} = [(sfld,tfld) |(_,sfld,tfld)<-mLkpTbl plug,isPlugIndex plug tfld]
attrels::PlugSQL ->[(SqlField,SqlField)]
attrels plug@ScalarSQL{} = [(sqlColumn plug,sqlColumn plug)]
attrels BinSQL{} = fatal 379 "Binary plugs do not know the concept of attribute fields."
attrels plug@TblSQL{} = [(sfld,tfld) |(_,sfld,tfld)<-mLkpTbl plug,not(isPlugIndex plug tfld)]
--the kernel of SqlFields is ordered by existence of elements for some instance of the entity stored in the plug.
--fldexpr of key is the relation with a similar or larger key.
--(similar = uni,tot,inj,sur, includes = uni,inj,sur)
--
--each kernel field is a key to attributes and itself (kfld), and each attribute field is related to one kernel field (kfld)
--kfld may be smaller than the ID of the plug, but larger than other kernel fields in the plug
--All (kernel) fields larger than or similar to kfld and their total attributes are required.
--(remark that the total property of an attribute points to the relation of the att with its key, which is not the ID of the plug per se)
--Smaller (kernel) fields and their total attributes may contain NULL where kfld does not and are not required.
--
--auto increment fields are not considered to be required
requiredFields :: PlugSQL -> SqlField ->[SqlField]
requiredFields plug@ScalarSQL{} _ = [sqlColumn plug]
requiredFields plug@BinSQL{} _ = [fst(columns plug),snd(columns plug)]
requiredFields plug@TblSQL{} fld
= [f |f<-requiredkeys++requiredatts, not (fldauto f)]
where
kfld | null findfld = fatal 401 $ "fld "++fldname fld++" must be in the plug "++name plug++"."
| isPlugIndex plug fld = fld
| otherwise = fst(head findfld) --fld is an attribute field, take its kernel field
findfld = [(k,maybek) |(_,k,maybek)<-mLkpTbl plug,fld==maybek]
requiredkeys = similar++requiredup
requiredatts = [a |k<-requiredkeys,(k',a)<-attrels plug,k==k',isTot(fldexpr a)]
-----------
--kernelclusters is a list of kernel field clusters clustered by similarity
--similar is the cluster where kfld is in
similar = [c |Cluster cs<-kernelclusters plug,kfld `elem` cs,c<-cs]
--the kernel fields in which a similar field is included, but not a similar field
--(clusterBy includeskey [Cluster [x]] (kernelrels plug) returns one inclusion chain (cluster) from ID to x
--Thus, similar elements of elements in the chain (except x) are not taken into account yet (see similarskeysup and requiredup)
keysup = nub[rf |x<-similar
,cs<-map cslist(clusterBy includeskey [Cluster [x]] (kernelrels plug))
,rf<-cs]
>- similar
--there can be a key1 similar to a key2 in keysup, but key1 is not in keysup.
--key1 is required just like key2 because they are similar
similarskeysup = nub[key1 | Cluster cs<-kernelclusters plug
, key1<-cs
, key2<-keysup
, key2 `elem` cs
, key1 `notElem` keysup]
--the similarskeysup may have required fields not in keysup (recursion)
--add those which are not in keysup yet
requiredup = nub(keysup++requiredbysimilarkeysup)
requiredbysimilarkeysup = nub[rf |x<-similarskeysup,rf<-requiredFields plug x]
-----------
--fld1 requires fld2 in plug?
requires :: PlugSQL -> (SqlField,SqlField) ->Bool
requires plug (fld1,fld2) = fld2 `elem` requiredFields plug fld1
composeCheck :: Expression -> Expression -> Expression
composeCheck l r
= if target l/=source r then fatal 316 ("\nl: "++show l++"with target "++show (target l)++"\nl: "++show r++"with source "++show (source r)) else
l .:. r
--composition from srcfld to trgfld, if there is an expression for that
plugpath :: PlugSQL -> SqlField -> SqlField -> Maybe Expression
plugpath p srcfld trgfld =
case p of
BinSQL{}
| srcfld==trgfld -> let tm=mLkp p --(note: mLkp p is the relation from fst to snd column of BinSQL)
in if srcfld==fst(columns p)
then Just$ tm .:. flp tm --domain of r
else Just$ flp tm .:. tm --codomain of r
| srcfld==fst(columns p) && trgfld==snd(columns p) -> Just$ fldexpr trgfld
| trgfld==fst(columns p) && srcfld==snd(columns p) -> Just$ flp(fldexpr srcfld)
| otherwise -> fatal 444 $ "BinSQL has only two fields:"++show(fldname srcfld,fldname trgfld,name p)
ScalarSQL{}
| srcfld==trgfld -> Just$ fldexpr trgfld
| otherwise -> fatal 447 $ "scalarSQL has only one field:"++show(fldname srcfld,fldname trgfld,name p)
TblSQL{}
| srcfld==trgfld && isPlugIndex p trgfld -> Just$ EDcI (target (fldexpr trgfld))
| srcfld==trgfld && not(isPlugIndex p trgfld) -> Just$ composeCheck (flp (fldexpr srcfld)) (fldexpr trgfld) --codomain of r of morAtt
| (not . null) (paths srcfld trgfld)
-> case head (paths srcfld trgfld) of
[] -> fatal 338 ("Empty head (paths srcfld trgfld) should be impossible.")
ps -> Just$ foldr1 composeCheck ps
--bijective kernel fields, which are bijective with ID of plug have fldexpr=I[X].
--thus, path closures of these kernel fields are disjoint (path closure=set of fields reachable by paths),
-- because these kernel fields connect to themselves by r=I[X] (i.e. end of path).
--connect two paths over I[X] (I[X];srce)~;(I[X];trge) => filter I[X] => srcpath~;trgpath
| (not.null) (pathsoverIs srcfld trgfld) -> Just$ foldr1 composeCheck (head (pathsoverIs srcfld trgfld))
| (not.null) (pathsoverIs trgfld srcfld) -> Just$ flp (foldr1 composeCheck (head (pathsoverIs trgfld srcfld)))
| otherwise -> Nothing
--paths from s to t by connecting r from mLkpTbl
--the (r,srcfld,trgfld) from mLkpTbl form paths longer paths if connected: (trgfld m1==srcfld m2) => (m1;m2,srcfld m1,trgfld m2)
where
paths s t = [e |(e,es,et)<-eLkpTbl p,s==es,t==et]
--paths from I to field t
pathsfromIs t = [(e,es,et) |(e,es,et)<-eLkpTbl p,et==t,not (null e),isIdent(head e)]
--paths from s to t over I[X]
pathsoverIs s t = [flpsrce++tail trge
|(srce,srces,_)<-pathsfromIs s
,(trge,trges,_)<-pathsfromIs t
,srces==trges, let flpsrce = (map flp.reverse.tail) srce]
--the expression LkpTbl of a plug is the transitive closure of the mLkpTbl of the plug
--Warshall's transitive closure algorithm clos1 :: (Eq a) => [(a,a)] -> [(a,a)] is extended to combine paths i.e. r++r'
--[Expression] implies a 'composition' from a kernel SqlField to another SqlField
--use plugpath to get the Expression from srcfld to trgfld
--plugpath also combines expressions with head I like (I;tail1)~;(I;tail2) <=> tail1;tail2
eLkpTbl::PlugSQL -> [([Expression],SqlField,SqlField)]
eLkpTbl p = clos1 [([r],s,t)|(r,s,t)<-mLkpTbl p]
where
clos1 :: [([Expression],SqlField,SqlField)] -> [([Expression],SqlField,SqlField)] -- e.g. a list of SqlField pairs
clos1 xs
= foldl f xs (nub (map (\(_,x,_)->x) xs) `isc` nub (map (\(_,_,x)->x) xs))
where
f q x = q `uni` [( r++r' , a, b') | (r ,a, b) <- q, b == x, (r', a', b') <- q, a' == x]
--bijective fields of f (incl. f)
bijectivefields::PlugSQL -> SqlField -> [SqlField]
bijectivefields p f = [bij |Cluster fs<-kernelclusters p, f `elem` fs,bij<-fs]
--the clusters of kernel sqlfields that are similar because they relate uni,inj,tot,sur
kernelclusters ::PlugSQL -> [Cluster SqlField]
kernelclusters plug@ScalarSQL{} = [Cluster [sqlColumn plug]]
kernelclusters (BinSQL{}) = [] --a binary plugs has no kernel (or at most (entityfield plug))
kernelclusters plug@TblSQL{} = clusterBy similarkey [] (kernelrels plug)
--similar key: some source key s that is not equal to target key t (i.e. not the identity), but related uni,tot,inj,sur in some other way
similarkey::(SqlField,SqlField)->Bool
similarkey (s,t) = s/=t && isTot (fldexpr t) && isSur (fldexpr t) && isInj (fldexpr t) && isUni (fldexpr t)
--includes key: some target key t that is related to source key s uni,inj,sur but not tot
includeskey::(SqlField,SqlField)->Bool
includeskey (_,t) = not(isTot (fldexpr t)) && isSur (fldexpr t) && isInj (fldexpr t) && isUni (fldexpr t)
--clusterBy clusters similar items like eqClass clusters equal items
--[(a,a)] defines flat relations between items (not closed)
--((a,a) -> Bool) defines some transitive relation between two items (for example similarity, equality, inclusion)
--[Cluster a] defines the initial set of clusters which may be []
-- EXAMPLE USE ->
-- if the relation is not symmetric and you need one chain from x to the top
-- then set [Cluster [x]]
-- (note: ClusterBy does not take into account any other relation than the one provided!)
--TODO -> test plugs that require more than one run (i.e. a composition of kernel fields n>2: ID(fld1;fld2;..;fldn)KernelConcept )
--REMARK151210 -> I have made a data type of cluster instead of just list to distinguish between lists and clusters (type checked and better readable code)
-- It is an idea to do the same for eqCl and eqClass (Class=Cluster or v.v.)
data Cluster a = Cluster [a] deriving (Eq,Show)
cslist :: Cluster a -> [a]
cslist (Cluster xs) = xs
clusterBy :: (Show a,Eq a) => ((a,a) -> Bool) -> [Cluster a] -> [(a,a)] -> [Cluster a]
clusterBy f [] xs = clusterBy f [Cluster [b] |(_,b)<-xs] xs --initial clusters, for every target there will be a cluster at first (see mergeclusters)
clusterBy f cs xs
| cs==nxtrun = mergeclusters cs
| otherwise = clusterBy f (mergeclusters nxtrun) xs
where
nxtrun = [Cluster (addtohead (head ys)++ys) |Cluster ys<-cs, not(null ys)]
addtohead y =[fst x | x<-xs, snd x==y, f x] --if x=(fst x);y and (f x), then fst x is chained to y
--we can merge clusters with equal heads, because
-- + similar things are chained to the head of the cluster
-- + and the head of mergeclusters == head of every cluster in cs' because we mergecluster each time we add one thing to the head of some cluster
mergeclusters cs' = [Cluster (nub(concat cl)) |cl<-eqClass eqhead (map cslist cs')]
eqhead c1 c2
| null (c1++c2) = fatal 547 "clusters are not expected to be empty at this point."
| otherwise = head c1==head c2
-- | tblcontents is meant to compute the contents of an entity table.
-- It yields a list of records. Values in the records may be absent, which is why Maybe String is used rather than String.
type TblRecord = [Maybe String]
tblcontents :: [A_Gen] -> [Population] -> PlugSQL -> [TblRecord]
tblcontents gens udp plug@ScalarSQL{}
= [[Just x] | x<-atomsOf gens udp (cLkp plug)]
tblcontents gens udp plug@BinSQL{}
= [[(Just . srcPaire) p,(Just . trgPaire) p] |p<-fullContents gens udp (mLkp plug)]
tblcontents gens udp plug@TblSQL{}
--TODO15122010 -> remove the assumptions (see comment data PlugSQL)
--fields are assumed to be in the order kernel+other,
--where NULL in a kernel field implies NULL in the following kernel fields
--and the first field is unique and not null
--(r,s,t)<-mLkpTbl: s is assumed to be in the kernel, fldexpr t is expected to hold r or (flp r), s and t are assumed to be different
| null(fields plug) = fatal 593 "no fields in plug."
| otherwise = transpose
( map Just cAtoms
: [case fExp of
EDcI c -> [ if a `elem` atomsOf gens udp c then Just a else Nothing | a<-cAtoms ]
_ -> [ (lkp a . fullContents gens udp) fExp | a<-cAtoms ]
| fld<-tail (fields plug), let fExp=fldexpr fld
]
)
where
cAtoms = (atomsOf gens udp . source . fldexpr . head . fields) plug
lkp a pairs
= case [ p | p<-pairs, a==srcPaire p ] of
[] -> Nothing
[p] -> Just (trgPaire p)
ps -> fatal 428 ("Multiple values in one field: "++show ps)