module DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (
A_Context(..)
, Meta(..)
, Theme(..)
, Process(..)
, Pattern(..)
, PairView(..)
, PairViewSegment(..)
, Rule(..)
, RuleType(..)
, RuleOrigin(..)
, Declaration(..)
, IdentityDef(..)
, IdentitySegment(..)
, ViewDef(..)
, ViewSegment(..)
, A_Gen(..)
, Interface(..)
, SubInterface(..)
, ObjectDef(..)
, Object(..)
, objAts
, Purpose(..)
, ExplObj(..)
, Expression(..)
, A_Concept(..)
, A_Markup(..)
, AMeaning(..)
, RoleRelation(..)
, Sign(..)
, Population(..)
, GenR
, Association(..)
, (<==>),join,meet,greatest,least,maxima,minima,sortWith
, smallerConcepts, largerConcepts, rootConcepts
, showSign
, aMarkup2String
, module DatabaseDesign.Ampersand.Core.ParseTree
, (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
)where
import qualified Prelude
import Prelude hiding (Ord(..), Ordering(..))
import DatabaseDesign.Ampersand.Basics
import DatabaseDesign.Ampersand.Core.ParseTree (MetaObj(..),Meta(..),ConceptDef,Origin(..),Traced(..),PairView(..),PairViewSegment(..),Prop,Lang,Pairs, PandocFormat, P_Markup(..), PMeaning(..), SrcOrTgt(..), isSrc)
import DatabaseDesign.Ampersand.Core.Poset (Poset(..), Sortable(..),Ordering(..),greatest,least,maxima,minima,sortWith)
import DatabaseDesign.Ampersand.Misc
import Text.Pandoc hiding (Meta)
import Data.List (intercalate,nub,delete)
fatal :: Int -> String -> a
fatal = fatalMsg "Core.AbstractSyntaxTree"
data A_Context
= ACtx{ ctxnm :: String
, ctxpos :: [Origin]
, ctxlang :: Lang
, ctxmarkup :: PandocFormat
, ctxthms :: [String]
, ctxpats :: [Pattern]
, ctxprocs :: [Process]
, ctxrs :: [Rule]
, ctxds :: [Declaration]
, ctxpopus :: [Population]
, ctxcds :: [ConceptDef]
, ctxks :: [IdentityDef]
, ctxvs :: [ViewDef]
, ctxgs :: [A_Gen]
, ctxgenconcs :: [[A_Concept]]
, ctxifcs :: [Interface]
, ctxps :: [Purpose]
, ctxsql :: [ObjectDef]
, ctxphp :: [ObjectDef]
, ctxmetas :: [Meta]
}
instance Show A_Context where
showsPrec _ c = showString (ctxnm c)
instance Eq A_Context where
c1 == c2 = name c1 == name c2
instance Identified A_Context where
name = ctxnm
data Theme = PatternTheme Pattern | ProcessTheme Process
instance Identified Theme where
name (PatternTheme pat) = name pat
name (ProcessTheme prc) = name prc
instance Traced Theme where
origin (PatternTheme pat) = origin pat
origin (ProcessTheme prc) = origin prc
data Process = Proc { prcNm :: String
, prcPos :: Origin
, prcEnd :: Origin
, prcRules :: [Rule]
, prcGens :: [A_Gen]
, prcDcls :: [Declaration]
, prcUps :: [Population]
, prcRRuls :: [(String,Rule)]
, prcRRels :: [(String,Declaration)]
, prcIds :: [IdentityDef]
, prcVds :: [ViewDef]
, prcXps :: [Purpose]
}
instance Identified Process where
name = prcNm
instance Traced Process where
origin = prcPos
data RoleRelation
= RR { rrRoles :: [String]
, rrRels :: [Declaration]
, rrPos :: Origin
}
instance Traced RoleRelation where
origin = rrPos
data Pattern
= A_Pat { ptnm :: String
, ptpos :: Origin
, ptend :: Origin
, ptrls :: [Rule]
, ptgns :: [A_Gen]
, ptdcs :: [Declaration]
, ptups :: [Population]
, ptrruls :: [(String,Rule)]
, ptrrels :: [(String,Declaration)]
, ptids :: [IdentityDef]
, ptvds :: [ViewDef]
, ptxps :: [Purpose]
}
instance Identified Pattern where
name = ptnm
instance Traced Pattern where
origin = ptpos
data A_Markup =
A_Markup { amLang :: Lang
, amFormat :: PandocFormat
, amPandoc :: [Block]
} deriving Show
data RuleOrigin = UserDefined
| Multiplicity
| Identity
deriving (Show, Eq)
data Rule =
Ru { rrnm :: String
, rrexp :: Expression
, rrfps :: Origin
, rrmean :: AMeaning
, rrmsg :: [A_Markup]
, rrviol :: Maybe (PairView Expression)
, rrtyp :: Sign
, rrdcl :: Maybe (Prop,Declaration)
, r_env :: String
, r_usr :: RuleOrigin
, isSignal :: Bool
, srrel :: Declaration
}
instance Eq Rule where
r==r' = rrnm r==rrnm r'
instance Show Rule where
showsPrec _ x
= showString $ "RULE "++ (if null (name x) then "" else name x++": ")++ show (rrexp x)
instance Traced Rule where
origin = rrfps
instance Identified Rule where
name = rrnm
instance Association Rule where
sign = rrtyp
data RuleType = Implication | Equivalence | Truth deriving (Eq,Show)
data Declaration =
Sgn { decnm :: String
, decsgn :: Sign
, decprps :: [Prop]
, decprps_calc :: Maybe [Prop]
, decprL :: String
, decprM :: String
, decprR :: String
, decMean :: AMeaning
, decfpos :: Origin
, deciss :: Bool
, decusr :: Bool
, decpat :: String
, decplug :: Bool
} |
Isn
{ detyp :: A_Concept
} |
Vs
{ decsgn :: Sign
}
instance Eq Declaration where
d@Sgn{} == d'@Sgn{} = decnm d==decnm d' && decsgn d==decsgn d'
d@Isn{} == d'@Isn{} = detyp d==detyp d'
d@Vs{} == d'@Vs{} = decsgn d==decsgn d'
_ == _ = False
instance Show Declaration where
showsPrec _ decl@Sgn{}
= showString (case decl of
Sgn{} -> name decl++showSign (sign decl)
Isn{} -> "I["++show (detyp decl)++"]"
Vs{} -> "V"++show (decsgn decl) )
showsPrec _ d@Isn{} = showString $ "Isn{detyp="++show(detyp d)++"}"
showsPrec _ d@Vs{} = showString $ "V"++showSign(decsgn d)
aMarkup2String :: A_Markup -> String
aMarkup2String a = blocks2String (amFormat a) False (amPandoc a)
data AMeaning = AMeaning { ameaMrk ::[A_Markup]} deriving Show
instance Identified Declaration where
name d@Sgn{} = decnm d
name Isn{} = "I"
name Vs{} = "V"
instance Association Declaration where
sign d = case d of
Sgn {} -> decsgn d
Isn {} -> Sign (detyp d) (detyp d)
Vs {} -> decsgn d
instance Traced Declaration where
origin d = case d of
Sgn{} -> decfpos d
_ -> OriginUnknown
data IdentityDef = Id { idPos :: Origin
, idLbl :: String
, idCpt :: A_Concept
, identityAts :: [IdentitySegment]
} deriving (Eq,Show)
instance Identified IdentityDef where
name = idLbl
instance Traced IdentityDef where
origin = idPos
data IdentitySegment = IdentityExp ObjectDef deriving (Eq, Show)
data ViewDef = Vd { vdpos :: Origin
, vdlbl :: String
, vdcpt :: A_Concept
, vdats :: [ViewSegment]
} deriving (Eq,Show)
instance Identified ViewDef where
name = vdlbl
instance Traced ViewDef where
origin = vdpos
data ViewSegment = ViewExp ObjectDef | ViewText String | ViewHtml String deriving (Eq, Show)
data A_Gen = Isa { genspc :: A_Concept
, gengen :: A_Concept
}
| IsE { genspc :: A_Concept
, genrhs :: [A_Concept]
}
instance Show A_Gen where
showsPrec _ g =
case g of
Isa{} -> showString ("CLASSIFY "++show (genspc g)++" ISA "++show (gengen g))
IsE{} -> showString ("CLASSIFY "++show (genspc g)++" IS "++intercalate " /\\ " (map show (genrhs g)))
smallerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]
smallerConcepts gens cpt
= nub$ oneSmaller ++ concatMap (smallerConcepts gens) oneSmaller
where oneSmaller = delete cpt. nub $ [ genspc g | g@Isa{}<-gens, gengen g==cpt ]++[ genspc g | g@IsE{}<-gens, cpt `elem` genrhs g ]
largerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]
largerConcepts gens cpt
= nub$ oneLarger ++ concatMap (largerConcepts gens) oneLarger
where oneLarger = delete cpt. nub $[ gengen g | g@Isa{}<-gens, genspc g==cpt ]++[ c | g@IsE{}<-gens, genspc g==cpt, c<-genrhs g ]
rootConcepts :: [A_Gen] -> [A_Concept] -> [A_Concept]
rootConcepts gens cpts = [ root | root<-nub $ [ c | cpt<-cpts, c<-largerConcepts gens cpt ] `uni` cpts
, root `notElem` [ genspc g | g@Isa{}<-gens]++[c | g@IsE{}<-gens, c<-genrhs g ]
]
data Interface = Ifc { ifcParams :: [Expression]
, ifcArgs :: [[String]]
, ifcRoles :: [String]
, ifcObj :: ObjectDef
, ifcPos :: Origin
, ifcPrp :: String
} deriving Show
instance Eq Interface where
s==s' = name s==name s'
instance Identified Interface where
name = name . ifcObj
instance Traced Interface where
origin = ifcPos
objAts :: ObjectDef -> [ObjectDef]
objAts obj
= case objmsub obj of
Nothing -> []
Just (InterfaceRef _) -> []
Just (Box _ objs) -> objs
class Object a where
concept :: a -> A_Concept
attributes :: a -> [ObjectDef]
contextOf :: a -> Expression
instance Object ObjectDef where
concept obj = target (objctx obj)
attributes = objAts
contextOf = objctx
data ObjectDef = Obj { objnm :: String
, objpos :: Origin
, objctx :: Expression
, objmsub :: Maybe SubInterface
, objstrs :: [[String]]
} deriving (Eq, Show)
instance Identified ObjectDef where
name = objnm
instance Traced ObjectDef where
origin = objpos
data SubInterface = Box A_Concept [ObjectDef] | InterfaceRef String deriving (Eq, Show)
data Purpose = Expl { explPos :: Origin
, explObj :: ExplObj
, explMarkup :: A_Markup
, explUserdefd :: Bool
, explRefIds :: [String]
}
instance Eq Purpose where
x0 == x1 = explObj x0 == explObj x1 &&
(amLang . explMarkup) x0 == (amLang . explMarkup) x1
instance Traced Purpose where
origin = explPos
data Population
= PRelPopu { popdcl :: Declaration
, popps :: Pairs
}
| PCptPopu { popcpt :: A_Concept
, popas :: [String]
} deriving Eq
data ExplObj = ExplConceptDef ConceptDef
| ExplDeclaration Declaration
| ExplRule String
| ExplIdentityDef String
| ExplViewDef String
| ExplPattern String
| ExplProcess String
| ExplInterface String
| ExplContext String
deriving (Show ,Eq)
data Expression
= EEqu (Expression,Expression)
| EImp (Expression,Expression)
| EIsc (Expression,Expression)
| EUni (Expression,Expression)
| EDif (Expression,Expression)
| ELrs (Expression,Expression)
| ERrs (Expression,Expression)
| EDia (Expression,Expression)
| ECps (Expression,Expression)
| ERad (Expression,Expression)
| EPrd (Expression,Expression)
| EKl0 Expression
| EKl1 Expression
| EFlp Expression
| ECpl Expression
| EBrk Expression
| EDcD Declaration
| EDcI A_Concept
| EEps A_Concept Sign
| EDcV Sign
| EMp1 String A_Concept
deriving (Eq,Show)
(.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.) :: Expression -> Expression -> Expression
infixl 1 .==.
infixl 1 .|-.
infixl 2 ./\.
infixl 2 .\/.
infixl 4 .-.
infixl 6 ./.
infixl 6 .\.
infixl 6 .<>.
infixl 8 .:.
infixl 8 .!.
infixl 8 .*.
l .==. r = if source l/=source r || target l/=target r then fatal 424 ("Cannot equate (with operator \"==\") expression\n "++show l++"\n with "++show r++".") else
EEqu (l,r)
l .|-. r = if source l/=source r || target l/=target r then fatal 426 ("Cannot include (with operator \"|-\") expression\n "++show l++"\n with "++show r++".") else
EImp (l,r)
l ./\. r = if source l/=source r || target l/=target r then fatal 428 ("Cannot intersect (with operator \"/\\\") expression\n "++show l++"\n with "++show r++".") else
EIsc (l,r)
l .\/. r = if source l/=source r || target l/=target r then fatal 430 ("Cannot unite (with operator \"\\/\") expression\n "++show l++"\n with "++show r++".") else
EUni (l,r)
l .-. r = if source l/=source r || target l/=target r then fatal 432 ("Cannot subtract (with operator \"-\") expression\n "++show l++"\n with "++show r++".") else
EDif (l,r)
l ./. r = if target l/=target r then fatal 434 ("Cannot residuate (with operator \"/\") expression\n "++show l++"\n with "++show r++".") else
ELrs (l,r)
l .\. r = if source l/=source r then fatal 436 ("Cannot residuate (with operator \"\\\") expression\n "++show l++"\n with "++show r++".") else
ERrs (l,r)
l .<>. r = if source l/=target r then fatal 438 ("Cannot use diamond operator \"<>\") on\n "++show l++"\n and "++show r++".") else
EDia (l,r)
l .:. r = if source r/=target l then fatal 440 ("Cannot compose (with operator \";\") expression\n "++show l++"\n with "++show r++".") else
ECps (l,r)
l .!. r = if source r/=target l then fatal 442 ("Cannot add (with operator \"!\") expression\n "++show l++"\n with "++show r++".") else
ERad (l,r)
l .*. r =
EPrd (l,r)
instance Flippable Expression where
flp expr = case expr of
EEqu (l,r) -> EEqu (flp l, flp r)
EImp (l,r) -> EImp (flp l, flp r)
EIsc (l,r) -> EIsc (flp l, flp r)
EUni (l,r) -> EUni (flp l, flp r)
EDif (l,r) -> EDif (flp l, flp r)
ELrs (l,r) -> ERrs (flp r, flp l)
ERrs (l,r) -> ELrs (flp r, flp l)
EDia (l,r) -> EDia (flp r, flp l)
ECps (l,r) -> ECps (flp r, flp l)
ERad (l,r) -> ERad (flp r, flp l)
EPrd (l,r) -> EPrd (flp r, flp l)
EFlp e -> e
ECpl e -> ECpl (flp e)
EKl0 e -> EKl0 (flp e)
EKl1 e -> EKl1 (flp e)
EBrk f -> EBrk (flp f)
EDcD{} -> EFlp expr
EDcI{} -> expr
EEps i sgn -> EEps i (flp sgn)
EDcV sgn -> EDcV (flp sgn)
EMp1{} -> expr
instance Association Expression where
sign (EEqu (l,r)) = Sign (source l) (target r)
sign (EImp (l,r)) = Sign (source l) (target r)
sign (EIsc (l,r)) = Sign (source l) (target r)
sign (EUni (l,r)) = Sign (source l) (target r)
sign (EDif (l,r)) = Sign (source l) (target r)
sign (ELrs (l,r)) = Sign (source l) (source r)
sign (ERrs (l,r)) = Sign (target l) (target r)
sign (EDia (l,r)) = Sign (source l) (target r)
sign (ECps (l,r)) = Sign (source l) (target r)
sign (ERad (l,r)) = Sign (source l) (target r)
sign (EPrd (l,r)) = Sign (source l) (target r)
sign (EKl0 e) = sign e
sign (EKl1 e) = sign e
sign (EFlp e) = flp (sign e)
sign (ECpl e) = sign e
sign (EBrk e) = sign e
sign (EDcD d) = sign d
sign (EDcI c) = Sign c c
sign (EEps _ sgn) = sgn
sign (EDcV sgn) = sgn
sign (EMp1 _ c) = Sign c c
showSign :: Association a => a -> String
showSign x = let Sign s t = sign x in "["++name s++"*"++name t++"]"
data A_Concept
= PlainConcept { cptnm :: String }
| ONE
instance Eq A_Concept where
PlainConcept{cptnm=a} == PlainConcept{cptnm=b} = a==b
ONE == ONE = True
_ == _ = False
instance Identified A_Concept where
name PlainConcept{cptnm = nm} = nm
name ONE = "ONE"
instance Show A_Concept where
showsPrec _ c = showString (name c)
data Sign = Sign A_Concept A_Concept deriving Eq
instance Show Sign where
showsPrec _ (Sign s t) =
showString ( "[" ++ show s ++ "*" ++ show t ++ "]" )
instance Association Sign where
source (Sign s _) = s
target (Sign _ t) = t
sign sgn = sgn
instance Flippable Sign where
flp (Sign s t) = Sign t s
class Association rel where
source, target :: rel -> A_Concept
source x = source (sign x)
target x = target (sign x)
sign :: rel -> Sign
isEndo :: rel -> Bool
isEndo s = source s == target s
type GenR = ( A_Concept -> A_Concept -> Ordering
, [[A_Concept]]
, [(A_Concept,A_Concept)]
, A_Concept -> A_Concept -> [A_Concept]
, A_Concept -> A_Concept -> [A_Concept]
)