module DatabaseDesign.Ampersand.Core.ParseTree (
P_Context(..)
, Meta(..)
, MetaObj(..)
, P_Process(..)
, P_RoleRelation(..)
, RoleRule(..)
, P_Pattern(..)
, P_Declaration(..)
, Term(..), TermPrim(..)
, PairView(..), PairViewSegment(..), PairViewTerm(..), PairViewSegmentTerm(..)
, SrcOrTgt(..), isSrc
, P_Rule(..)
, ConceptDef(..)
, P_Population(..)
, P_ObjectDef, P_SubInterface, P_Interface(..), P_ObjDef(..), P_SubIfc(..)
, P_IdentDef(..) , P_IdentSegment(..)
, P_ViewDef , P_ViewSegment
, P_ViewD(..) , P_ViewSegmt(..)
, PPurpose(..),PRef2Obj(..),PMeaning(..),PMessage(..)
, P_Concept(..), P_Sign(..)
, P_Gen(..)
, Lang(..)
, P_Markup(..)
, PandocFormat(..)
, Label(..)
, Prop(..), Props
, module DatabaseDesign.Ampersand.Input.ADL1.FilePos
, module DatabaseDesign.Ampersand.ADL1.Pair
, gen_concs
)
where
import DatabaseDesign.Ampersand.Input.ADL1.FilePos
import DatabaseDesign.Ampersand.Basics
import DatabaseDesign.Ampersand.ADL1.Pair (Pairs,Paire,mkPair ,srcPaire, trgPaire)
import Data.Traversable
import Data.Foldable
import Prelude hiding (foldr, sequence)
import Control.Applicative
fatal :: Int -> String -> a
fatal = fatalMsg "Core.ParseTree"
data P_Context
= PCtx{ ctx_nm :: String
, ctx_pos :: [Origin]
, ctx_lang :: Maybe Lang
, ctx_markup :: Maybe PandocFormat
, ctx_thms :: [String]
, ctx_pats :: [P_Pattern]
, ctx_PPrcs :: [P_Process]
, ctx_rs :: [(P_Rule TermPrim)]
, ctx_ds :: [P_Declaration]
, ctx_cs :: [ConceptDef]
, ctx_ks :: [P_IdentDef]
, ctx_vs :: [P_ViewDef]
, ctx_gs :: [P_Gen]
, ctx_ifcs :: [P_Interface]
, ctx_ps :: [PPurpose]
, ctx_pops :: [P_Population]
, ctx_sql :: [P_ObjectDef]
, ctx_php :: [P_ObjectDef]
, ctx_metas :: [Meta]
} deriving Show
instance Eq P_Context where
c1 == c2 = name c1 == name c2
instance Identified P_Context where
name = ctx_nm
data Meta = Meta { mtPos :: Origin
, mtObj :: MetaObj
, mtName :: String
, mtVal :: String
} deriving (Show)
data MetaObj = ContextMeta deriving Show
data P_RoleRelation
= P_RR { rr_Roles :: [String]
, rr_Rels :: [TermPrim]
, rr_Pos :: Origin
} deriving (Show)
instance Eq P_RoleRelation where rr==rr' = origin rr==origin rr'
instance Traced P_RoleRelation where
origin = rr_Pos
data P_Process
= P_Prc { procNm :: String
, procPos :: Origin
, procEnd :: Origin
, procRules :: [(P_Rule TermPrim)]
, procGens :: [P_Gen]
, procDcls :: [P_Declaration]
, procRRuls :: [RoleRule]
, procRRels :: [P_RoleRelation]
, procCds :: [ConceptDef]
, procIds :: [P_IdentDef]
, procVds :: [P_ViewDef]
, procXps :: [PPurpose]
, procPop :: [P_Population]
} deriving Show
instance Identified P_Process where
name = procNm
instance Traced P_Process where
origin = procPos
data RoleRule
= Maintain
{ mRoles :: [String]
, mRules :: [String]
, mPos :: Origin
} deriving (Eq, Show)
instance Traced RoleRule where
origin = mPos
data P_Pattern
= P_Pat { pt_nm :: String
, pt_pos :: Origin
, pt_end :: Origin
, pt_rls :: [(P_Rule TermPrim)]
, pt_gns :: [P_Gen]
, pt_dcs :: [P_Declaration]
, pt_rus :: [RoleRule]
, pt_res :: [P_RoleRelation]
, pt_cds :: [ConceptDef]
, pt_ids :: [P_IdentDef]
, pt_vds :: [P_ViewDef]
, pt_xps :: [PPurpose]
, pt_pop :: [P_Population]
} deriving (Show)
instance Identified P_Pattern where
name = pt_nm
instance Traced P_Pattern where
origin = pt_pos
data ConceptDef
= Cd { cdpos :: Origin
, cdcpt :: String
, cdplug:: Bool
, cddef :: String
, cdtyp :: String
, cdref :: String
, cdfrom:: String
} deriving (Show,Eq)
instance Traced ConceptDef where
origin = cdpos
instance Identified ConceptDef where
name = cdcpt
data P_Declaration =
P_Sgn { dec_nm :: String
, dec_sign :: P_Sign
, dec_prps :: Props
, dec_prL :: String
, dec_prM :: String
, dec_prR :: String
, dec_Mean :: [PMeaning]
, dec_popu :: Pairs
, dec_fpos :: Origin
, dec_plug :: Bool
} deriving Show
instance Eq P_Declaration where
decl==decl' = origin decl==origin decl'
instance Prelude.Ord P_Declaration where
decl `compare` decl' = origin decl `compare` origin decl'
instance Identified P_Declaration where
name = dec_nm
instance Traced P_Declaration where
origin = dec_fpos
data TermPrim
= PI Origin
| Pid Origin P_Concept
| Patm Origin String (Maybe P_Concept)
| PVee Origin
| Pfull Origin P_Concept P_Concept
| Prel Origin String
| PTrel Origin String P_Sign
deriving Show
data Term a
= Prim a
| Pequ Origin (Term a) (Term a)
| Pimp Origin (Term a) (Term a)
| PIsc Origin (Term a) (Term a)
| PUni Origin (Term a) (Term a)
| PDif Origin (Term a) (Term a)
| PLrs Origin (Term a) (Term a)
| PRrs Origin (Term a) (Term a)
| PDia Origin (Term a) (Term a)
| PCps Origin (Term a) (Term a)
| PRad Origin (Term a) (Term a)
| PPrd Origin (Term a) (Term a)
| PKl0 Origin (Term a)
| PKl1 Origin (Term a)
| PFlp Origin (Term a)
| PCpl Origin (Term a)
| PBrk Origin (Term a)
deriving (Show)
instance Functor Term where fmap = fmapDefault
instance Foldable Term where foldMap = foldMapDefault
instance Traversable Term where
traverse f' x
= case x of
Prim a -> Prim <$> f' a
Pequ o a b -> Pequ o <$> (f a) <*> (f b)
Pimp o a b -> Pimp o <$> (f a) <*> (f b)
PIsc o a b -> PIsc o <$> (f a) <*> (f b)
PUni o a b -> PUni o <$> (f a) <*> (f b)
PDif o a b -> PDif o <$> (f a) <*> (f b)
PLrs o a b -> PLrs o <$> (f a) <*> (f b)
PRrs o a b -> PRrs o <$> (f a) <*> (f b)
PDia o a b -> PDia o <$> (f a) <*> (f b)
PCps o a b -> PCps o <$> (f a) <*> (f b)
PRad o a b -> PRad o <$> (f a) <*> (f b)
PPrd o a b -> PPrd o <$> (f a) <*> (f b)
PKl0 o a -> PKl0 o <$> (f a)
PKl1 o a -> PKl1 o <$> (f a)
PFlp o a -> PFlp o <$> (f a)
PCpl o a -> PCpl o <$> (f a)
PBrk o a -> PBrk o <$> (f a)
where f = traverse f'
instance Functor P_SubIfc where fmap = fmapDefault
instance Foldable P_SubIfc where foldMap = foldMapDefault
instance Traversable P_SubIfc where
traverse _ (P_InterfaceRef a b) = pure (P_InterfaceRef a b)
traverse f (P_Box b lst) = P_Box b <$> (traverse (traverse f) lst)
instance Traced (P_SubIfc a) where
origin = si_ori
instance Functor P_ObjDef where fmap = fmapDefault
instance Foldable P_ObjDef where foldMap = foldMapDefault
instance Traversable P_ObjDef where
traverse f (P_Obj nm pos ctx msub strs)
= (\ctx' msub'->(P_Obj nm pos ctx' msub' strs)) <$>
traverse f ctx <*> traverse (traverse f) msub
instance Traced TermPrim where
origin e = case e of
PI orig -> orig
Pid orig _ -> orig
Patm orig _ _ -> orig
PVee orig -> orig
Pfull orig _ _ -> orig
Prel orig _ -> orig
PTrel orig _ _ -> orig
instance Identified TermPrim where
name e = case e of
PI _ -> "I"
Pid _ _ -> "I"
Patm _ s _ -> s
PVee _ -> "V"
Pfull _ _ _ -> "V"
Prel _ r -> r
PTrel _ r _ -> r
instance Traced a => Traced (Term a) where
origin e = case e of
Prim a -> origin a
Pequ orig _ _ -> orig
Pimp orig _ _ -> orig
PIsc orig _ _ -> orig
PUni orig _ _ -> orig
PDif orig _ _ -> orig
PLrs orig _ _ -> orig
PRrs orig _ _ -> orig
PDia orig _ _ -> orig
PCps orig _ _ -> orig
PRad orig _ _ -> orig
PPrd orig _ _ -> orig
PKl0 orig _ -> orig
PKl1 orig _ -> orig
PFlp orig _ -> orig
PCpl orig _ -> orig
PBrk orig _ -> orig
data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord)
instance Flippable SrcOrTgt where
flp Src = Tgt
flp Tgt = Src
isSrc :: SrcOrTgt -> Bool
isSrc Src = True
isSrc Tgt = False
data PairView a = PairView { ppv_segs :: [PairViewSegment a] } deriving Show
data PairViewSegment a = PairViewText String
| PairViewExp SrcOrTgt a
deriving Show
newtype PairViewTerm a = PairViewTerm (PairView (Term a))
newtype PairViewSegmentTerm a = PairViewSegmentTerm (PairViewSegment (Term a))
instance Traversable PairViewSegmentTerm where
traverse f (PairViewSegmentTerm x) = PairViewSegmentTerm <$> traverse (traverse f) x
instance Functor PairViewSegmentTerm where fmap = fmapDefault
instance Foldable PairViewSegmentTerm where foldMap = foldMapDefault
instance Traversable PairViewTerm where
traverse f (PairViewTerm x) = PairViewTerm <$> traverse (traverse f) x
instance Functor PairViewTerm where fmap = fmapDefault
instance Foldable PairViewTerm where foldMap = foldMapDefault
instance Traversable PairViewSegment where
traverse _ (PairViewText s) = pure (PairViewText s)
traverse f (PairViewExp st x) = PairViewExp st <$> f x
instance Functor PairViewSegment where fmap = fmapDefault
instance Foldable PairViewSegment where foldMap = foldMapDefault
instance Traversable PairView where
traverse f (PairView s) = PairView <$> traverse (traverse f) s
instance Functor PairView where fmap = fmapDefault
instance Foldable PairView where foldMap = foldMapDefault
data P_Rule a =
P_Ru { rr_nm :: String
, rr_exp :: (Term a)
, rr_fps :: Origin
, rr_mean :: [PMeaning]
, rr_msg :: [PMessage]
, rr_viol :: Maybe (PairView (Term a))
} deriving Show
instance Traced (P_Rule a) where
origin = rr_fps
instance Functor P_Rule where fmap = fmapDefault
instance Foldable P_Rule where foldMap = foldMapDefault
instance Traversable P_Rule where
traverse f (P_Ru nm expr fps mean msg viol)
= (\e v -> P_Ru nm e fps mean msg v) <$> traverse f expr <*> traverse (traverse (traverse f)) viol
instance Identified (P_Rule a) where
name = rr_nm
newtype PMeaning = PMeaning P_Markup
deriving Show
newtype PMessage = PMessage P_Markup
deriving Show
data P_Markup =
P_Markup { mLang :: Maybe Lang
, mFormat :: Maybe PandocFormat
, mString :: String
} deriving Show
data P_Population
= P_RelPopu { p_rnme :: String
, p_orig :: Origin
, p_popps :: Pairs
}
| P_TRelPop { p_rnme :: String
, p_type :: P_Sign
, p_orig :: Origin
, p_popps :: Pairs
}
| P_CptPopu { p_cnme :: String
, p_orig :: Origin
, p_popas :: [String]
}
deriving Show
instance Identified P_Population where
name P_RelPopu{p_rnme = nm} = nm
name P_TRelPop{p_rnme = nm} = nm
name P_CptPopu{p_cnme = nm} = nm
instance Traced P_Population where
origin = p_orig
data P_Interface =
P_Ifc { ifc_Name :: String
, ifc_Params :: [TermPrim]
, ifc_Args :: [[String]]
, ifc_Roles :: [String]
, ifc_Obj :: P_ObjectDef
, ifc_Pos :: Origin
, ifc_Prp :: String
} deriving Show
instance Identified P_Interface where
name = ifc_Name
instance Traced P_Interface where
origin = ifc_Pos
type P_SubInterface = P_SubIfc TermPrim
data P_SubIfc a
= P_Box { si_ori :: Origin
, si_box :: [P_ObjDef a] }
| P_InterfaceRef { si_ori :: Origin
, si_str :: String }
deriving (Eq, Show)
type P_ObjectDef = P_ObjDef TermPrim
data P_ObjDef a =
P_Obj { obj_nm :: String
, obj_pos :: Origin
, obj_ctx :: Term a
, obj_msub :: Maybe (P_SubIfc a)
, obj_strs :: [[String]]
} deriving (Show)
instance Eq (P_ObjDef a) where od==od' = origin od==origin od'
instance Identified (P_ObjDef a) where
name = obj_nm
instance Traced (P_ObjDef a) where
origin = obj_pos
data P_IdentDef =
P_Id { ix_pos :: Origin
, ix_lbl :: String
, ix_cpt :: P_Concept
, ix_ats :: [P_IdentSegment]
} deriving (Show)
instance Identified P_IdentDef where
name = ix_lbl
instance Eq P_IdentDef where identity==identity' = origin identity==origin identity'
instance Traced P_IdentDef where
origin = ix_pos
data P_IdentSegment
= P_IdentExp { ks_obj :: P_ObjectDef }
deriving (Eq, Show)
type P_ViewDef = P_ViewD TermPrim
data P_ViewD a =
P_Vd { vd_pos :: Origin
, vd_lbl :: String
, vd_cpt :: P_Concept
, vd_ats :: [P_ViewSegmt a]
} deriving (Show)
instance Identified (P_ViewD a) where
name = vd_lbl
instance Functor P_ViewD where fmap = fmapDefault
instance Foldable P_ViewD where foldMap = foldMapDefault
instance Traversable P_ViewD where
traverse f (P_Vd a b c d) = P_Vd a b c <$> traverse (traverse f) d
instance Functor P_ViewSegmt where fmap = fmapDefault
instance Foldable P_ViewSegmt where foldMap = foldMapDefault
instance Traversable P_ViewSegmt where
traverse f (P_ViewExp a) = P_ViewExp <$> traverse f a
traverse _ (P_ViewText a) = pure (P_ViewText a)
traverse _ (P_ViewHtml a) = pure (P_ViewHtml a)
instance Traced (P_ViewD a) where
origin = vd_pos
type P_ViewSegment = P_ViewSegmt TermPrim
data P_ViewSegmt a
= P_ViewExp { vs_obj :: P_ObjDef a }
| P_ViewText { vs_txt :: String }
| P_ViewHtml { vs_htm :: String }
deriving (Eq, Show)
data PRef2Obj = PRef2ConceptDef String
| PRef2Declaration TermPrim
| PRef2Rule String
| PRef2IdentityDef String
| PRef2ViewDef String
| PRef2Pattern String
| PRef2Process String
| PRef2Interface String
| PRef2Context String
| PRef2Fspc String
deriving Show
instance Identified PRef2Obj where
name pe = case pe of
PRef2ConceptDef str -> str
PRef2Declaration (PTrel _ nm sgn) -> nm++show sgn
PRef2Declaration (Prel _ nm) -> nm
PRef2Declaration expr -> fatal 362 ("Expression "++show expr++" should never occur in PRef2Declaration")
PRef2Rule str -> str
PRef2IdentityDef str -> str
PRef2ViewDef str -> str
PRef2Pattern str -> str
PRef2Process str -> str
PRef2Interface str -> str
PRef2Context str -> str
PRef2Fspc str -> str
data PPurpose = PRef2 { pexPos :: Origin
, pexObj :: PRef2Obj
, pexMarkup:: P_Markup
, pexRefIDs :: [String]
} deriving Show
instance Identified PPurpose where
name pe = name (pexObj pe)
instance Traced PPurpose where
origin = pexPos
data P_Concept
= PCpt{ p_cptnm :: String }
| P_Singleton
instance Identified P_Concept where
name (PCpt {p_cptnm = nm}) = nm
name P_Singleton = "ONE"
instance Show P_Concept where
showsPrec _ c = showString (name c)
data P_Sign = P_Sign {pSrc :: P_Concept, pTgt :: P_Concept }
instance Show P_Sign where
showsPrec _ sgn =
showString ( "[" ++ show (pSrc sgn)++"*"++show (pTgt sgn) ++ "]" )
data P_Gen = P_Cy{ gen_spc :: P_Concept
, gen_rhs :: [P_Concept]
, gen_fp :: Origin
}
| PGen{ gen_spc :: P_Concept
, gen_gen :: P_Concept
, gen_fp :: Origin
}
gen_concs :: P_Gen -> [P_Concept]
gen_concs (P_Cy {gen_rhs=x}) = x
gen_concs (PGen {gen_gen=x,gen_spc=y}) = [x,y]
instance Show P_Gen where
showsPrec _ g = showString ("CLASSIFY "++show (gen_spc g)++" IS "++show (gen_concs g))
instance Traced P_Gen where
origin = gen_fp
data Lang = Dutch | English deriving (Show, Eq)
data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show)
type Props = [Prop]
data Prop = Uni
| Inj
| Sur
| Tot
| Sym
| Asy
| Trn
| Rfx
| Irf
deriving (Eq,Ord)
instance Show Prop where
showsPrec _ Uni = showString "UNI"
showsPrec _ Inj = showString "INJ"
showsPrec _ Sur = showString "SUR"
showsPrec _ Tot = showString "TOT"
showsPrec _ Sym = showString "SYM"
showsPrec _ Asy = showString "ASY"
showsPrec _ Trn = showString "TRN"
showsPrec _ Rfx = showString "RFX"
showsPrec _ Irf = showString "IRF"
instance Flippable Prop where
flp Uni = Inj
flp Tot = Sur
flp Sur = Tot
flp Inj = Uni
flp x = x
data Label = Lbl { lblnm :: String
, lblpos :: Origin
, lblstrs :: [[String]]
}
instance Eq Label where
l==l' = lblnm l==lblnm l'