module DatabaseDesign.Ampersand.Core.AbstractSyntaxTree (
A_Context(..)
, Meta(..)
, Theme(..)
, Process(..)
, Pattern(..)
, PairView(..)
, PairViewSegment(..)
, Rule(..)
, RuleType(..)
, RuleOrigin(..)
, Declaration(..), decusr, deciss
, IdentityDef(..)
, IdentitySegment(..)
, ViewDef(..)
, ViewSegment(..)
, A_Gen(..)
, Interface(..)
, SubInterface(..)
, ObjectDef(..)
, objAts
, objatsLegacy
, Purpose(..)
, ExplObj(..)
, Expression(..)
, A_Concept(..)
, A_Markup(..)
, AMeaning(..)
, RoleRelation(..)
, Sign(..)
, Population(..)
, GenR
, Signaling(..)
, Association(..)
, (<==>),join,meet,greatest,least,maxima,minima,sortWith
, smallerConcepts, largerConcepts, rootConcepts
, showSign
, aMarkup2String
, insParentheses
, 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, RelConceptDef(..))
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)
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
, r_sgl :: 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
instance Signaling Rule where
isSignal = r_sgl
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
, decConceptDef :: Maybe RelConceptDef
, decfpos :: Origin
, decissX :: Bool
, decusrX :: Bool
, decISA :: Bool
, decpat :: String
, decplug :: Bool
} |
Isn
{ detyp :: A_Concept
} |
Vs
{ decsgn :: Sign
}
decusr :: Declaration -> Bool
decusr Sgn{decusrX=b}=b
decusr _ = False
deciss :: Declaration -> Bool
deciss Sgn{decissX=b}=b
deciss _ = False
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 _ d@Sgn{}
= showString (unwords (["RELATION",decnm d,show (decsgn d),show (decprps_calc d)
,"PRAGMA",show (decprL d),show (decprM d),show (decprR d)]
++concatMap showMeaning (ameaMrk (decMean d))
) )
where
showMeaning m = "MEANING"
: ["IN", show (amLang m)]
++ [show (amFormat m)]
++ ["{+",aMarkup2String m,"-}"]
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 { genfp :: Origin
, gengen :: A_Concept
, genspc :: A_Concept
}
| IsE { genfp :: Origin
, genrhs :: [A_Concept]
, genspc :: A_Concept
}
instance Show A_Gen where
showsPrec _ g@(Isa{}) = showString ("CLASSIFY "++show (genspc g)++" ISA "++show (gengen g))
showsPrec _ g@(IsE{}) = showString ("CLASSIFY "++show (genspc g)++" IS "++intercalate " /\\ " (map show $ genrhs g))
instance Traced A_Gen where
origin = genfp
smallerConcepts :: [A_Gen] -> A_Concept -> [A_Concept]
smallerConcepts gens cpt
= nub$ oneSmaller ++ concatMap (smallerConcepts gens) oneSmaller
where oneSmaller = 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 = 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{ objmsub=Nothing } = []
objAts Obj{ objmsub=Just (InterfaceRef _) } = []
objAts Obj{ objmsub=Just (Box _ objs) } = objs
objatsLegacy :: ObjectDef -> [ObjectDef]
objatsLegacy Obj{ objmsub=Nothing } = []
objatsLegacy Obj{ objmsub=Just (Box _ objs) } = objs
objatsLegacy Obj{ objmsub=Just (InterfaceRef _) } = fatal 301 $ "Using functionality that has not been extended to InterfaceRefs"
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
, explRefId :: 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]
}
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)
| 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 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 r/=target l then fatal 438 ("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 440 ("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)
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
insParentheses :: Expression -> Expression
insParentheses = insPar 0
where
wrap :: Integer -> Integer -> Expression -> Expression
wrap i j e' = if i<=j then e' else EBrk e'
insPar :: Integer -> Expression -> Expression
insPar i (EEqu (l,r)) = wrap i 0 (EEqu (insPar 1 l, insPar 1 r))
insPar i (EImp (l,r)) = wrap i 0 (EImp (insPar 1 l, insPar 1 r))
insPar i (EUni (l,r)) = wrap (i+1) 2 (EUni (insPar 2 l, insPar 2 r))
insPar i (EIsc (l,r)) = wrap (i+1) 2 (EIsc (insPar 2 l, insPar 2 r))
insPar i (EDif (l,r)) = wrap i 4 (EDif (insPar 5 l, insPar 5 r))
insPar i (ELrs (l,r)) = wrap i 6 (ELrs (insPar 7 l, insPar 7 r))
insPar i (ERrs (l,r)) = wrap i 6 (ERrs (insPar 7 l, insPar 7 r))
insPar i (ECps (l,r)) = wrap (i+1) 8 (ECps (insPar 8 l, insPar 8 r))
insPar i (ERad (l,r)) = wrap (i+1) 8 (ERad (insPar 8 l, insPar 8 r))
insPar i (EPrd (l,r)) = wrap (i+1) 8 (EPrd (insPar 8 l, insPar 8 r))
insPar _ (EKl0 e) = EKl0 (insPar 10 e)
insPar _ (EKl1 e) = EKl1 (insPar 10 e)
insPar _ (EFlp e) = EFlp (insPar 10 e)
insPar _ (ECpl e) = ECpl (insPar 10 e)
insPar i (EBrk f) = insPar i f
insPar _ e@EDcD{} = e
insPar _ e@EDcI{} = e
insPar _ e@EEps{} = e
insPar _ e@EDcV{} = e
insPar _ e@EMp1{} = e
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 (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
, cpttp :: String
, cptdf :: [ConceptDef]
}
| 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
class Signaling a where
isSignal :: a -> Bool
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]
)