{-# OPTIONS_GHC -fno-enable-rewrite-rules #-} -- Disable rewrite rules to drastically improve compilation speed {-# LANGUAGE FlexibleContexts #-} module Database.Design.Ampersand.Input.ADL1.Parser (AmpParser, pContext, pPopulations,pTerm, pRule, keywordstxt, keywordsops, specialchars, opchars) where import Database.Design.Ampersand.Input.ADL1.UU_Scanner ( Token(..),TokenType(..),noPos , pKey,pConid,pString,pSpec,pExpl,pVarid,pComma,pSemi) import UU.Parsing hiding (Parser) import Database.Design.Ampersand.Basics import Database.Design.Ampersand.Core.ParseTree import Data.List import Data.Maybe fatal :: Int -> String -> a fatal = fatalMsg "Input.ADL1.Parser" type AmpParser a = AnaParser [Token] Pair Token (Maybe Token) a -- The Ampersand scanner takes the file name (String) for documentation and error messaging. -- scanner :: String -> String -> [Token] -- scanner fn str = scan keywordstxt keywordsops specialchars opchars fn initPos str keywordstxt :: [String] keywordstxt = [ "INCLUDE" , "CONTEXT", "ENDCONTEXT", "EXTENDS", "THEMES" , "META" , "PATTERN", "ENDPATTERN" , "PROCESS", "ENDPROCESS" , "INTERFACE", "CLASS", "FOR", "BOX", "ROWS", "TABS", "COLS", "INITIAL", "SQLPLUG", "PHPPLUG", "TYPE" , "POPULATION", "CONTAINS" , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "AUT", "PROP", "ALWAYS" , "RULE", "MESSAGE", "VIOLATION", "SRC", "TGT", "TEST" , "RELATION", "MEANING", "CONCEPT", "IDENT" , "VIEW", "ENDVIEW", "DEFAULT", "TXT", "PRIMHTML", "TEMPLATE" , "KEY" -- HJO, 20130605: Obsolete. Only useful as long as the old prototype generator is still in use. , "IMPORT", "SPEC", "ISA", "IS", "I", "V" , "CLASSIFY" , "PRAGMA", "PURPOSE", "IN", "REF", "ENGLISH", "DUTCH" , "REST", "HTML", "LATEX", "MARKDOWN" , "ONE" , "BYPLUG" , "ROLE", "EDITS", "MAINTAINS" ] keywordsops :: [String] keywordsops = [ "|-", "-", "->", "<-", "=", "~", "+", "*", ";", "!", "#", "::", ":", "\\/", "/\\", "\\", "/", "<>" , "..", "." , "0", "1"] specialchars :: String specialchars = "()[],{}<>" opchars :: String opchars = nub (sort (concat keywordsops)) --to parse files containing only populations pPopulations :: AmpParser [P_Population] pPopulations = pList1 pPopulation pContext :: AmpParser (P_Context, [String]) -- the result is the parsed context and a list of include filenames pContext = rebuild <$> pKey_pos "CONTEXT" <*> pConceptName <*> pLanguageRef <*> pMaybe pTextMarkup <*> pList pContextElement <* pKey "ENDCONTEXT" where rebuild :: Origin -> String -> Lang -> Maybe PandocFormat -> [ContextElement] -> (P_Context, [String]) rebuild pos' nm lang fmt ces = (PCtx{ ctx_nm = nm , ctx_pos = [pos'] , ctx_lang = lang , ctx_markup = fmt , ctx_thms = (nub.concat) [xs | CThm xs<-ces] -- Names of patterns/processes to be printed in the functional specification. (For partial documents.) , ctx_pats = [p | CPat p<-ces] -- The patterns defined in this context , ctx_PPrcs = [p | CPrc p<-ces] -- The processes as defined by the parser , ctx_rs = [p | CRul p<-ces] -- All user defined rules in this context, but outside patterns and outside processes , ctx_ds = [p | CRel p<-ces] -- The relations defined in this context, outside the scope of patterns , ctx_cs = [c ("CONTEXT "++nm) | CCon c<-ces] -- The concept definitions defined in this context, outside the scope of patterns , ctx_gs = [g | CGen g<-ces] -- The gen definitions defined in this context, outside the scope of patterns , ctx_ks = [k | CIndx k<-ces] -- The identity definitions defined in this context, outside the scope of patterns , ctx_rrules = [] -- TODO: Allow MAINTAINS statements in the context , ctx_rrels = [] -- TODO: Allow EDITS statements in the context , ctx_vs = [v | CView v<-ces] -- The view definitions defined in this context, outside the scope of patterns , ctx_ifcs = [s | Cifc s<-ces] -- The interfaces defined in this context, outside the scope of patterns -- fatal 78 ("Diagnostic: "++concat ["\n\n "++show ifc | Cifc ifc<-ces]) , ctx_sql = [p | CSqlPlug p<-ces] -- user defined sqlplugs, taken from the Ampersand scriptplug<-ces] , ctx_php = [p | CPhpPlug p<-ces] -- user defined phpplugs, taken from the Ampersand script , ctx_ps = [e | CPrp e<-ces] -- The purposes defined in this context, outside the scope of patterns , ctx_pops = [p | CPop p<-ces] -- The populations defined in this contextplug<-ces] , ctx_metas = [meta | CMeta meta <-ces] } , [s | CIncl s<-ces]) -- the INCLUDE filenames pContextElement :: AmpParser ContextElement pContextElement = CMeta <$> pMeta <|> CPat <$> pPatternDef <|> CPrc <$> pProcessDef <|> CRul <$> pRuleDef <|> CCfy <$> pClassify <|> CRel <$> pRelationDef <|> CCon <$> pConceptDef <|> CGen <$> pGenDef <|> CIndx <$> pIndex <|> CView <$> pViewDef <|> Cifc <$> pInterface <|> CSqlPlug <$> pSqlplug <|> CPhpPlug <$> pPhpplug <|> CPrp <$> pPurpose <|> CPop <$> pPopulation <|> CThm <$> pPrintThemes <|> CIncl <$> pIncludeStatement data ContextElement = CMeta Meta | CPat P_Pattern | CPrc P_Pattern | CRul (P_Rule TermPrim) | CCfy P_Gen | CRel P_Declaration | CCon (String->ConceptDef) | CGen P_Gen | CIndx P_IdentDef | CView P_ViewDef | Cifc P_Interface | CSqlPlug P_ObjectDef | CPhpPlug P_ObjectDef | CPrp PPurpose | CPop P_Population | CThm [String] -- a list of themes to be printed in the functional specification. These themes must be PATTERN or PROCESS names. | CIncl String -- an INCLUDE statement pIncludeStatement :: AmpParser String pIncludeStatement = pKey "INCLUDE" *> pString pLanguageRef :: AmpParser Lang pLanguageRef = pKey "IN" *> (( Dutch <$ pKey "DUTCH" ) <|> ( English <$ pKey "ENGLISH") ) pTextMarkup :: AmpParser PandocFormat pTextMarkup = ( ReST <$ pKey "REST" ) <|> ( HTML <$ pKey "HTML" ) <|> ( LaTeX <$ pKey "LATEX" ) <|> ( Markdown <$ pKey "MARKDOWN" ) pMeta :: AmpParser Meta pMeta = Meta <$> pKey_pos "META" <*> pMetaObj <*> pString <*> pString where pMetaObj = pSucceed ContextMeta -- for the context meta we don't need a keyword pPatternDef :: AmpParser P_Pattern pPatternDef = rebuild <$> pKey_pos "PATTERN" <*> pConceptName -- The name spaces of patterns, processes and concepts are shared. <*> pList pPatElem <*> pKey_pos "ENDPATTERN" where rebuild :: Origin -> String -> [PatElem] -> Origin -> P_Pattern rebuild pos' nm pes end = P_Pat { pt_nm = nm , pt_pos = pos' , pt_end = end , pt_rls = [r | Pr r<-pes] , pt_gns = [g | Pg g<-pes] , pt_dcs = [d | Pd d<-pes] , pt_RRuls = [] -- TODO: Add P_RoleRule to Pattern , pt_RRels = [] -- TODO: Add P_RoleRelation to Pattern , pt_cds = [c nm | Pc c<-pes] , pt_ids = [k | Pk k<-pes] , pt_vds = [v | Pv v<-pes] , pt_xps = [e | Pe e<-pes] , pt_pop = [p | Pp p<-pes] } pPatElem :: AmpParser PatElem pPatElem = Pr <$> pRuleDef <|> Py <$> pClassify <|> Pd <$> pRelationDef <|> Pc <$> pConceptDef <|> Pg <$> pGenDef <|> Pk <$> pIndex <|> Pv <$> pViewDef <|> Pe <$> pPurpose <|> Pp <$> pPopulation data PatElem = Pr (P_Rule TermPrim) | Py P_Gen | Pd P_Declaration | Pc (String->ConceptDef) | Pg P_Gen | Pk P_IdentDef | Pv P_ViewDef | Pe PPurpose | Pp P_Population pProcessDef :: AmpParser P_Pattern pProcessDef = rebuild <$> pKey_pos "PROCESS" <*> pConceptName -- The name spaces of patterns, processes and concepts are shared. <*> pList pProcElem <*> pKey_pos "ENDPROCESS" where rebuild :: Origin -> String -> [ProcElem] -> Origin -> P_Pattern rebuild pos' nm pes end = P_Pat { pt_nm = nm , pt_pos = pos' , pt_end = end , pt_rls = [rr | PrR rr<-pes] , pt_gns = [g | PrG g <-pes] , pt_dcs = [d | PrD d <-pes] , pt_RRuls = [rr | PrM rr<-pes] , pt_RRels = [rr | PrL rr<-pes] , pt_cds = [cd nm | PrC cd<-pes] , pt_ids = [ix | PrI ix<-pes] , pt_vds = [vd | PrV vd<-pes] , pt_xps = [e | PrE e <-pes] , pt_pop = [p | PrP p <-pes] } pProcElem :: AmpParser ProcElem pProcElem = PrR <$> pRuleDef <|> PrY <$> pClassify <|> PrD <$> pRelationDef <|> PrM <$> pRoleRule <|> PrL <$> pRoleRelation <|> PrC <$> pConceptDef <|> PrG <$> pGenDef <|> PrI <$> pIndex <|> PrV <$> pViewDef <|> PrE <$> pPurpose <|> PrP <$> pPopulation data ProcElem = PrR (P_Rule TermPrim) | PrY P_Gen | PrD P_Declaration | PrM P_RoleRule | PrL P_RoleRelation | PrC (String->ConceptDef) | PrG P_Gen | PrI P_IdentDef | PrV P_ViewDef | PrE PPurpose | PrP P_Population pClassify :: AmpParser P_Gen -- Example: CLASSIFY A IS B /\ C /\ D pClassify = rebuild <$> pKey_pos "CLASSIFY" <*> pConceptRef <* pKey "IS" <*> pCterm where rebuild po lhs rhs = P_Cy { gen_spc = lhs -- Left hand side concept expression , gen_rhs = rhs -- Right hand side concept expression , gen_fp = po } pCterm = f <$> pList1Sep (pKey "/\\") pCterm1 pCterm1 = g <$> pConceptRef <|> h <$> (pSpec '(' *> pCterm <* pSpec ')') -- brackets are allowed for educational reasons. f ccs = concat ccs g c = [c] h cs = cs pRuleDef :: AmpParser (P_Rule TermPrim) pRuleDef = rebuild <$> pKey_pos "RULE" <*> pMaybe (pADLid <* pKey ":" ) <*> pRule <*> pList pMeaning <*> pList pMessage <*> pMaybe pViolation where rebuild po mn rexp mean msg mViolation = P_Ru { rr_nm = fromMaybe (rulid po) mn , rr_exp = rexp , rr_fps = po , rr_mean = mean , rr_msg = msg , rr_viol = mViolation } rulid (FileLoc(FilePos (_,Pos l _,_))) = "rule@line"++show l rulid _ = fatal 226 "pRuleDef is expecting a file location." pViolation :: AmpParser (PairView (Term TermPrim)) pViolation = id <$ pKey "VIOLATION" <*> pPairView pPairView :: AmpParser (PairView (Term TermPrim)) pPairView = PairView <$ pSpec '(' <*> pList1Sep (pSpec ',') pPairViewSegment <* pSpec ')' pPairViewSegment :: AmpParser (PairViewSegment (Term TermPrim)) pPairViewSegment = rebuildSrc <$> pKey_pos "SRC" <*> pTerm <|> rebuildTgt <$> pKey_pos "TGT" <*> pTerm <|> PairViewText <$> pKey_pos "TXT" <*> pString where rebuildSrc p t = PairViewExp p Src t rebuildTgt p t = PairViewExp p Tgt t pRelationDef :: AmpParser P_Declaration pRelationDef = ( rebuild <$> pVarid <*> pKey_pos "::" <*> pConceptRef <*> pFun <*> pConceptRef <|> rbd <$> pKey_pos "RELATION" <*> pVarid <*> pSign ) <*> ((True <$ pKey "BYPLUG") `opt` False) <*> (pProps `opt` []) <*> ((True <$ pKey "BYPLUG") `opt` False) <*> (pPragma `opt` []) <*> pList pMeaning <*> ((pKey "=" *> pContent) `opt` []) <* (pKey "." `opt` "") -- in the syntax before 2011, a dot was required. This optional dot is there to save user irritation during the transition to a dotless era :-) . where rebuild nm pos' src fun' trg bp1 props --bp2 pragma meanings content = rbd pos' nm (P_Sign src trg) bp1 props' --bp2 pragma meanings content where props'= nub (props `uni` fun') rbd pos' nm sgn bp1 props bp2 pragma meanings content = P_Sgn { dec_nm = nm , dec_sign = sgn , dec_prps = props , dec_prL = head pr , dec_prM = pr!!1 , dec_prR = pr!!2 , dec_Mean = meanings , dec_popu = content , dec_fpos = pos' , dec_plug = bp1 || bp2 } where pr = pragma++["","",""] pProps :: AmpParser [Prop] pProps = (f.concat) <$> (pSpec '[' *> pListSep (pSpec ',') pProp <* pSpec ']') where f ps = nub (ps ++ concat [[Uni, Inj] | null ([Sym, Asy]>-ps)]) pProp :: AmpParser [Prop] pProp = k [Uni] "UNI" <|> k [Inj] "INJ" <|> k [Sur] "SUR" <|> k [Tot] "TOT" <|> k [Sym] "SYM" <|> k [Asy] "ASY" <|> k [Trn] "TRN" <|> k [Rfx] "RFX" <|> k [Irf] "IRF" <|> k [Aut] "AUT" <|> k [Sym, Asy] "PROP" where k obj str = f <$> pKey str where f _ = obj pPragma :: AmpParser [String] pPragma = pKey "PRAGMA" *> pList1 pString pFun :: AmpParser [Prop] pFun = [] <$ pKey "*" <|> [Uni,Tot] <$ pKey "->" <|> [Sur,Inj] <$ pKey "<-" <|> (rbld <$ pSpec '[' <*> (pMult (Sur,Inj) `opt` []) <* pKey "-" <*> (pMult (Tot,Uni) `opt` []) <* pSpec ']' ) where pMult :: (Prop,Prop) -> AmpParser [Prop] pMult (ts,ui) = rbld <$> (( [] <$ pKey "0") <|> ([ts] <$ pKey "1") ) <* pKey ".." <*> (( [ui] <$ pKey "1") <|> ([] <$ pKey "*" )) <|> [] <$ pKey "*" <|> [ts,ui] <$ pKey "1" rbld a b = a++b pConceptDef :: AmpParser (String->ConceptDef) pConceptDef = Cd <$> pKey_pos "CONCEPT" <*> pConceptName -- the concept name <*> ((True <$ pKey "BYPLUG") `opt` False) <*> pString -- the definition text <*> ((pKey "TYPE" *> pString) `opt` "") -- the type of the concept. <*> (pString `opt` "") -- a reference to the source of this definition. pGenDef :: AmpParser P_Gen pGenDef = rebuild <$> pKey_pos "SPEC" <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|> -- SPEC is obsolete syntax. Should disappear! rebuild <$> pKey_pos "CLASSIFY" <*> pConceptRef <* pKey "ISA" <*> pConceptRef <|> pClassify where rebuild p spc gen = PGen{gen_spc=spc, gen_gen=gen, gen_fp =p} -- | A identity definition looks like: IDENT onNameAdress : Person(name, address), -- which means that name<>name~ /\ address<>addres~ |- I[Person]. -- The label 'onNameAddress' is used to refer to this identity. -- You may also use an expression on each attribute place, for example: IDENT onpassport: Person(nationality, passport;documentnr), -- which means that nationality<>nationality~ /\ passport;documentnr<>(passport;documentnr)~ |- I[Person]. pIndex :: AmpParser P_IdentDef pIndex = identity <$ pKey "IDENT" <*> pLabel <*> pConceptRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pIndSegment <* pSpec ')' where identity :: Label -> (P_Concept, Origin) -> [P_IdentSegment] -> P_IdentDef identity (Lbl nm _ _) (c, orig) ats = P_Id { ix_pos = orig , ix_lbl = nm , ix_cpt = c , ix_ats = ats } pIndSegment :: AmpParser P_IdentSegment pIndSegment = P_IdentExp <$> pIndAtt pIndAtt :: AmpParser P_ObjectDef pIndAtt = attL <$> pLabelProps <*> pTerm <|> att <$> pTerm where attL (Lbl nm p strs) attexpr = P_Obj { obj_nm = nm , obj_pos = p , obj_ctx = attexpr , obj_mView = Nothing , obj_msub = Nothing , obj_strs = strs } att attexpr = P_Obj { obj_nm = "" , obj_pos = Origin "pIndAtt CC664" , obj_ctx = attexpr , obj_mView = Nothing , obj_msub = Nothing , obj_strs = [] } pViewDef :: AmpParser P_ViewDef pViewDef = pFancyViewDef <|> pViewDefLegacy -- introduces a bit of harmless backtracking, but is more elegant than rewriting pViewDefLegacy to disallow "KEY ... ENDVIEW". pFancyViewDef :: AmpParser P_ViewDef pFancyViewDef = mkViewDef <$ pKey "VIEW" <*> pLabel <*> pConceptOneRefPos <*> pMaybe (pKey "DEFAULT") <* pSpec '{' <*> pList1Sep (pSpec ',') pViewObj <* pSpec '}' <*> pMaybe pHtmlView <* pKey "ENDVIEW" where mkViewDef :: Label -> (P_Concept, Origin) -> Maybe String -> [P_ObjectDef] -> Maybe ViewHtmlTemplate -> P_ViewDef mkViewDef (Lbl nm _ _) (c, orig) mDefault objs mHtml = P_Vd { vd_pos = orig , vd_lbl = nm , vd_cpt = c , vd_isDefault = isJust mDefault , vd_html = mHtml , vd_ats = map P_ViewExp objs } pViewObj :: AmpParser P_ObjectDef pViewObj = mkObj <$> pLabel <*> pTerm where mkObj (Lbl nm p strs) attexpr = P_Obj { obj_nm = nm , obj_pos = p , obj_ctx = attexpr , obj_mView = Nothing , obj_msub = Nothing , obj_strs = strs -- will always be [] } pHtmlView :: AmpParser ViewHtmlTemplate pHtmlView = ViewHtmlTemplateFile <$ pKey "HTML" <* pKey "TEMPLATE" <*> pString -- | A view definition looks like: -- VIEW onSSN: Person("social security number":ssn) -- or -- VIEW SaveAdlFile: SaveAdlFile(PRIMHTML "", filename/\V[SaveAdlFile*FileName], PRIMHTML "") -- which can be used to define a proper user interface by assigning labels and markup to the attributes in a view. pViewDefLegacy :: AmpParser P_ViewDef pViewDefLegacy = vd <$ (pKey "VIEW" <|> pKey "KEY") <*> pLabelProps <*> pConceptOneRefPos <* pSpec '(' <*> pList1Sep (pSpec ',') pViewSegment <* pSpec ')' where vd :: Label -> (P_Concept, Origin) -> [P_ViewSegment] -> P_ViewDef vd (Lbl nm _ _) (c, orig) ats = P_Vd { vd_pos = orig , vd_lbl = nm , vd_cpt = c , vd_isDefault = True -- Legacy view defs are always assumed to be the default (only one is allowed) , vd_html = Nothing , vd_ats = [ case viewSeg of P_ViewExp x -> if null (obj_nm x) then P_ViewExp $ x{obj_nm="seg_"++show i} else P_ViewExp x P_ViewText _ -> viewSeg P_ViewHtml _ -> viewSeg | (i,viewSeg) <- zip [(1::Integer)..] ats] } -- counter is used to name anonymous segments (may skip numbers because text/html segments are also counted) pViewSegment :: AmpParser P_ViewSegment pViewSegment = P_ViewExp <$> pViewAtt <|> P_ViewText <$ pKey "TXT" <*> pString <|> P_ViewHtml <$ pKey "PRIMHTML" <*> pString pViewAtt :: AmpParser P_ObjectDef pViewAtt = rebuild <$> pMaybe pLabelProps <*> pTerm where rebuild mLbl attexpr = case mLbl of Just (Lbl nm p strs) -> P_Obj { obj_nm = nm , obj_pos = p , obj_ctx = attexpr , obj_mView = Nothing , obj_msub = Nothing , obj_strs = strs } Nothing -> P_Obj { obj_nm = "" , obj_pos = origin attexpr , obj_ctx = attexpr , obj_mView = Nothing , obj_msub = Nothing , obj_strs = [] } pInterface :: AmpParser P_Interface pInterface = lbl <$> (pKey "INTERFACE" *> pADLid_val_pos) <*> (pMaybe $ pKey "CLASS" *> (pConid <|> pString)) <*> -- the class is an upper-case identifier or a quoted string (pParams `opt` []) <*> -- a list of expressions, which say which relations are editable within this service. -- either Prel _ nm -- or PNamedRel _ nm sgn (pArgs `opt` []) <*> (pRoles `opt` []) <*> (pKey ":" *> pTerm) <*> pSubInterface where lbl :: (String, Origin) -> Maybe String -> [P_NamedRel] -> [[String]] -> [Role] -> (Term TermPrim) -> P_SubInterface -> P_Interface lbl (nm,p) iclass params args roles expr sub = P_Ifc { ifc_Name = nm , ifc_Class = iclass , ifc_Params = params , ifc_Args = args , ifc_Roles = roles , ifc_Obj = P_Obj { obj_nm = nm , obj_pos = p , obj_ctx = expr , obj_mView = Nothing , obj_msub = Just sub , obj_strs = args } , ifc_Pos = p , ifc_Prp = "" --TODO: Nothing in syntax defined for the purpose of the interface. } pParams = pSpec '(' *> pList1Sep (pSpec ',') pNamedRel <* pSpec ')' pArgs = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid) <* pSpec '}' pRoles = pKey "FOR" *> pList1Sep (pSpec ',') pRole pSubInterface :: AmpParser P_SubInterface pSubInterface = (\(o,cl) objs -> P_Box o cl objs) <$> pBoxKey <*> pBox <|> (\(n,p) -> P_InterfaceRef p n) <$ pKey "INTERFACE" <*> pADLid_val_pos where pBoxKey :: AmpParser (Origin, Maybe String) pBoxKey = (\o mCl -> (o,mCl)) <$> pKey_pos "BOX" <*> pMaybe (pSpec '<' *> pConid <* pSpec '>') <|> (\o -> (o,Just "ROWS")) <$> pKey_pos "ROWS" <|> (\o -> (o,Just "COLS")) <$> pKey_pos "COLS" <|> (\o -> (o,Just "TABS")) <$> pKey_pos "TABS" pObjDef :: AmpParser P_ObjectDef pObjDef = obj <$> pLabelProps <*> pTerm -- the context expression (for example: I[c]) <*> pMaybe (pSpec '<' *> pConid <* pSpec '>') <*> pMaybe pSubInterface -- the optional subinterface where obj (Lbl nm pos' strs) expr mView msub = P_Obj { obj_nm = nm , obj_pos = pos' , obj_ctx = expr , obj_mView = mView , obj_msub = msub , obj_strs = strs } pBox :: AmpParser [P_ObjectDef] pBox = pSpec '[' *> pList1Sep (pSpec ',') pObjDef <* pSpec ']' pSqlplug :: AmpParser P_ObjectDef pSqlplug = pKey_pos "SQLPLUG" *> pObjDef pPhpplug :: AmpParser P_ObjectDef pPhpplug = pKey_pos "PHPPLUG" *> pObjDef pPurpose :: AmpParser PPurpose pPurpose = rebuild <$> pKey_pos "PURPOSE" -- "EXPLAIN" has become obsolete <*> pRef2Obj <*> pMaybe pLanguageRef <*> pMaybe pTextMarkup <*> ((pKey "REF" *> (pList1Sep pSemi pString)) `opt` []) <*> pExpl where rebuild :: Origin -> PRef2Obj -> Maybe Lang -> Maybe PandocFormat -> [String] -> String -> PPurpose rebuild orig obj lang fmt refs str = PRef2 orig obj (P_Markup lang fmt str) (concatMap (splitOn ";") refs) where splitOn :: Eq a => [a] -> [a] -> [[a]] splitOn [] s = [s] splitOn s t = case findIndex (isPrefixOf s) (tails t) of Nothing -> [t] Just i -> [take i t] ++ splitOn s (drop (i+length s) t) pRef2Obj :: AmpParser PRef2Obj pRef2Obj = PRef2ConceptDef <$ pKey "CONCEPT" <*> pConceptName <|> PRef2Declaration <$ pKey "RELATION" <*> pNamedRel <|> PRef2Rule <$ pKey "RULE" <*> pADLid <|> PRef2IdentityDef <$ pKey "IDENT" <*> pADLid <|> PRef2ViewDef <$ pKey "VIEW" <*> pADLid <|> PRef2Pattern <$ pKey "PATTERN" <*> pADLid <|> PRef2Pattern <$ pKey "PROCESS" <*> pADLid <|> PRef2Interface <$ pKey "INTERFACE" <*> pADLid <|> PRef2Context <$ pKey "CONTEXT" <*> pADLid pPopulation :: AmpParser P_Population pPopulation = prelpop <$> pKey_pos "POPULATION" <*> pNamedRel <* pKey "CONTAINS" <*> pContent <|> pcptpop <$> pKey_pos "POPULATION" <*> pConceptName <* pKey "CONTAINS" <*> (pSpec '[' *> pListSep pComma pString <* pSpec ']') where prelpop :: Origin -> P_NamedRel -> Pairs -> P_Population prelpop orig (PNamedRel _ nm mSgn) contents = case mSgn of Nothing -> P_RelPopu { p_rnme = nm , p_orig = orig , p_popps = contents } Just sgn -> P_TRelPop { p_rnme = nm , p_type = sgn , p_orig = orig , p_popps = contents } pcptpop :: Origin -> String -> [String] -> P_Population pcptpop orig cnm contents = P_CptPopu { p_cnme = cnm , p_orig = orig , p_popas = contents } pRoleRelation :: AmpParser P_RoleRelation pRoleRelation = rr <$> pKey_pos "ROLE" <*> pList1Sep (pSpec ',') pRole <* pKey "EDITS" <*> pList1Sep (pSpec ',') pNamedRel where rr p roles rels = P_RR roles rels p pRoleRule :: AmpParser P_RoleRule pRoleRule = rr <$> pKey_pos "ROLE" <*> pList1Sep (pSpec ',') pRole <* pKey "MAINTAINS" <*> pList1Sep (pSpec ',') pADLid where rr p roles rulIds = Maintain roles rulIds p pRole :: AmpParser Role pRole = Role <$> pADLid pPrintThemes :: AmpParser [String] pPrintThemes = pKey "THEMES" *> pList1Sep (pSpec ',') pConceptName -- Patterns, processes and concepts share the same name space, so these names must be checked whether the processes and patterns exist. pMeaning :: AmpParser PMeaning pMeaning = rebuild <$ pKey "MEANING" <*> pMaybe pLanguageRef <*> pMaybe pTextMarkup <*> (pString <|> pExpl) where rebuild :: Maybe Lang -> Maybe PandocFormat -> String -> PMeaning rebuild lang fmt mkup = PMeaning (P_Markup lang fmt mkup) pMessage :: AmpParser PMessage pMessage = rebuild <$ pKey "MESSAGE" <*> pMaybe pLanguageRef <*> pMaybe pTextMarkup <*> (pString <|> pExpl) where rebuild :: Maybe Lang -> Maybe PandocFormat -> String -> PMessage rebuild lang fmt mkup = PMessage (P_Markup lang fmt mkup) {- Basically we would have the following expression syntax: pRule ::= pTrm1 "=" pTerm | -- equivalence pTrm1 "|-" pTerm | -- implication or subset pTrm1 . pTerm ::= pList1Sep "/\\" pTrm2 | -- intersection pList1Sep "\\/" pTrm2 | -- union pTrm2 . pTrm2 ::= pTrm3 "-" pTrm3 | -- set difference pTrm3 . pTrm3 ::= pTrm4 "\\" pTrm4 | -- right residual pTrm4 "/" pTrm4 | -- left residual pTrm4 . pTrm4 ::= pList1Sep ";" pTrm5 | -- composition (semicolon) pList1Sep "!" pTrm5 | -- relative addition (dagger) pList1Sep "#" pTrm5 | -- cartesian product (asterisk) pTrm5 . pTrm5 ::= "-" pTrm6 | -- unary complement pTrm6 pSign | -- unary type cast pTrm6 "~" | -- unary flip pTrm6 "*" | -- unary Kleene star pTrm6 "+" | -- unary Kleene plus pTrm6 . pTrm6 ::= pRelation | "(" pTerm ")" . In practice, we have it a little different. - In order to avoid "associative" brackets, we parse the associative operators "\/", "/\", ";", and "!" with pList1Sep. That works. - We would like the user to disambiguate between "=" and "|-" by using brackets. -} {- In theory, the expression is parsed by: pRule :: AmpParser (Term TermPrim) pRule = fEequ <$> pTrm1 <*> pKey_pos "=" <*> pTerm <|> fEimp <$> pTrm1 <*> pKey_pos "|-" <*> pTerm <|> pTrm1 where fequ lExp orig rExp = PEqu orig lExp rExp fEimp lExp orig rExp = PImp orig lExp rExp -- However elegant, this solution needs to be left-factored in order to get a performant parser. -} pRule :: AmpParser (Term TermPrim) pRule = pTerm (fEqu <$> pKey_pos "=" <*> pTerm <|> fImpl <$> pKey_pos "|-" <*> pTerm ) where fEqu orig rExp lExp = PEqu orig lExp rExp fImpl orig rExp lExp = PImp orig lExp rExp {- pTrm1 is slightly more complicated, for the purpose of avoiding "associative" brackets. The idea is that each operator ("/\\" or "\\/") can be parsed as a sequence without brackets. However, as soon as they are combined, brackets are needed to disambiguate the combination. There is no natural precedence of one operator over the other. Brackets are enforced by parsing the subexpression as pTrm5. In order to maintain performance standards, the parser is left factored. The functions pars and f have arguments 'combinator' and 'operator' only to avoid writing the same code twice. -} pTerm :: AmpParser (Term TermPrim) pTerm = pTrm2 (f PIsc <$> pars PIsc "/\\" <|> f PUni <$> pars PUni "\\/") where pars combinator operator = g <$> pKey_pos operator <*> pTrm2 <*> pMaybe (pars combinator operator) where g orig y Nothing = (orig, y) g orig y (Just (org,z)) = (orig, combinator org y z) f combinator (orig, y) x = combinator orig x y -- The left factored version of difference: (Actually, there is no need for left-factoring here, but no harm either) pTrm2 :: AmpParser (Term TermPrim) pTrm2 = pTrm3 (f <$> pKey_pos "-" <*> pTrm3) where f orig rExp lExp = PDif orig lExp rExp -- The left factored version of right- and left residuals: pTrm3 :: AmpParser (Term TermPrim) pTrm3 = pTrm4 (fLrs <$> pKey_pos "/" <*> pTrm4 <|> fRrs <$> pKey_pos "\\" <*> pTrm4 <|> fDia <$> pKey_pos "<>" <*> pTrm4 ) where fLrs orig rExp lExp = PLrs orig lExp rExp fRrs orig rExp lExp = PRrs orig lExp rExp fDia orig rExp lExp = PDia orig lExp rExp {- by the way, a slightly different way of getting exactly the same result is: pTrm3 :: AmpParser (Term TermPrim) pTrm3 = pTrm4 (f <$> (pKey_val_pos "/" <|> pKey_val_pos "\\" <|> pKey_val_pos "<>") <*> pTrm4 ) where f ("\\", orig) rExp lExp = PRrs orig lExp rExp f ("/" , orig) rExp lExp = PLrs orig lExp rExp f (_ , orig) rExp lExp = PDia orig lExp rExp -} -- composition and relational addition are associative, and parsed similar to union and intersect... pTrm4 :: AmpParser (Term TermPrim) pTrm4 = pTrm5 (f PCps <$> pars PCps ";" <|> f PRad <$> pars PRad "!" <|> f PPrd <$> pars PPrd "#") where pars combinator operator = g <$> pKey_pos operator <*> pTrm5 <*> pMaybe (pars combinator operator) where g orig y Nothing = (orig, y) g orig y (Just (org,z)) = (orig, combinator org y z) f combinator (orig, y) x = combinator orig x y pTrm5 :: AmpParser (Term TermPrim) pTrm5 = f <$> pList (pKey_val_pos "-") <*> pTrm6 <*> pList ( pKey_val_pos "~" <|> pKey_val_pos "*" <|> pKey_val_pos "+" ) where f ms pe (("~",_):ps) = let x=f ms pe ps in PFlp (origin x) x -- the type checker requires that the origin of x is equal to the origin of its converse. f ms pe (("*",orig):ps) = PKl0 orig (f ms pe ps) -- e* Kleene closure (star) f ms pe (("+",orig):ps) = PKl1 orig (f ms pe ps) -- e+ Kleene closure (plus) f (_:_:ms) pe ps = f ms pe ps -- -e complement (unary minus) f ((_,orig):ms) pe ps = let x=f ms pe ps in PCpl orig x -- the type checker requires that the origin of x is equal to the origin of its complement. f _ pe _ = pe pTrm6 :: AmpParser (Term TermPrim) pTrm6 = (Prim <$> pRelationRef) <|> PBrk <$> pSpec_pos '(' <*> pTerm <* pSpec ')' pRelationRef :: AmpParser TermPrim pRelationRef = PNamedR <$> pNamedRel <|> pid <$> pKey_pos "I" <*> pMaybe (pSpec '[' *> pConceptOneRef <* pSpec ']') <|> pfull <$> pKey_pos "V" <*> pMaybe pSign <|> singl <$> pAtom_val_pos <*> pMaybe (pSpec '[' *> pConceptOneRef <* pSpec ']') where pid orig Nothing = PI orig pid orig (Just c)= Pid orig c pfull orig Nothing = PVee orig pfull orig (Just (P_Sign src trg)) = Pfull orig src trg singl (nm,orig) x = Patm orig nm x pNamedRel :: AmpParser P_NamedRel pNamedRel = pnamedrel <$> pVarid_val_pos <*> pMaybe pSign where pnamedrel (nm,orig) mSgn = PNamedRel orig nm mSgn pSign :: AmpParser P_Sign pSign = mkSign <$ pSpec '[' <*> pConceptOneRef <*> pMaybe (pKey "*" *> pConceptOneRef) <* pSpec ']' where mkSign :: P_Concept -> Maybe P_Concept -> P_Sign mkSign src mTgt = case mTgt of Just tgt -> P_Sign src tgt Nothing -> P_Sign src src pConceptName :: AmpParser String pConceptName = pConid <|> pString pConceptRef :: AmpParser P_Concept pConceptRef = PCpt <$> pConceptName pConceptOneRef :: AmpParser P_Concept pConceptOneRef = (P_Singleton <$ pKey "ONE") <|> pConceptRef pConceptRefPos :: AmpParser (P_Concept, Origin) pConceptRefPos = conid <$> pConid_val_pos <|> conid <$> pString_val_pos where conid :: (String, Origin) -> (P_Concept, Origin) conid (c,orig) = (PCpt c, orig) pConceptOneRefPos :: AmpParser (P_Concept, Origin) pConceptOneRefPos = singl <$> pKey_pos "ONE" <|> conid <$> pConid_val_pos <|> conid <$> pString_val_pos where singl :: Origin -> (P_Concept, Origin) singl orig = (P_Singleton, orig) conid :: (String, Origin) -> (P_Concept, Origin) conid (c,orig) = (PCpt c, orig) -- (SJ) Why does a label have (optional) strings? -- (GM) This is a binding mechanism for implementation specific properties, such as SQL/PHP plug,PHP web app,etc. -- (SJ April 15th, 2013) Since KEY has been replaced by IDENT and VIEW, there is a variant with props (pLabelProps) and one without (pLabel). pLabelProps :: AmpParser Label pLabelProps = lbl <$> pADLid_val_pos <*> (pArgs `opt` []) <* pKey_pos ":" where lbl :: (String, Origin) -> [[String]] -> Label lbl (nm,pos') strs = Lbl nm pos' strs pArgs = pSpec '{' *> pList1Sep (pSpec ',') (pList1 pADLid) <* pSpec '}' pLabel :: AmpParser Label pLabel = lbl <$> pADLid_val_pos <* pKey ":" where lbl :: (String, Origin) -> Label lbl (nm,pos') = Lbl nm pos' [] pContent :: AmpParser Pairs pContent = pSpec '[' *> pListSep pComma pRecord <* pSpec ']' <|> pSpec '[' *> pListSep (pKey ";") pRecordObs <* pSpec ']' --obsolete where pRecord = mkPair<$> pString <* pKey "*" <*> pString pRecordObs = mkPair<$ pSpec '(' <*> pString <* pComma <*> pString <* pSpec ')' --obsolete pADLid :: AmpParser String pADLid = pVarid <|> pConid <|> pString pADLid_val_pos :: AmpParser (String, Origin) pADLid_val_pos = pVarid_val_pos <|> pConid_val_pos <|> pString_val_pos pMaybe :: IsParser p s => p a -> p (Maybe a) pMaybe p = Just <$> p <|> pSucceed Nothing get_tok_pos :: Token -> Origin get_tok_pos (Tok _ _ s l f) = FileLoc(FilePos (f,l,s)) get_tok_val_pos :: Token -> (String, Origin) get_tok_val_pos (Tok _ _ s l f) = (s,FileLoc(FilePos (f,l,s))) gsym_pos :: IsParser p Token => TokenType -> String -> String -> p Origin gsym_pos kind val' val2' = get_tok_pos <$> pSym (Tok kind val' val2' noPos "") gsym_val_pos :: IsParser p Token => TokenType -> String -> String -> p (String,Origin) gsym_val_pos kind val' val2' = get_tok_val_pos <$> pSym (Tok kind val' val2' noPos "") pKey_pos :: String -> AmpParser Origin pKey_pos keyword = gsym_pos TkKeyword keyword keyword pSpec_pos :: Char -> AmpParser Origin pSpec_pos s = gsym_pos TkSymbol [s] [s] pString_val_pos, pVarid_val_pos, pConid_val_pos, pAtom_val_pos :: IsParser p Token => p (String,Origin) pString_val_pos = gsym_val_pos TkString "" "?STR?" pVarid_val_pos = gsym_val_pos TkVarid "" "?LC?" pConid_val_pos = gsym_val_pos TkConid "" "?UC?" pAtom_val_pos = gsym_val_pos TkAtom "" "" -- TODO: does not escape, i.e. 'Mario\'s Pizzas' will fail to parse pKey_val_pos :: IsParser p Token => String -> p (String,Origin) pKey_val_pos keyword = gsym_val_pos TkKeyword keyword keyword -- pSpec_val_pos :: IsParser p Token => Char -> p (String,Origin) -- pSpec_val_pos s = gsym_val_pos TkSymbol [s] [s]