diff --git a/CASL/Formula.hs b/CASL/Formula.hs index 97da5adbb7..414904f933 100644 --- a/CASL/Formula.hs +++ b/CASL/Formula.hs @@ -61,6 +61,8 @@ module CASL.Formula , qualPredName , implKey , ifKey + , orKey + , andKey ) where import Common.AnnoState diff --git a/CASL/Logic_CASL.hs b/CASL/Logic_CASL.hs index 4692c1eed9..5e7d8222b9 100644 --- a/CASL/Logic_CASL.hs +++ b/CASL/Logic_CASL.hs @@ -47,7 +47,7 @@ import CASL.OMDocExport import CASL.Freeness -- test -import CASL.Formula (formula) +import CASL.Formula (formula, primFormula) #ifdef UNI_PACKAGE import CASL.QuickCheck @@ -225,10 +225,13 @@ instance Sentences CASL CASLFORMULA CASLSign CASLMor Symbol where symmap_of CASL = morphismToSymbMap sym_name CASL = symName symKind CASL = show . pretty . symbolKind . symbType + extSymKind CASL = extSymbolKind . symbType symsOfSen CASL _ = Set.toList . foldFormula (symbolsRecord $ const Set.empty) simplify_sen CASL = simplifyCASLSen print_named CASL = printTheoryFormula + -- test nominals + is_nominal_sen CASL = isNominalSen instance StaticAnalysis CASL CASLBasicSpec CASLFORMULA SYMB_ITEMS SYMB_MAP_ITEMS @@ -237,6 +240,7 @@ instance StaticAnalysis CASL CASLBasicSpec CASLFORMULA Symbol RawSymbol where basic_analysis CASL = Just basicCASLAnalysis sen_analysis CASL = Just cASLsen_analysis + convertTheory CASL = Just convertCASLTheory stat_symb_map_items CASL = statSymbMapItems stat_symb_items CASL = statSymbItems signature_colimit CASL diag = return $ signColimit diag extCASLColimit @@ -246,13 +250,16 @@ instance StaticAnalysis CASL CASLBasicSpec CASLFORMULA qualify CASL = qualifySig symbol_to_raw CASL = symbolToRaw + raw_to_symbol CASL = rawToSymbol id_to_raw CASL = idToRaw matches CASL = CASL.Morphism.matches is_transportable CASL = isSortInjective is_injective CASL = isInjective + raw_to_var CASL = rawToVar empty_signature CASL = emptySign () add_symb_to_sign CASL = addSymbToSign + add_noms_to_sign CASL = addNomsToSign signature_union CASL s = return . addSig const s signatureDiff CASL s = return . diffSig const s @@ -275,6 +282,7 @@ instance Logic CASL CASL_Sublogics stability CASL = Stable -- for Hybridization parse_basic_sen CASL = Just $ \ _ -> formula [] + parse_prim_formula CASL = Just $ const (primFormula []) proj_sublogic_epsilon CASL = pr_epsilon () all_sublogics CASL = sublogics_all [] @@ -292,6 +300,20 @@ instance Logic CASL CASL_Sublogics addOMadtToTheory CASL = OMI.addOMadtToTheory addOmdocToTheory CASL = OMI.addOmdocToTheory syntaxTable CASL = Just . getSyntaxTable + constr_to_sens CASL = constrToSens + -- helpers for hybridization + -- for each type, its name and the file where it is defined + sublogicsTypeName CASL = ("CASL_Sublogics","CASL.Sublogic") + basicSpecTypeName CASL = ("CASLBasicSpec","CASL.Logic_CASL") + sentenceTypeName CASL = ("CASLFORMULA","CASL.AS_Basic_CASL") + symbItemsTypeName CASL = ("SYMB_ITEMS","CASL.AS_Basic_CASL") + symbMapItemsTypeName CASL = ("SYMB_MAP_ITEMS","CASL.AS_Basic_CASL") + signTypeName CASL = ("CASLSign","CASL.Sign") + morphismTypeName CASL = ("CASLMor","CASL.Morphism") + symbolTypeName CASL = ("Symbol","") + rawSymbolTypeName CASL = ("RawSymbol","CASL.Morphism") + proofTreeTypeName CASL = ("ProofTree","Common.ProofTree") + #ifdef UNI_PACKAGE provers CASL = [quickCheckProver] #endif diff --git a/CASL/Morphism.hs b/CASL/Morphism.hs index 3349458bde..c8a26a4cf3 100644 --- a/CASL/Morphism.hs +++ b/CASL/Morphism.hs @@ -49,6 +49,8 @@ module CASL.Morphism , idToRaw , typedSymbKindToRaw , symbolToRaw + , rawToSymbol + , rawToVar , insertRsys , mapSort , mapOpSym @@ -208,6 +210,17 @@ mapCASLMor e me m = symbolToRaw :: Symbol -> RawSymbol symbolToRaw = ASymbol +rawToSymbol :: RawSymbol -> Maybe Symbol +rawToSymbol (ASymbol s) = Just s +rawToSymbol (AKindedSymb k i) = + case k of + Sorts_kind -> Just $ Symbol i SortAsItemType + _ -> Nothing + +rawToVar :: RawSymbol -> Maybe (Token, Id) +rawToVar (ASymbol (Symbol n (OpAsItemType (OpType Total [] s)))) = Just (idToSimpleId n, s) +rawToVar _ = Nothing + idToRaw :: Id -> RawSymbol idToRaw = AKindedSymb Implicit diff --git a/CASL/Sign.hs b/CASL/Sign.hs index 80d6952ffd..9673a9987b 100644 --- a/CASL/Sign.hs +++ b/CASL/Sign.hs @@ -34,7 +34,7 @@ import Common.DocUtils import Data.Data import Data.Maybe (fromMaybe) import Data.List (isPrefixOf) -import Control.Monad (when, unless) +import Control.Monad (when, unless, foldM) -- constants have empty argument lists data OpType = OpType {opKind :: OpKind, opArgs :: [SORT], opRes :: SORT} @@ -81,6 +81,15 @@ symbolKind t = case t of PredAsItemType _ -> Preds_kind _ -> Sorts_kind +extSymbolKind :: SymbType -> String +extSymbolKind t = case t of + OpAsItemType (OpType k l _) -> + case (k, l) of + (Total, []) -> "const" + _ -> "op" + PredAsItemType _ -> "pred" + _ -> "sort" + data Symbol = Symbol {symName :: Id, symbType :: SymbType} deriving (Show, Eq, Ord, Typeable, Data) @@ -591,8 +600,16 @@ addSymbToSign sig sy = PredAsItemType pt -> return $ addPred' sig' n pt OpAsItemType ot -> return $ addOp' sig' n ot +addNomsToSign :: Sign e f -> Set.Set Id -> Result (Sign e f) +addNomsToSign sig noms = do + -- add a fake sort for nominals + sig0 <- addSymbToSign sig $ Symbol (genName "ST") SortAsItemType + sig' <- foldM (\aSig nom -> addSymbToSign aSig $ Symbol nom $ + PredAsItemType $ PredType []) + sig0 $ Set.toList noms + return sig' --- The function below belong in a different file. But I put them here for now. +-- TODO: The function below belong in a different file. But I put them here for now. -- dual of a quantifier dualQuant :: QUANTIFIER -> QUANTIFIER diff --git a/CASL/StaticAna.hs b/CASL/StaticAna.hs index a0f5935c77..bd4c54c3d9 100644 --- a/CASL/StaticAna.hs +++ b/CASL/StaticAna.hs @@ -54,6 +54,8 @@ import qualified Data.Set as Set import Data.Maybe import Data.List +import Logic.SemConstr + checkPlaces :: [SORT] -> Id -> [Diagnosis] checkPlaces args i = let n = placeCount i in [mkDiag Error "wrong number of places" i | n > 0 && n /= length args ] @@ -869,6 +871,14 @@ anaTerm mef mixIn sign msrt pos t = do (\ srt -> Sorted_term resT srt pos) msrt return (resT, anaT) +getAllIds :: (FormExtension f, TermExtension f) => + BASIC_SPEC b s f -> Mix b s f e -> Sign f e -> IdSets +getAllIds bs mix inSig = + unite $ ids_BASIC_SPEC (getBaseIds mix) (getSigIds mix) bs + : getExtIds mix (extendedInfo inSig) : + [mkIdSets (allConstIds inSig) (allOpIds inSig) + $ allPredIds inSig] + basicAnalysis :: (FormExtension f, TermExtension f) => Min f e -- ^ type analysis of f -> Ana b b s f e -- ^ static analysis of basic item b @@ -879,10 +889,7 @@ basicAnalysis :: (FormExtension f, TermExtension f) {- ^ (BS with analysed mixfix formulas for pretty printing, differences to input Sig,accumulated Sig,analysed Sentences) -} basicAnalysis mef anab anas mix (bs, inSig, ga) = - let allIds = unite $ ids_BASIC_SPEC (getBaseIds mix) (getSigIds mix) bs - : getExtIds mix (extendedInfo inSig) : - [mkIdSets (allConstIds inSig) (allOpIds inSig) - $ allPredIds inSig] + let allIds = getAllIds bs mix inSig (newBs, accSig) = runState (ana_BASIC_SPEC mef anab anas mix { mixRules = makeRules ga allIds } bs) inSig { globAnnos = addAssocs inSig ga } @@ -908,15 +915,161 @@ basicCASLAnalysis = basicAnalysis (const return) (const return) -- | extra cASLsen_analysis :: - (BASIC_SPEC () () (), Sign () (), FORMULA ()) -> Result (FORMULA ()) + (BASIC_SPEC () () (), Sign () (), FORMULA ()) -> + Result (FORMULA (), FORMULA ()) cASLsen_analysis (bs, s, f) = let mix = emptyMix - allIds = unite $ - ids_BASIC_SPEC (getBaseIds mix) - (getSigIds mix) bs - : getExtIds mix (extendedInfo s) : - [mkIdSets (allConstIds s) (allOpIds s) - $ allPredIds s] + allIds = getAllIds bs mix s mix' = mix { mixRules = makeRules emptyGlobalAnnos allIds } - in liftM fst $ anaForm (const return) mix' s f + in anaForm (const return) mix' s f + +-- | convert theory + +convertCASLTheory :: (Sign f e, [Named (FORMULA f)]) -> BASIC_SPEC b s f +convertCASLTheory (sig, nsens) = + case (sig, nsens) of + (_, []) -> Basic_spec [] -- TODO: the sig should be empty + _ -> error "convert theory nyi for CASL logic" + +-- | test nominal sen + +isNominalSen :: Set.Set Id -> FORMULA f -> (Bool, Maybe Id) +isNominalSen noms aSen = + case aSen of + Mixfix_formula (Mixfix_token p) -> + let pId = simpleIdToId p + in if Set.member pId noms then (True, Just pId) else (False, Nothing) + _ -> (False, Nothing) + +-- | CASL hybridization: constraints to CASL sentences + +constrToSens :: Sign () () -> String -> SemanticConstraint -> + Result [Named (FORMULA ())] +constrToSens sig cname sc = + let + st = genName $ "ST_" ++ cname + domain = genName $ "domain_" ++ cname + defined = genName "defined" + (totals, partials) = partition (\(_, ot) -> opKind ot == Total) $ + MapSet.toPairList $ opMap sig + in + case sc of + SameInterpretation "sort" -> + return $ + map (\s -> makeNamed ("ga_sem_constr_"++show s) + $ mkForall [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st, + mkVarDecl (genToken "x") s] + $ mkEqv + (mkPredication + (mkQualPred domain $ Pred_type [st, s] nullRange) + [Qual_var (genToken "w1") st nullRange, + Qual_var (genToken "x") s nullRange]) + (mkPredication + (mkQualPred domain $ Pred_type [st, s] nullRange) + [Qual_var (genToken "w2") st nullRange, + Qual_var (genToken "x") s nullRange]) + ) + $ Set.toList $ sortSet sig + SameInterpretation "const" -> error "nyi for const" + SameInterpretation "op" -> + let + xs ot = zip (opArgs ot) [1::Int ..] + extOt i ot = Qual_op_name + i + (Op_type Total (st:opArgs ot) (opRes ot) nullRange) + nullRange + in return $ + map (\(i,ot) -> makeNamed ("ga_sem_constr_" ++ show i) + $ mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> + mkVarDecl (genToken $ "x" ++ show ii) si) $ xs ot) + ) + $ mkStEq + (mkAppl (extOt i ot) $ map (\(a,b) -> mkVarTerm a b) $ + (genToken "w1", st): + (map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ + xs ot)) + (mkAppl (extOt i ot) $ map (\(a,b) -> mkVarTerm a b) $ + (genToken "w2", st): + (map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ + xs ot)) + ) totals + SameInterpretation "pred" -> + let + xs pt = zip (predArgs pt) [1::Int ..] + extPt (Pred_type ss r) = Pred_type (st:ss) r + in return $ + map (\(i, pt) -> makeNamed ("ga_sem_constr_" ++ show i) $ + mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> + mkVarDecl (genToken $ "x" ++ show ii) si) + $ xs pt) + ) + $ mkEqv + (mkPredication + (mkQualPred i $ extPt $ toPRED_TYPE pt) $ + map (\(a,b) -> mkVarTerm a b) $ + (genToken "w1", st): + (map (\(si, ii) -> + (genToken $ "x" ++ show ii, si)) + $ xs pt)) + (mkPredication + (mkQualPred i $ extPt $ toPRED_TYPE pt) $ + map (\(a,b) -> mkVarTerm a b) $ + (genToken "w2", st): + (map (\(si, ii) -> + (genToken $ "x" ++ show ii, si)) + $ xs pt)) + ) $ MapSet.toPairList $ predMap sig + SameDomain False -> let + xs ot = zip (opArgs ot) [1::Int ..] + extOt i ot = Qual_op_name + i + (Op_type Total (st:opArgs ot) (opRes ot) nullRange) + nullRange + in return $ + map (\(i,ot) -> makeNamed ("ga_sem_constr_" ++ show i) + $ mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> + mkVarDecl (genToken $ "x" ++ show ii) si) + $ xs ot) + ) + $ mkEqv + (mkPredication + (mkQualPred defined $ + Pred_type [st, opRes ot] nullRange) $ + [mkVarTerm (genToken "w1") st, + mkAppl (extOt i ot) $ + map (\(a,b) -> mkVarTerm a b) $ + (genToken "w1", st): + (map (\(si, ii) -> + (genToken $ "x" ++ show ii, si)) + $ xs ot) + ] + ) + (mkPredication + (mkQualPred defined $ + Pred_type [st, opRes ot] nullRange) $ + [mkVarTerm (genToken "w2") st, + mkAppl (extOt i ot) $ + map (\(a,b) -> mkVarTerm a b) $ + (genToken "w2", st): + (map (\(si, ii) -> + (genToken $ "x" ++ show ii, si)) + $ xs ot) + ] + ) + ) + partials + _ -> error $ "Constraint not supported for CASL logic:" ++ show sc diff --git a/CoCASL/StatAna.hs b/CoCASL/StatAna.hs index 641f8a5640..5b0cb3c08e 100644 --- a/CoCASL/StatAna.hs +++ b/CoCASL/StatAna.hs @@ -59,7 +59,7 @@ basicCoCASLAnalysis = -- analyses cocasl sentences only co_sen_analysis :: (BASIC_SPEC C_BASIC_ITEM C_SIG_ITEM C_FORMULA, CSign, FORMULA C_FORMULA) - -> Result (FORMULA C_FORMULA) + -> Result (FORMULA C_FORMULA, FORMULA C_FORMULA) co_sen_analysis (bs, s, f) = let mix = emptyMix allIds = unite $ @@ -68,7 +68,7 @@ co_sen_analysis (bs, s, f) = let [mkIdSets (allConstIds s) (allOpIds s) $ allPredIds s] mix' = mix { mixRules = makeRules emptyGlobalAnnos allIds} - in liftM fst $ anaForm minExpForm mix' s f + in anaForm minExpForm mix' s f ana_CMix :: Mix C_BASIC_ITEM C_SIG_ITEM C_FORMULA CoCASLSign diff --git a/Common/AnnoState.hs b/Common/AnnoState.hs index 8e940530f4..7af0bf8e9b 100644 --- a/Common/AnnoState.hs +++ b/Common/AnnoState.hs @@ -214,6 +214,9 @@ equalT :: AParser st Token equalT = wrapAnnos $ pToken $ reserved [exEqual] (choice (map (keySign . string) [exEqual, equalS]) show equalS) +doubleColonT :: AParser st Token +doubleColonT = asKey "::" + colonT :: AParser st Token colonT = asKey colonS diff --git a/Common/Keywords.hs b/Common/Keywords.hs index 3db5b06995..c2b874adce 100644 --- a/Common/Keywords.hs +++ b/Common/Keywords.hs @@ -260,6 +260,64 @@ ren_proc_openS = "[[" ren_proc_closeS :: String ren_proc_closeS = "]]" +-- * definitions of hybrid logics + +newhlogicS :: String +newhlogicS = "newhlogic" + +baselogicS :: String +baselogicS = "base" + +hlogicS :: String +hlogicS = "hlogic" + +quantS :: String +quantS = "quant" + +constrS :: String +constrS = "constr" + +reflexiveS :: String +reflexiveS = "Reflexive" + +transitiveS :: String +transitiveS = "Transitive" + +symmetricS :: String +symmetricS = "Symmetric" + +serialS :: String +serialS = "Serial" + +euclideanS :: String +euclideanS = "Euclidean" + +functionalConstrS :: String +functionalConstrS = "Functional" + +linearS :: String +linearS = "Linear" + +totalS :: String +totalS = "Total" + +sameInterpretationS :: String +sameInterpretationS = "SameInterpretation" + +sameDomainS :: String +sameDomainS = "SameDomain" + +-- * definition of hybridizations of comorphisms + +hcomS :: String +hcomS = "newhcomorphism" + +basecomS :: String +basecomS = "basecomorphism" + +sourceHLogicS :: String +sourceHLogicS = "sourcehlogic" + -- * logic definition symbols newlogicS :: String @@ -663,3 +721,21 @@ withS = "with" withinS :: String withinS = "within" + +hybrid_keywords :: [String] +hybrid_keywords = [ + rigidS, + modalityS, + modalitiesS, + nominalS, + nominalsS + ] + +nominalS, nominalsS :: String +nominalS = "nominal" +nominalsS = "nominals" + +hExistsS, hForallS :: String +hExistsS = "existsH" +hForallS = "forallH" + diff --git a/Comorphisms/DynComorphismList.hs b/Comorphisms/DynComorphismList.hs index a89f9ad1c6..45adfe333e 100644 --- a/Comorphisms/DynComorphismList.hs +++ b/Comorphisms/DynComorphismList.hs @@ -1,3 +1,13 @@ +{- | +Module : ./Comorphisms/DynComorphismList.hs +Description : Automatically modified file, includes the user-defined + comorphisms in the Hets logic list. Do not change. +Copyright : (c) Kristina Sojakova, DFKI Bremen 2010 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : k.sojakova@jacobs-university.de +Stability : experimental +Portability : portable -} module Comorphisms.DynComorphismList where diff --git a/Comorphisms/DynLogicList.hs b/Comorphisms/DynLogicList.hs index 01b8c38e49..5c4d2202a4 100644 --- a/Comorphisms/DynLogicList.hs +++ b/Comorphisms/DynLogicList.hs @@ -2,7 +2,7 @@ Module : ./Comorphisms/DynLogicList.hs Description : Automatically modified file, includes the user-defined logics in the Hets logic list. Do not change. -Copyright : (c) Kristina Sojakova, DFKI Bremen 2010 +Copyright : (c) Mihai Codescu, IMAR 2018 License : GPLv2 or higher, see LICENSE.txt Maintainer : k.sojakova@jacobs-university.de @@ -11,7 +11,13 @@ Portability : portable -} module Comorphisms.DynLogicList where +import Common.Id import Logic.Logic +import Logic.HDef +import Logic.SemConstr dynLogicList :: [AnyLogic] dynLogicList = [] + +dynHLogicList :: [(String, HLogicDef)] +dynHLogicList = [] diff --git a/Comorphisms/HPAR2CASL.hs b/Comorphisms/HPAR2CASL.hs new file mode 100644 index 0000000000..869cb3e0d2 --- /dev/null +++ b/Comorphisms/HPAR2CASL.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{- | +Module : ./Comorphisms/HPAR2CASL.hs +Description : encoding of HPAR to FOL +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +The encoding comorphism from HPAR to FOL. + +-} + +module Comorphisms.HPAR2CASL where + +import Logic.Logic +import Logic.Comorphism +import Logic.SemConstr +import qualified Data.Set as Set +import qualified Data.Map as Map +import Common.ProofTree +import Common.Result +import Common.AS_Annotation +import Common.Id +import qualified Common.Lib.MapSet as MapSet + + +import Control.Monad (foldM) +import Data.List(partition) + +-- HPAR +import qualified HPAR.Logic_HPAR as HLogic +import qualified HPAR.AS_Basic_HPAR as HBasic +import qualified HPAR.Sign as HSign +import qualified RigidCASL.Sign as RSign +import qualified HPAR.Morphism as HMorphism +import qualified HPAR.StaticAna as HAna +import qualified HPAR.Symbol as HSym + +-- CASL +import qualified CASL.Logic_CASL as CLogic +import qualified CASL.AS_Basic_CASL as CBasic +import qualified CASL.Sign as CSign +import qualified CASL.Morphism as CMor +import CASL.Sublogic +import qualified CASL.Induction as CInd + +-- base comorphism +import qualified Comorphisms.CASL2SubCFOL as BaseCom + +-- | The identity of the comorphism +data HPAR2CASL = HPAR2CASL deriving (Show) + +instance Language HPAR2CASL + +instance Comorphism HPAR2CASL + HLogic.HPAR () + HBasic.H_BASIC_SPEC HBasic.HFORMULA HBasic.H_SYMB_ITEMS + CBasic.SYMB_MAP_ITEMS + HSign.HSign HMorphism.HMorphism HSym.HSymbol CMor.RawSymbol () + CLogic.CASL CASL_Sublogics + CLogic.CASLBasicSpec CBasic.CASLFORMULA CBasic.SYMB_ITEMS CBasic.SYMB_MAP_ITEMS + CSign.CASLSign + CMor.CASLMor + CSign.Symbol CMor.RawSymbol ProofTree where + sourceLogic HPAR2CASL = HLogic.HPAR + sourceSublogic HPAR2CASL = () + targetLogic HPAR2CASL = CLogic.CASL + mapSublogic HPAR2CASL _ = Just cFol { cons_features = emptyMapConsFeature } + map_theory HPAR2CASL = mapTheory + map_morphism HPAR2CASL = undefined + map_sentence HPAR2CASL = undefined + map_symbol HPAR2CASL _ = undefined + has_model_expansion HPAR2CASL = True + +mapTheory :: (HSign.HSign, [Named HBasic.HFORMULA]) -> + Result (CSign.CASLSign, [Named CBasic.CASLFORMULA]) +mapTheory (hsig, nhsens) = -- trace ("nhsens:" ++ show nhsens) $ + do + -- 1. translate base signature + (csig, csens) <- map_theory (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) $ (RSign.caslSign $ HSign.baseSig $ hsig, []) + -- 2. auxiliaries + let st = genName "ST" + v = genToken "X" + domain = genName "domain" + -- 3. variables in \Gamma_\Sigma + cvars = foldl (\vars asen -> getVarSorts vars $ sentence asen) Set.empty csens + -- 4. e -> forall gn_X : gn_ST . e(X) + csens' = -- trace ("cvars:" ++ show cvars) $ + map (\f -> f { sentence = CBasic.Quantification CBasic.Universal [CBasic.Var_decl [v] st nullRange] (addX v $ sentence f) nullRange} ) csens + -- 5. this one has gn_ST + stsig <- CSign.addSymbToSign (CSign.emptySign ()) $ CSign.Symbol st CSign.SortAsItemType + -- 6. this one has [S_\Sigma] + sortsig <- foldM (\aSig x -> CSign.addSymbToSign aSig $ CSign.Symbol x CSign.SortAsItemType) + stsig $ Set.toList $ CSign.sortSet csig + -- 7. this one has \overline{Nom} + nomsig <- foldM (\aSig x -> CSign.addSymbToSign aSig $ CSign.Symbol x $ CSign.OpAsItemType $ CSign.OpType CBasic.Total [] st) + sortsig $ HSign.noms hsig + -- 8. this one has [F_\Sigma] + opsig <- foldM (\aSig (i, CSign.OpType k w s) -> CSign.addSymbToSign aSig $ CSign.Symbol i $ CSign.OpAsItemType $ CSign.OpType k (st:w) s) + nomsig $ MapSet.toPairList $ CSign.opMap csig + -- 9. this is D_F_\Sigma + let domsens = + foldl (\sens (f, o@(CSign.OpType _ w s)) -> + let ydecl = CBasic.mkVarDecl (genToken "w") st + xsdecl = map (\(si, ii) -> CBasic.mkVarDecl (genToken $ "x" ++ show ii) si) $ zip w [1::Int ..] + df = CBasic.mkForall [ydecl] $ + CBasic.mkForall xsdecl $ + CBasic.mkImpl + (CBasic.conjunct $ map (\xidecl -> case xidecl of + CBasic.Var_decl [xi] si _ -> + CBasic.mkPredication (CBasic.mkQualPred domain $ CBasic.Pred_type [st, si] nullRange) + [CBasic.Qual_var (genToken "w") st nullRange, + CBasic.Qual_var xi si nullRange] + _ -> error "domsens" + ) xsdecl + ) + (CBasic.mkPredication (CBasic.mkQualPred domain $ CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "w") st nullRange, + CBasic.mkAppl (CBasic.Qual_op_name f (addSortToOpType $ CSign.toOP_TYPE o) nullRange) + (map CBasic.toQualVar $ ydecl:xsdecl) + ] + ) + in (makeNamed ("ga_domain_"++show f) df):sens + ) + [] $ MapSet.toPairList $ CSign.opMap csig + -- 10. this one has [P_\Sigma] + predsig <- foldM (\aSig (i, CSign.PredType w) -> CSign.addSymbToSign aSig $ CSign.Symbol i $ CSign.PredAsItemType $ CSign.PredType (st:w)) + opsig $ MapSet.toPairList $ CSign.predMap csig + -- 11. this one has D_s + domsig <- foldM (\aSig s -> CSign.addSymbToSign aSig $ CSign.Symbol domain $ CSign.PredAsItemType $ CSign.PredType [st, s]) + predsig $ Set.toList $ CSign.sortSet csig + -- 12. this one has \overline{\Lambda} + lamsig <- foldM (\aSig (l, x) -> CSign.addSymbToSign aSig $ CSign.Symbol l $ CSign.PredAsItemType $ CSign.PredType $ take x $ repeat st) + domsig $ Map.toList $ HSign.mods hsig + -- 13. translate sentences from HPAR to CASL + let ncsens = map (mapNamedSentence hsig) nhsens + -- 14. add constraints as CASL sentences + constrsens = constrsToSens hsig $ sem_constr HLogic.HPAR + -- 15. this is V(\Gamma_Sigma) + makeVSen s = makeNamed ("ga_V_"++show s) + $ CBasic.mkForall [CBasic.mkVarDecl (genToken "w") st, CBasic.mkVarDecl (genToken "x") s] + $ CBasic.mkPredication (CBasic.mkQualPred domain $ CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "w") st nullRange, + CBasic.Qual_var (genToken "x") s nullRange] + vsens = map makeVSen $ Set.toList cvars + -- 16. return results + -- trace (concatMap (\x -> show x ++ "\n") ncsens) $ + return (lamsig, csens' ++ vsens ++ domsens ++ ncsens ++ constrsens) + +getVarSorts :: Set.Set CBasic.SORT -> CBasic.CASLFORMULA -> Set.Set CBasic.SORT +getVarSorts oldS sen = + case sen of + CBasic.Quantification _ vdecls f _ -> Set.union (Set.fromList $ map (\(CBasic.Var_decl _ s _) -> s) vdecls) $ getVarSorts oldS f + CBasic.Junction _ fs _ -> foldl (\s f -> getVarSorts s f) oldS fs + CBasic.Relation f1 _ f2 _ -> Set.union (getVarSorts oldS f1) (getVarSorts oldS f2) + CBasic.Negation f _ -> getVarSorts oldS f + CBasic.Atom _ _ -> oldS + CBasic.Definedness _ _ -> oldS + CBasic.Predication _ _ _ -> oldS + CBasic.Equation _ _ _ _ -> oldS + _ -> error $ "Illegal argument for getVarSorts in HPAR2CASL.hs: " ++ show sen + +constrsToSens :: HSign.HSign -> [SemanticConstraint] -> [Named CBasic.CASLFORMULA] +constrsToSens hsig cs = concatMap (constrToSens hsig) cs + +constrToSens :: HSign.HSign -> SemanticConstraint -> [Named CBasic.CASLFORMULA] +constrToSens hsig sc = + let + rsig = HSign.baseSig hsig + st = genName "ST" + domain = genName "domain" + defined = genName "defined" + (totals, partials) = partition (\(_, ot) -> CSign.opKind ot == CBasic.Total) $ MapSet.toPairList $ RSign.rigidOps $ CSign.extendedInfo rsig + in + case sc of + SameInterpretation "rigid sort" -> + map (\s -> makeNamed ("ga_sem_constr_"++show s) + $ CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st, + CBasic.mkVarDecl (genToken "x") s] + $ CBasic.mkEqv + (CBasic.mkPredication (CBasic.mkQualPred domain $ CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "x") s nullRange]) + (CBasic.mkPredication (CBasic.mkQualPred domain $ CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "w2") st nullRange, + CBasic.Qual_var (genToken "x") s nullRange]) + ) + $ Set.toList $ RSign.rigidSorts $ CSign.extendedInfo rsig + SameInterpretation "rigid op" -> + let + xs ot = zip (CSign.opArgs ot) [1::Int ..] + extOt i ot = CBasic.Qual_op_name i (CBasic.Op_type CBasic.Total (st:CSign.opArgs ot) (CSign.opRes ot) nullRange) nullRange + in + map (\(i,ot) -> makeNamed ("ga_sem_constr_" ++ show i) + $ CBasic.mkForall + ( [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> CBasic.mkVarDecl (genToken $ "x" ++ show ii) si) $ xs ot) + ) + $ CBasic.mkStEq + (CBasic.mkAppl (extOt i ot) $ map (\(a,b) -> CBasic.mkVarTerm a b) $ (genToken "w1", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot)) + (CBasic.mkAppl (extOt i ot) $ map (\(a,b) -> CBasic.mkVarTerm a b) $ (genToken "w2", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot)) + ) + totals + SameDomain True -> let + xs ot = zip (CSign.opArgs ot) [1::Int ..] + extOt i ot = CBasic.Qual_op_name i (CBasic.Op_type CBasic.Total (st:CSign.opArgs ot) (CSign.opRes ot) nullRange) nullRange + in + map (\(i,ot) -> makeNamed ("ga_sem_constr_" ++ show i) + $ CBasic.mkForall + ( [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> CBasic.mkVarDecl (genToken $ "x" ++ show ii) si) $ xs ot) + ) + $ CBasic.mkEqv + (CBasic.mkPredication (CBasic.mkQualPred defined $ CBasic.Pred_type [st, CSign.opRes ot] nullRange) $ + [CBasic.mkVarTerm (genToken "w1") st, + CBasic.mkAppl (extOt i ot) $ map (\(a,b) -> CBasic.mkVarTerm a b) $ (genToken "w1", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot) + ] + ) + (CBasic.mkPredication (CBasic.mkQualPred defined $ CBasic.Pred_type [st, CSign.opRes ot] nullRange) $ + [CBasic.mkVarTerm (genToken "w2") st, + CBasic.mkAppl (extOt i ot) $ map (\(a,b) -> CBasic.mkVarTerm a b) $ (genToken "w2", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot) + ] + ) + ) + partials + _ -> error $ "unexpected semantic constraint: " ++ show sc + +addSortToOpType :: CBasic.OP_TYPE -> CBasic.OP_TYPE +addSortToOpType (CBasic.Op_type k w s r1) = CBasic.Op_type k (genName "ST":w) s r1 + +addSortToPredType :: CBasic.PRED_TYPE -> CBasic.PRED_TYPE +addSortToPredType (CBasic.Pred_type w r1) = CBasic.Pred_type (genName "ST" : w) r1 + +addVarToTerm :: CBasic.VAR -> CBasic.TERM () -> CBasic.TERM () +addVarToTerm v t = case t of + CBasic.Qual_var _ _ _ -> t + CBasic.Application (CBasic.Qual_op_name f o r2) args r -> + CBasic.Application (CBasic.Qual_op_name f (addSortToOpType o) r2) ((CBasic.Qual_var v (genName "ST") nullRange):(map (addVarToTerm v) args)) r + _ -> error $ "HPAR2CASL: can't add var to term " ++ show t + +addX :: CBasic.VAR -> CBasic.CASLFORMULA -> CBasic.CASLFORMULA +addX v sen = case sen of + CBasic.Quantification q vdecls f r -> CBasic.Quantification q vdecls (addX v f) r + CBasic.Junction j fs r -> CBasic.Junction j (map (addX v) fs) r + CBasic.Relation f1 rel f2 r -> CBasic.Relation (addX v f1) rel (addX v f2) r + CBasic.Negation f r -> CBasic.Negation (addX v f) r + CBasic.Atom _ _ -> sen + CBasic.Definedness t r -> CBasic.Definedness (addVarToTerm v t) r + CBasic.Predication (CBasic.Qual_pred_name p t r2) terms r -> + CBasic.Predication (CBasic.Qual_pred_name p (addSortToPredType t) r2) ((CBasic.Qual_var v (genName "ST") nullRange):(map (addVarToTerm v) terms)) r + CBasic.Equation t1 eq t2 r -> CBasic.Equation (addVarToTerm v t1) eq (addVarToTerm v t2) r + _ -> error $ "Illegal argument for addX in HPAR2CASL.hs: " ++ show sen + +substituteInHSen :: CBasic.VAR -> CBasic.SORT -> CBasic.TERM () -> HBasic.HFORMULA -> HBasic.HFORMULA +substituteInHSen v s t hf = + case hf of + HBasic.Base_formula f r -> HBasic.Base_formula (CInd.substitute v s t f) r + HBasic.Negation hf' r -> HBasic.Negation (substituteInHSen v s t hf') r + HBasic.Conjunction hfs r -> HBasic.Conjunction (map (substituteInHSen v s t) hfs) r + HBasic.Disjunction hfs r -> HBasic.Disjunction (map (substituteInHSen v s t) hfs) r + HBasic.Implication hf1 hf2 r -> HBasic.Implication (substituteInHSen v s t hf1) (substituteInHSen v s t hf2) r + HBasic.Equivalence hf1 hf2 r -> HBasic.Equivalence (substituteInHSen v s t hf1) (substituteInHSen v s t hf2) r + HBasic.AtState nom hf' r -> HBasic.AtState nom (substituteInHSen v s t hf') r + HBasic.BoxFormula md hf' r -> HBasic.BoxFormula md (substituteInHSen v s t hf') r + HBasic.DiamondFormula md hf' r -> HBasic.DiamondFormula md (substituteInHSen v s t hf') r + HBasic.QuantNominals q noms hf' r -> HBasic.QuantNominals q noms (substituteInHSen v s t hf') r + HBasic.QuantRigidVars q vdecls hf' r -> HBasic.QuantRigidVars q vdecls (substituteInHSen v s t hf') r + _ -> hf + +replaceInHSen :: CBasic.VAR -> CBasic.SORT -> HBasic.HFORMULA -> HBasic.HFORMULA +replaceInHSen v s hf = + case hf of + HBasic.Base_formula f r -> HBasic.Base_formula (replaceVarAppls v s f) r + HBasic.Negation hf' r -> HBasic.Negation (replaceInHSen v s hf') r + HBasic.Conjunction hfs r -> HBasic.Conjunction (map (replaceInHSen v s) hfs) r + HBasic.Disjunction hfs r -> HBasic.Disjunction (map (replaceInHSen v s) hfs) r + HBasic.Implication hf1 hf2 r -> HBasic.Implication (replaceInHSen v s hf1) (replaceInHSen v s hf2) r + HBasic.Equivalence hf1 hf2 r -> HBasic.Equivalence (replaceInHSen v s hf1) (replaceInHSen v s hf2) r + HBasic.AtState nom hf' r -> HBasic.AtState nom (replaceInHSen v s hf') r + HBasic.BoxFormula md hf' r -> HBasic.BoxFormula md (replaceInHSen v s hf') r + HBasic.DiamondFormula md hf' r -> HBasic.DiamondFormula md (replaceInHSen v s hf') r + HBasic.QuantNominals q noms hf' r -> HBasic.QuantNominals q noms (replaceInHSen v s hf') r + HBasic.QuantRigidVars q vdecls hf' r -> HBasic.QuantRigidVars q vdecls (replaceInHSen v s hf') r + _ -> hf + +replaceVarAppls :: CBasic.VAR -> CBasic.SORT -> CBasic.CASLFORMULA -> CBasic.CASLFORMULA +replaceVarAppls v s sen = case sen of + CBasic.Quantification q vdecls f r -> CBasic.Quantification q vdecls (replaceVarAppls v s f) r + CBasic.Junction j fs r -> CBasic.Junction j (map (replaceVarAppls v s) fs) r + CBasic.Relation f1 rel f2 r -> CBasic.Relation (replaceVarAppls v s f1) rel (replaceVarAppls v s f2) r + CBasic.Negation f r -> CBasic.Negation (replaceVarAppls v s f) r + CBasic.Atom _ _ -> sen + CBasic.Definedness t r -> CBasic.Definedness (replTermWithVar v s t) r + CBasic.Predication p terms r -> CBasic.Predication p (map (replTermWithVar v s) terms) r + CBasic.Equation t1 eq t2 r -> CBasic.Equation (replTermWithVar v s t1) eq (replTermWithVar v s t2) r + _ -> error $ "Illegal argument for replaceVarAppls in HPAR2CASL.hs: " ++ show sen + +replTermWithVar :: CBasic.VAR -> CBasic.SORT -> CBasic.TERM () -> CBasic.TERM () +replTermWithVar v s t = case t of + CBasic.Application op@(CBasic.Qual_op_name f _o _r2) args r -> + if simpleIdToId v == f + then CBasic.Qual_var v s nullRange + else CBasic.Application op (map (replTermWithVar v s) args) r + _ -> t + +mapNamedSentence :: HSign.HSign -> Named HBasic.HFORMULA -> Named CBasic.CASLFORMULA +mapNamedSentence hsig nsen = nsen {sentence = mapSentence hsig $ sentence nsen} + +mapSentence :: HSign.HSign -> HBasic.HFORMULA -> CBasic.CASLFORMULA +mapSentence hsig sen = -- trace ("mapping:" ++ show sen) $ + let + x = genToken "X" + st = genName "ST" + hth = HAna.HTheoryAna hsig Set.empty [] Map.empty [] + in CBasic.mkForall [CBasic.mkVarDecl x st] $ + mapSentenceAux hth x st sen + +mapSentenceAux :: HAna.HTheoryAna -> CBasic.VAR -> CBasic.SORT -> HBasic.HFORMULA -> CBasic.CASLFORMULA +mapSentenceAux hth x st sen = case sen of + HBasic.Nominal b i _ -> CBasic.mkStEq + (CBasic.Qual_var x st nullRange) $ + if b then CBasic.Qual_var i st nullRange + else CBasic.Application (CBasic.mkQualOp (simpleIdToId i) $ CBasic.Op_type CBasic.Total [] st nullRange) [] nullRange + HBasic.Base_formula f _ -> let + hsig = HAna.hSign hth + Result ds f' = map_sentence (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) (RSign.caslSign $ HSign.baseSig hsig) f + in case f' of + Nothing -> error $ "can't translate sentence " ++ show f ++ " msg:" ++ show ds + Just f'' -> addX x f'' + HBasic.Negation hf _ -> CBasic.Negation (mapSentenceAux hth x st hf) nullRange + HBasic.Conjunction hfs _ -> CBasic.Junction CBasic.Con (map (mapSentenceAux hth x st) hfs) nullRange + HBasic.Disjunction hfs _ -> CBasic.Junction CBasic.Dis (map (mapSentenceAux hth x st) hfs) nullRange + HBasic.Implication hf1 hf2 _ -> CBasic.Relation (mapSentenceAux hth x st hf1) CBasic.Implication (mapSentenceAux hth x st hf2) nullRange + HBasic.Equivalence hf1 hf2 _ -> CBasic.Relation (mapSentenceAux hth x st hf1) CBasic.Equivalence (mapSentenceAux hth x st hf2) nullRange + HBasic.AtState nom hf _ -> let cf = mapSentenceAux hth x st hf + t = if nom `elem` (Map.keys $ HAna.hVars hth) then CBasic.Qual_var nom st nullRange else + CBasic.mkAppl (CBasic.mkQualOp (simpleIdToId nom) $ CBasic.Op_type CBasic.Total [] st nullRange) [] + in CInd.substitute x st t cf + -- mapSentenceAux i st sen does not work, because i should not be a var. apply a substitution of x with i instead + HBasic.BoxFormula md hf _ -> CBasic.mkForall [CBasic.mkVarDecl (genToken "Y") st] $ + CBasic.mkImpl + (CBasic.mkPredication (CBasic.mkQualPred (simpleIdToId md) $ CBasic.Pred_type [st,st] nullRange) + [CBasic.Qual_var x st nullRange, CBasic.Qual_var (genToken "Y") st nullRange]) $ + mapSentenceAux hth (genToken "Y") st hf + HBasic.DiamondFormula md hf _ -> CBasic.mkExist [CBasic.mkVarDecl (genToken "Y") st] $ + CBasic.Junction CBasic.Con + [CBasic.mkPredication (CBasic.mkQualPred (simpleIdToId md) $ CBasic.Pred_type [st,st] nullRange) + [CBasic.Qual_var x st nullRange, CBasic.Qual_var (genToken "Y") st nullRange], + mapSentenceAux hth (genToken "Y") st hf] + nullRange + HBasic.QuantNominals q noms hf _ -> (case q of + HBasic.HUniversal -> CBasic.mkForall + HBasic.HExistential -> CBasic.mkExist) + (map (\n -> CBasic.mkVarDecl n st) noms) + $ mapSentenceAux (hth{HAna.hVars = foldl (\f n -> Map.insert n st f) (HAna.hVars hth) noms}) x st hf + -- here we must make sure that noms are known to be variables and not nominals! + HBasic.QuantRigidVars q vdecls hf _ -> + let + hsig = HAna.hSign hth + domainSen xi si = CBasic.mkPredication (CBasic.mkQualPred (genName "domain") $ CBasic.Pred_type [st, si] nullRange) + [CBasic.Qual_var x st nullRange, + CBasic.mkAppl (CBasic.Qual_op_name (simpleIdToId xi) (addSortToOpType $ CBasic.Op_type CBasic.Total [] si nullRange) nullRange) + [CBasic.Qual_var x st nullRange]] + baseSig = RSign.caslSign $ HSign.baseSig $ hsig + Result ds resTh = map_theory (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) $ (baseSig, []) + (_, csens) = case resTh of + Nothing -> error $ "could not translate theory:" ++ show ds + Just th -> th + addVarAsConst xi si = + let Result ds' resTh' = CSign.addSymbToSign baseSig $ CSign.Symbol (simpleIdToId xi) $ CSign.OpAsItemType $ CSign.OpType CBasic.Total [] si + in case resTh' of + Nothing -> error $ "could not add variable as constant:" ++ show ds' + Just th -> th + getCSens xi si = let + Result ds'' resTh'' = map_theory (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) $ (addVarAsConst xi si, []) + in case resTh'' of + Nothing -> error $ "could not translate theory with added variable:" ++ show ds'' + Just (_, sens) -> sens + -- keep the sentences that appear only in the second list of sentences + gamma_xi xi si = map (\f -> f { sentence = CBasic.Quantification CBasic.Universal [CBasic.Var_decl [genToken "w"] st nullRange] (addX (genToken "w") $ sentence f) nullRange} ) + $ filter (\s -> not (s `elem` csens)) $ getCSens xi si + allVars = concatMap (\(CBasic.Var_decl vs si _ ) -> map (\v -> (v, si)) vs) vdecls + baseSigXi bSig xi si = let Result ds''' resSig = CSign.addSymbToSign bSig $ CSign.Symbol (simpleIdToId xi) $ CSign.OpAsItemType $ CSign.OpType CBasic.Total [] si + in case resSig of + Nothing -> error $ show ds''' + Just sig -> sig + baseSigWithVars = foldl (\bSig (xi, si) -> baseSigXi bSig xi si) (HSign.baseSig $ hsig) allVars + hsig' = hsig {HSign.baseSig = baseSigWithVars} + hf' = foldl (\f (xi, si) -> substituteInHSen xi si (CBasic.mkAppl (CBasic.mkQualOp (simpleIdToId xi) $ CBasic.Op_type CBasic.Total [] si nullRange) []) f) hf allVars + senWithVarAppl = CBasic.mkImpl + (CBasic.Junction CBasic.Con ( + (map sentence $ + concatMap (\(xi,si)-> gamma_xi xi si) allVars + ) ++ (map (\(xi,si) -> domainSen xi si) allVars) + ) nullRange) + $ mapSentenceAux (hth {HAna.hSign = hsig'}) x st hf' + senRepl = foldl (\csen (xi,si) -> replaceVarAppls xi si csen) senWithVarAppl allVars + in -- trace ("hf':" ++ show hf') $ + (case q of + HBasic.HUniversal -> CBasic.mkForall + HBasic.HExistential -> CBasic.mkExist) vdecls senRepl + + + {- (case q of + HBasic.HUniversal -> CBasic.mkForall + HBasic.HExistential -> CBasic.mkExist) + vdecls + $ CBasic.mkImpl + (CBasic.mkForall [CBasic.mkVarDecl (genToken "Y") st] $ + CBasic.Junction CBasic.Con + (concatMap (\(CBasic.Var_decl vs s _) -> + map (\v -> CBasic.mkPredication (CBasic.mkQualPred (genName "domain") $ CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "Y") st nullRange, + CBasic.Qual_var v s nullRange]) + vs + ) vdecls + ) + nullRange + ) + $ mapSentenceAux hsig x st hf -} + +{- + +QuantRigidVars q vdecls hf _ -> + let + domainSen xi si = CBasic.mkPredication (CBasic.mkQualPred domain $ CBasic.Pred_type [st, si] nullRange) + [CBasic.Qual_var x st nullRange, + CBasic.Qual_var xi si nullRange] + -- translate hsig to CASL + baseSig = RSign.caslSign $ HSign.baseSig $ hsig + (csig, csens) <- map_theory (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) $ (baseSig, []) + baseSigXi <- CSign.addSymbToSign baseSig $ CSign.Symbol xi $ CSign.OpAsItemType $ CSign.OpType CBasic.Total [] si + hsig' = hsig {HSign.baseSig = addSymb (xi as constant) $ baseSig hsig} + -- translate hsig + x to CASL + (csig', csens') <- map_theory (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) $ (baseSigXi, []) + -- keep the sentences that appear only in the second list of sentences + let gamma_xi = map (\f -> f { sentence = CBasic.Quantification CBasic.Universal [CBasic.Var_decl [v] st nullRange] (addX v $ sentence f) nullRange} ) csens + $ filter (\s -> not (s `elem` csens)) csens' + in CBasic.mkImpl + (CBasic.Junction CBasic.Con $ map domainSen $ vdecls) + $ mapSentenceAux hsig' x st f + +-} + +{- + +mapTheory :: (RSign.RSign, [Named CBasic.CASLFORMULA]) -> + Result (HSign.HSign, [Named HBasic.HFORMULA]) +mapTheory (sig, nsens) = do + let tsig = HSign.HSign {HSign.baseSig = sig, + HSign.noms = Set.singleton $ genName "i", + HSign.mods = Map.empty} + tsens = map mapNamedSen nsens + return (tsig, tsens) + +mapNamedSen :: Named CBasic.CASLFORMULA -> Named HBasic.HFORMULA +mapNamedSen nsen = let + sen = sentence nsen + trans = HBasic.AtState (genToken "i") (HBasic.Base_formula sen) nullRange + in + nsen {sentence = trans} + +-} diff --git a/Comorphisms/KnownProvers.hs b/Comorphisms/KnownProvers.hs index ed8ee6414c..ce610f7468 100644 --- a/Comorphisms/KnownProvers.hs +++ b/Comorphisms/KnownProvers.hs @@ -32,7 +32,7 @@ import System.Exit (exitFailure) import Common.Result -import Logic.Logic (provers, AnyLogic (Logic), top_sublogic) -- hiding (top) +import Logic.Logic (provers, AnyLogic (Logic), top_sublogic, language_name) -- hiding (top) import Logic.Coerce () import Logic.Grothendieck import Logic.Comorphism @@ -44,6 +44,7 @@ import CASL.Sublogic import Comorphisms.QBF2Prop import Comorphisms.Prop2QBF import Comorphisms.Prop2CASL +--import Comorphisms.HPropNoms2CASL -- TODO: remove import import Comorphisms.CASL2SubCFOL import Comorphisms.CASL2PCFOL import Comorphisms.CASL2HasCASL @@ -51,6 +52,7 @@ import Comorphisms.CFOL2IsabelleHOL import Comorphisms.CommonLogic2IsabelleHOL import Comorphisms.CSMOF2CASL #ifdef CASLEXTENSIONS +import Comorphisms.HPAR2CASL import Comorphisms.CoCASL2CoPCFOL import Comorphisms.CoCASL2CoSubCFOL import Comorphisms.CoCFOL2IsabelleHOL @@ -75,6 +77,8 @@ import Comorphisms.Haskell2IsabelleHOLCF import Comorphisms.SuleCFOL2TPTP import Comorphisms.LogicList +import Comorphisms.DynComorphismList + type KnownProversMap = Map.Map String [AnyComorphism] type KnownConsCheckersMap = Map.Map String [AnyComorphism] @@ -190,6 +194,8 @@ spassComorphisms = csmof2casl <- compSPASS (Comorphism CSMOF2CASL) #ifdef CASLEXTENSIONS -- hybrid + --hpropnoms2SPASS <- compSPASS $ Comorphism HPropNoms2CASL + hpar2SPASS <- compSPASS $ Comorphism HPAR2CASL hybr2SPASS <- compComorphism (Comorphism Hybrid2CASL) partOut prop2SPASS <- compComorphism (Comorphism Prop2CASL) partOut casl_dl2SPASS <- compComorphism (Comorphism CASL_DL2CASL) partOut @@ -204,11 +210,16 @@ spassComorphisms = {- Fixme: constraint empty mapping is not available after Modal2CASL mod2SPASS <- compComorphism (Comorphism Modal2CASL) partSubOut CommonLogic -} - return + dynSpassList <- mapM compSPASS + $ filter (\(Comorphism cid) -> let tLid = targetLogic cid in language_name tLid == "CASL") + dynComorphismList + return $ [ Comorphism suleCFOL2TPTP , partOut , partSubOut #ifdef CASLEXTENSIONS + --, hpropnoms2SPASS + , hpar2SPASS , prop2SPASS , casl_dl2SPASS , maude2SPASS @@ -221,7 +232,7 @@ spassComorphisms = #ifndef NOOWLLOGIC , owl2spass #endif - ] + ] ++ dynSpassList quickCheckComorphisms :: Result [AnyComorphism] quickCheckComorphisms = do diff --git a/Comorphisms/LogicGraph.hs b/Comorphisms/LogicGraph.hs index e364fb7174..e1b5316708 100644 --- a/Comorphisms/LogicGraph.hs +++ b/Comorphisms/LogicGraph.hs @@ -50,6 +50,9 @@ import qualified Data.Map as Map import qualified Control.Monad.Fail as Fail import Data.Maybe (fromMaybe) +import Comorphisms.DynComorphismList +import Comorphisms.DynLogicList + import Common.Result import Common.IRI (nullIRI, parseIRI) import Logic.Logic @@ -88,6 +91,7 @@ import Comorphisms.QVTR2CASL import Comorphisms.CASL2Hybrid import Comorphisms.Hybrid2CASL +import Comorphisms.HPAR2CASL #ifdef CASLEXTENSIONS @@ -120,6 +124,8 @@ import Comorphisms.CommonLogicModuleElimination import Comorphisms.Prop2CommonLogic import Comorphisms.SoftFOL2CommonLogic import Comorphisms.Adl2CASL +import Comorphisms.Rigid2HPAR +import Comorphisms.Rigid2CASL #endif #ifndef NOOWLLOGIC import OWL2.DMU2OWL2 @@ -207,6 +213,9 @@ comorphismList = , Comorphism Prop2CommonLogic , Comorphism SoftFOL2CommonLogic , Comorphism Adl2CASL + , Comorphism Rigid2HPAR + , Comorphism Rigid2CASL + , Comorphism HPAR2CASL #endif #ifndef NOOWLLOGIC , Comorphism OWL22CASL @@ -242,7 +251,7 @@ comorphismList = , Comorphism QBF2Prop , Comorphism Prop2QBF , Comorphism CSMOF2CASL - , Comorphism QVTR2CASL ] + , Comorphism QVTR2CASL ] ++ dynComorphismList inclusionList :: [AnyComorphism] inclusionList = @@ -285,6 +294,7 @@ logicGraph = emptyLogicGraph ++ concatMap (\ (Comorphism cid) -> [Logic $ sourceLogic cid, Logic $ targetLogic cid]) comorphismList) + , knownHybLogics = Map.fromList dynHLogicList , comorphisms = Map.fromList $ map addComorphismName comorphismList , inclusions = addCompsN $ Map.fromList $ map addInclusionNames inclusionList diff --git a/Comorphisms/LogicList.hs b/Comorphisms/LogicList.hs index ea58d5a760..a23b8dbb12 100644 --- a/Comorphisms/LogicList.hs +++ b/Comorphisms/LogicList.hs @@ -40,6 +40,7 @@ import qualified Data.Map as Map import Logic.Logic import Logic.Grothendieck import CASL.Logic_CASL -- also serves as default logic +import RigidCASL.Logic_RigidCASL import HasCASL.Logic_HasCASL import Propositional.Logic_Propositional import QBF.Logic_QBF @@ -91,6 +92,7 @@ import NeSyPatterns.Logic_NeSyPatterns logicList :: [AnyLogic] logicList = [ Logic CASL + , Logic RigidCASL , Logic HasCASL , Logic HolLight , Logic Isabelle diff --git a/Comorphisms/Prop2CASL.hs b/Comorphisms/Prop2CASL.hs index f010873ef3..0c6a76aff7 100644 --- a/Comorphisms/Prop2CASL.hs +++ b/Comorphisms/Prop2CASL.hs @@ -81,3 +81,4 @@ instance Comorphism Prop2CASL has_model_expansion Prop2CASL = True is_weakly_amalgamable Prop2CASL = True isInclusionComorphism Prop2CASL = True + com_path Prop2CASL = "Comorphisms.Prop2CASL" diff --git a/Comorphisms/Rigid2CASL.hs b/Comorphisms/Rigid2CASL.hs new file mode 100644 index 0000000000..de52958b4d --- /dev/null +++ b/Comorphisms/Rigid2CASL.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{- | +Module : ./Comorphisms/Rigid2CASL.hs +Description : code out partiality +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +Comorphism from RigidCASL to HPAR that works like + +-} + +module Comorphisms.Rigid2CASL where + +import Logic.Logic +import Logic.Comorphism +import Common.ProofTree +import Common.Result +import Common.AS_Annotation + +-- Rigid CASL +import qualified RigidCASL.Logic_RigidCASL as RLogic +import qualified RigidCASL.Sign as RSign +import qualified RigidCASL.AS_Rigid as RBasic +import qualified RigidCASL.Morphism as RMorphism + +-- CASL +import qualified CASL.Logic_CASL as CLogic +import qualified CASL.AS_Basic_CASL as CBasic +import qualified CASL.Sign as CSign +import qualified CASL.Morphism as CMor +import CASL.Sublogic + +-- base comorphism +import qualified Comorphisms.CASL2SubCFOL as BaseCom +-- | The identity of the comorphism +data Rigid2CASL = Rigid2CASL deriving (Show) + +instance Language Rigid2CASL -- default definition is okay + +instance Comorphism Rigid2CASL + RLogic.RigidCASL () + RBasic.R_BASIC_SPEC CBasic.CASLFORMULA + CBasic.SYMB_ITEMS + CBasic.SYMB_MAP_ITEMS + RSign.RSign + RMorphism.RigidMor + RBasic.RigidSymbol CMor.RawSymbol () + CLogic.CASL CASL_Sublogics + CLogic.CASLBasicSpec CBasic.CASLFORMULA + CBasic.SYMB_ITEMS + CBasic.SYMB_MAP_ITEMS + CSign.CASLSign + CMor.CASLMor + CSign.Symbol CMor.RawSymbol ProofTree where + sourceLogic Rigid2CASL = RLogic.RigidCASL + sourceSublogic Rigid2CASL = () + targetLogic Rigid2CASL = CLogic.CASL + mapSublogic Rigid2CASL _ = + Just cFol { cons_features = emptyMapConsFeature } + map_theory Rigid2CASL = mapTheory + map_morphism Rigid2CASL = undefined + map_sentence Rigid2CASL sig sen = + map_sentence (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) + (RSign.caslSign sig) sen + map_symbol Rigid2CASL _ = undefined + has_model_expansion Rigid2CASL = True + com_path Rigid2CASL = "Comorphisms.Rigid2CASL" + +mapTheory :: (RSign.RSign, [Named CBasic.CASLFORMULA]) -> + Result (CSign.CASLSign, [Named CBasic.CASLFORMULA]) +mapTheory (sig, nsens) = do + let csig = RSign.caslSign sig + (csig', csens') <- + map_theory (BaseCom.CASL2SubCFOL True BaseCom.NoMembershipOrCast) + (csig, nsens) + return (csig', csens') diff --git a/Comorphisms/Rigid2HPAR.hs b/Comorphisms/Rigid2HPAR.hs new file mode 100644 index 0000000000..980d9d1310 --- /dev/null +++ b/Comorphisms/Rigid2HPAR.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{- | +Module : ./Comorphisms/Rigid2HPAR.hs +Description : embedding from RigidCASL to HPAR +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +The embedding comorphism from RigidCASL to HPAR. + +-} + +module Comorphisms.Rigid2HPAR where + +import Logic.Logic +import Logic.Comorphism +import qualified Data.Set as Set +import qualified Data.Map as Map +--import Common.ProofTree +import Common.Result +import Common.AS_Annotation +import Common.Id + +-- Rigid CASL +import qualified RigidCASL.Logic_RigidCASL as RLogic +import qualified RigidCASL.Sign as RSign +import qualified RigidCASL.AS_Rigid as RBasic +import qualified RigidCASL.Morphism as RMorphism + +-- HPAR +import qualified HPAR.Logic_HPAR as HLogic +import qualified HPAR.AS_Basic_HPAR as HBasic +import qualified HPAR.Sign as HSign +import qualified HPAR.Morphism as HMorphism +import qualified HPAR.Symbol as HSym + +-- CASL +import qualified CASL.AS_Basic_CASL as CBasic +import qualified CASL.Sign as CSign () +import qualified CASL.Morphism as CMor + +-- | The identity of the comorphism +data Rigid2HPAR = Rigid2HPAR deriving (Show) + +instance Language Rigid2HPAR -- default definition is okay + +instance Comorphism Rigid2HPAR + RLogic.RigidCASL () + RBasic.R_BASIC_SPEC CBasic.CASLFORMULA CBasic.SYMB_ITEMS CBasic.SYMB_MAP_ITEMS + RSign.RSign + RMorphism.RigidMor + RBasic.RigidSymbol CMor.RawSymbol () + HLogic.HPAR () + HBasic.H_BASIC_SPEC HBasic.HFORMULA HBasic.H_SYMB_ITEMS + CBasic.SYMB_MAP_ITEMS + HSign.HSign HMorphism.HMorphism HSym.HSymbol CMor.RawSymbol () where + sourceLogic Rigid2HPAR = RLogic.RigidCASL + sourceSublogic Rigid2HPAR = () + targetLogic Rigid2HPAR = HLogic.HPAR + mapSublogic Rigid2HPAR _ = Just () + map_theory Rigid2HPAR = mapTheory + map_morphism Rigid2HPAR = undefined + map_sentence Rigid2HPAR = undefined + map_symbol Rigid2HPAR _ = undefined + has_model_expansion Rigid2HPAR = True + is_weakly_amalgamable Rigid2HPAR = True + isInclusionComorphism Rigid2HPAR = True + +mapTheory :: (RSign.RSign, [Named CBasic.CASLFORMULA]) -> + Result (HSign.HSign, [Named HBasic.HFORMULA]) +mapTheory (sig, nsens) = do + let tsig = HSign.HSign {HSign.baseSig = sig, + HSign.noms = Set.singleton $ genName "i", + HSign.mods = Map.empty} + tsens = map mapNamedSen nsens + return (tsig, tsens) + +mapNamedSen :: Named CBasic.CASLFORMULA -> Named HBasic.HFORMULA +mapNamedSen nsen = let + sen = sentence nsen + trans = HBasic.AtState (genToken "i") (HBasic.Base_formula sen nullRange) nullRange + in + nsen {sentence = trans} + + diff --git a/ExtModal/Keywords.hs b/ExtModal/Keywords.hs index 2d888d83a5..852cc3246e 100644 --- a/ExtModal/Keywords.hs +++ b/ExtModal/Keywords.hs @@ -54,8 +54,8 @@ atS = "@" hereS :: String hereS = "Here" -nominalS :: String -nominalS = "nominal" +--nominalS :: String +--nominalS = "nominal" timeS :: String timeS = "time" diff --git a/Framework/Analysis.hs b/Framework/Analysis.hs index bd3480335f..3944ec6983 100644 --- a/Framework/Analysis.hs +++ b/Framework/Analysis.hs @@ -13,6 +13,8 @@ module Framework.Analysis ( anaLogicDef , anaComorphismDef , addLogic2LogicList + , addHLogic + , addComorphism2ComorphismList ) where import Framework.AS @@ -186,6 +188,17 @@ addLogic2LogicList l = do else writeFile file contentsNew Left er -> error $ show er + +addHLogic :: String -> IO () +addHLogic hld = do + let file = dynLogicsDir ++ "/" ++ dynLogicsFile + contentsOld <- readFile file + let res = runParser (parserh hld) (emptyAnnos ()) "" contentsOld + case res of + Right contentsNew -> + writeFile file contentsNew + Left er -> error $ show er + {- ---------------------------------------------------------------------------- Comorphism analysis -} @@ -381,11 +394,90 @@ parser l = do do (xs, _) <- logParser `separatedBy` commaT cBracketT return xs - + hlg_var_decl <- do v <- asStr "dynHLogicList" + s <- asStr "::" + t <- do oBracketT + oParenT + asStr "String" + commaT + asStr "HLogicDef" + cParenT + cBracketT + return "[(String, HLogicDef)]" + return $ unwords [v, s, t] + hlog_var_def <- do v <- asStr "dynHLogicList" + s <- asStr "=" + return $ unwords [v, s] + hlog_list <- do oBracketT + (do cBracketT + return []) + <|> + do (xs, _) <- hLogParser `separatedBy` commaT + cBracketT + return xs return $ header ++ mod_decl ++ "\n\n" ++ intercalate "\n" (imps ++ [l_imp]) ++ "\n\n" ++ log_var_decl ++ "\n" ++ log_var_def ++ " " ++ "[" ++ - intercalate ", " (log_list ++ [l_log]) ++ "]" + intercalate ", " (log_list ++ [l_log]) ++ "]" ++ "\n\n" ++ + hlg_var_decl ++ "\n" ++ hlog_var_def ++ " " ++ "[\n " ++ + (intercalate " ,\n" hlog_list) ++ " ]" + +parserh :: String -> AParser st String +parserh hlog = do + header <- skipUntil "module" + mod_decl <- do m <- asStr "module" + n <- moduleName + w <- asStr "where" + return $ unwords [m, n, w] + imps <- many1 $ do + i <- asStr "import" + n <- moduleName + return $ unwords [i, n] + log_var_decl <- do v <- asStr dynLogicsCon + s <- asStr "::" + t <- do oBracketT + asStr "AnyLogic" + cBracketT + return "[AnyLogic]" + return $ unwords [v, s, t] + log_var_def <- do v <- asStr dynLogicsCon + s <- asStr "=" + return $ unwords [v, s] + log_list <- do oBracketT + (do cBracketT + return []) + <|> + do (xs, _) <- logParser `separatedBy` commaT + cBracketT + return xs + hlg_var_decl <- do v <- asStr "dynHLogicList" + s <- asStr "::" + t <- do oBracketT + oParenT + asStr "String" + commaT + asStr "HLogicDef" + cParenT + cBracketT + return "[(String, HLogicDef)]" + return $ unwords [v, s, t] + hlog_var_def <- do v <- asStr "dynHLogicList" + s <- asStr "=" + return $ unwords [v, s] + hlog_list <- do oBracketT + (do cBracketT + return []) + <|> + do (xs, _) <- hLogParser `separatedBy` commaT + cBracketT + return xs + return $ header ++ mod_decl ++ "\n\n" ++ + intercalate "\n" imps ++ "\n\n" ++ + log_var_decl ++ "\n" ++ log_var_def ++ " " ++ "[" ++ + intercalate ", " log_list ++ "]" ++ "\n\n" ++ + hlg_var_decl ++ "\n" ++ hlog_var_def ++ " " ++ "[\n " ++ + intercalate "\n ," (hlog_list ++ [hlog]) ++ " ]" + parserc :: String -> AParser st String parserc c = do @@ -442,6 +534,81 @@ moduleName = do n <- simpleId return $ tokStr m ++ "." ++ tokStr n +hLogParser :: AParser st String +hLogParser = do + l <- asStr "(" + char '"' + k <- simpleId + char '"' + c <- asStr "," + hld <- asStr "HLogicDef" + char '"' + hldn <- simpleId + char '"' + let parseHQ = do + l1 <- asStr "(" + char '"' + (strs, _) <- scanAnyWords `separatedBy` skip --TODO: this should only work for quants but not for logics! + let lg = concat $ intersperse " " strs + char '"' + c1 <- asStr "," + subl <- do + n <- asStr "Nothing" + return n + <|> do + j <- asStr "Just" + char '"' + sub <- simpleId + char '"' + return $ j ++ " \"" ++ tokStr sub ++ "\"" + r1 <- asStr ")" + return $ l1 ++ "\"" ++ lg ++ "\"" ++ c1 ++ " " ++ subl ++ r1 + <|> return "" + + parseConstr = do + s <- asStr "ReflexiveMod" + <|> asStr "TransitiveMod" + <|> asStr "SymmetricMod" + <|> asStr "SerialMod" + <|> asStr "EuclideanMod" + <|> asStr "FunctionalMod" + <|> asStr "LinearMod" + <|> asStr "TotalMod" + <|> do + s1 <- asStr sameInterpretationS + char '"' -- _oP <- oParenT + (str, _) <- scanAnyWords `separatedBy` skip -- ) `separatedBy` commaT + char '"' -- _cP <- cParenT + return $ s1 ++ "\"" ++ (concat $ intersperse " " str) ++ "\"" + -- this needs testing! + <|> do + s1 <- asStr sameDomainS + _ <- skip + arg <- asStr "False" <|> asStr "True" + _ <- skip + return $ s1 ++ " " ++ arg + <|> do + return "" + return s + + hldb <- parseHQ + hldf <- asStr "True" <|> asStr "False" + _ <- oBracketT + (hldc, _) <- parseConstr `separatedBy` commaT + _ <- cBracketT + _ <- oBracketT + (hldq, _) <- parseHQ `separatedBy` commaT + _ <- cBracketT +-- HLogicDef aString +-- (bString, Nothing) | (bString, Just cString) +-- True | False +-- [semconstr] -- still need a parser for this one! +-- [(String, Nothing) | (String, Just String) `separatedBy`] + let hldString = intercalate " " + [hld, "\"" ++ tokStr hldn ++ "\"", hldb, hldf, "[" ++ (intercalate "," hldc) ++ "]", "[" ++ (intercalate "," hldq) ++ "]"] + r <- asStr ")" + return $ l ++ "\"" ++ tokStr k ++ "\"" ++ c ++ " " ++ hldString ++ r + logParser :: AParser st String logParser = do l <- asKey "Logic" diff --git a/Framework/WriteLogicUtils.hs b/Framework/WriteLogicUtils.hs index 7a90dc3d73..0053094943 100644 --- a/Framework/WriteLogicUtils.hs +++ b/Framework/WriteLogicUtils.hs @@ -22,6 +22,9 @@ multiOpt = "MultiParamTypeClasses" synOpt :: String synOpt = "TypeSynonymInstances" +flexOpt :: String +flexOpt = "FlexibleInstances" + prefixBy :: String -> [String] -> [String] prefixBy s = map (s ++) diff --git a/GenHyb/GenComor.hs b/GenHyb/GenComor.hs new file mode 100644 index 0000000000..d7332208c5 --- /dev/null +++ b/GenHyb/GenComor.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, FlexibleContexts #-} +{- | +Module : ./GenHyb/GenComor +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +Generic methods for hybridisation of comorphisms. +-} + +module GenHyb.GenComor where + +import Logic.Logic +import Logic.Comorphism +import qualified Data.Set as Set +import qualified Data.Map as Map +import Common.ProofTree +import Common.Result +import Common.AS_Annotation +import Common.GlobalAnnotations +import Common.Id +import qualified Common.Lib.MapSet as MapSet + + +import Control.Monad (foldM) + +-- CASL +import qualified CASL.Logic_CASL as CLogic +import qualified CASL.AS_Basic_CASL as CBasic +import qualified CASL.Sign as CSign +import qualified CASL.Morphism as CMor +import CASL.Sublogic +import qualified CASL.Induction as CInd + +-- generic hybrid logic +import qualified GenHyb.GenTypes as GTypes +import qualified GenHyb.GenMethods as GMethods + +-- methods only on CASL types, copied from HPAR2CASL + +getVarSorts :: Set.Set CBasic.SORT -> CBasic.CASLFORMULA -> Set.Set CBasic.SORT +getVarSorts oldS sen = + case sen of + CBasic.Quantification _ vdecls f _ -> + Set.union + (Set.fromList $ + map (\(CBasic.Var_decl _ s _) -> s) vdecls) $ getVarSorts oldS f + CBasic.Junction _ fs _ -> foldl (\s f -> getVarSorts s f) oldS fs + CBasic.Relation f1 _ f2 _ -> + Set.union (getVarSorts oldS f1) (getVarSorts oldS f2) + CBasic.Negation f _ -> getVarSorts oldS f + CBasic.Atom _ _ -> oldS + CBasic.Definedness _ _ -> oldS + CBasic.Predication _ _ _ -> oldS + CBasic.Equation _ _ _ _ -> oldS + _ -> error $ "GenHyb.GenComor.getVarSorts: Illegal argument " ++ show sen + +addSortToOpType :: Id -> CBasic.OP_TYPE -> CBasic.OP_TYPE +addSortToOpType stStr (CBasic.Op_type k w s r1) = + CBasic.Op_type k (stStr:w) s r1 + +addSortToPredType :: Id -> CBasic.PRED_TYPE -> CBasic.PRED_TYPE +addSortToPredType stStr (CBasic.Pred_type w r1) = + CBasic.Pred_type (stStr : w) r1 + +addVarToTerm :: Id -> CBasic.VAR -> CBasic.TERM () -> CBasic.TERM () +addVarToTerm stStr v t = case t of + CBasic.Qual_var _ _ _ -> t + CBasic.Application (CBasic.Qual_op_name f o r2) args r -> + CBasic.Application + (CBasic.Qual_op_name f (addSortToOpType stStr o) r2) + ((CBasic.Qual_var v stStr nullRange):(map (addVarToTerm stStr v) args)) r + _ -> error $ "GenHyb.GenComor.addVarToTerm: can't add var to term " ++ show t + +addX :: Id -> CBasic.VAR -> CBasic.CASLFORMULA -> CBasic.CASLFORMULA +addX stStr v sen = case sen of + CBasic.Quantification q vdecls f r -> + CBasic.Quantification q vdecls (addX stStr v f) r + CBasic.Junction j fs r -> + CBasic.Junction j (map (addX stStr v) fs) r + CBasic.Relation f1 rel f2 r -> + CBasic.Relation (addX stStr v f1) rel (addX stStr v f2) r + CBasic.Negation f r -> + CBasic.Negation (addX stStr v f) r + CBasic.Atom _ _ -> sen + CBasic.Definedness t r -> + CBasic.Definedness (addVarToTerm stStr v t) r + CBasic.Predication (CBasic.Qual_pred_name p t r2) terms r -> + CBasic.Predication + (CBasic.Qual_pred_name p (addSortToPredType stStr t) r2) + ((CBasic.Qual_var v stStr nullRange):(map (addVarToTerm stStr v) terms)) + r + CBasic.Equation t1 eq t2 r -> + CBasic.Equation (addVarToTerm stStr v t1) eq (addVarToTerm stStr v t2) r + _ -> error $ "Illegal argument for addX in HPAR2CASL.hs: " ++ show sen + +replaceVarAppls :: CBasic.VAR -> CBasic.SORT -> CBasic.CASLFORMULA -> + CBasic.CASLFORMULA +replaceVarAppls v s sen = case sen of + CBasic.Quantification q vdecls f r -> + CBasic.Quantification q vdecls (replaceVarAppls v s f) r + CBasic.Junction j fs r -> + CBasic.Junction j (map (replaceVarAppls v s) fs) r + CBasic.Relation f1 rel f2 r -> + CBasic.Relation (replaceVarAppls v s f1) rel (replaceVarAppls v s f2) r + CBasic.Negation f r -> + CBasic.Negation (replaceVarAppls v s f) r + CBasic.Atom _ _ -> sen + CBasic.Definedness t r -> + CBasic.Definedness (replTermWithVar v s t) r + CBasic.Predication p terms r -> + CBasic.Predication p (map (replTermWithVar v s) terms) r + CBasic.Equation t1 eq t2 r -> + CBasic.Equation (replTermWithVar v s t1) eq (replTermWithVar v s t2) r + _ -> error $ + "Illegal argument for replaceVarAppls in HPAR2CASL.hs: " ++ show sen + +replTermWithVar :: CBasic.VAR -> CBasic.SORT -> CBasic.TERM () -> + CBasic.TERM () +replTermWithVar v s t = case t of + CBasic.Application op@(CBasic.Qual_op_name f _o _r2) args r -> + if simpleIdToId v == f + then CBasic.Qual_var v s nullRange + else CBasic.Application op (map (replTermWithVar v s) args) r + _ -> t + +-- map theory + +mapTheoryConstr :: (Comorphism cid lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + CLogic.CASL CASL_Sublogics + CLogic.CASLBasicSpec CBasic.CASLFORMULA + CBasic.SYMB_ITEMS + CBasic.SYMB_MAP_ITEMS + CSign.CASLSign + CMor.CASLMor + CSign.Symbol CMor.RawSymbol ProofTree, + Logic hlid hsublogics hbasic_spec hsen + hsymb_items hsymb_map_items (GTypes.HSign sig) + hmor hsym hraw_sym hproof_tree) + => + cid + -- base comorphism + -> hlid + -- hybrid logic, source of the generated comorphism. + -- we only need it to + -- 1. check that the data logic fits + -- 2. get its semantic constraints + -> (GTypes.HSign sig, + [Named (GTypes.HFORMULA sen symb_items raw_sym)]) + -- the theory + -> Result (CSign.CASLSign, [Named CBasic.CASLFORMULA]) +mapTheoryConstr cid hlid (hsig, nhsens) = do + -- 0. preliminaries + let baseLid = sourceLogic cid + mapBTheory = map_theory cid + mapBSen = map_sentence cid + -- TODO: check that the data_logic of hlid is actually baseLid + -- 1. map base signature + (csig, csens) <- mapBTheory (GTypes.baseSig hsig, []) + -- 2. auxiliaries + let st = genName $ "ST_" ++ show hlid + v = genToken "X" + domain = genName $ "domain_" ++ show hlid + -- 3. variables in \Gamma_\Sigma + cvars = foldl (\vars asen -> getVarSorts vars $ sentence asen) + Set.empty csens + -- 4. e -> forall gn_X : gn_ST . e(X) + csens' = -- trace ("cvars:" ++ show cvars) $ + map (\f -> f { sentence = CBasic.Quantification + CBasic.Universal + [CBasic.Var_decl [v] st nullRange] + (addX st v $ sentence f) nullRange} ) + csens + -- 5. this one has gn_ST + stsig <- CSign.addSymbToSign (CSign.emptySign ()) $ + CSign.Symbol st CSign.SortAsItemType + -- 6. this one has [S_\Sigma] + sortsig <- foldM (\aSig x -> CSign.addSymbToSign aSig $ + CSign.Symbol x CSign.SortAsItemType) + stsig $ Set.toList $ CSign.sortSet csig + -- 7. this one has \overline{Nom} + nomsig <- foldM (\aSig x -> CSign.addSymbToSign aSig $ + CSign.Symbol x $ CSign.OpAsItemType $ + CSign.OpType CBasic.Total [] st) + sortsig $ GTypes.noms hsig + -- 8. this one has [F_\Sigma] + opsig <- foldM (\aSig (i, CSign.OpType k w s) -> + CSign.addSymbToSign aSig $ + CSign.Symbol i $ CSign.OpAsItemType $ + CSign.OpType k (st:w) s) + nomsig $ MapSet.toPairList $ CSign.opMap csig + -- 9. this is D_F_\Sigma + let domsens = + foldl (\sens (f, o@(CSign.OpType _ w s)) -> + let ydecl = CBasic.mkVarDecl (genToken "w") st + xsdecl = map (\(si, ii) -> + CBasic.mkVarDecl + (genToken $ "x" ++ show ii) si) $ + zip w [1::Int ..] + df = CBasic.mkForall [ydecl] $ + CBasic.mkForall xsdecl $ + CBasic.mkImpl + (CBasic.conjunct $ + map (\xidecl -> case xidecl of + CBasic.Var_decl [xi] si _ -> + CBasic.mkPredication + (CBasic.mkQualPred domain $ + CBasic.Pred_type [st, si] nullRange) + [CBasic.Qual_var (genToken "w") + st nullRange, + CBasic.Qual_var xi si nullRange] + _ -> error "domsens" + ) xsdecl + ) + (CBasic.mkPredication + (CBasic.mkQualPred domain $ + CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "w") st nullRange, + CBasic.mkAppl + (CBasic.Qual_op_name f + (addSortToOpType st $ CSign.toOP_TYPE o) + nullRange) + (map CBasic.toQualVar $ ydecl:xsdecl) + ] + ) + in (makeNamed ("ga_domain_"++show f) df):sens + ) + [] $ MapSet.toPairList $ CSign.opMap csig + -- 10. this one has [P_\Sigma] + predsig <- foldM (\aSig (i, CSign.PredType w) -> + CSign.addSymbToSign aSig $ + CSign.Symbol i $ CSign.PredAsItemType $ + CSign.PredType (st:w)) + opsig $ MapSet.toPairList $ CSign.predMap csig + -- 11. this one has D_s + domsig <- foldM (\aSig s -> + CSign.addSymbToSign aSig $ + CSign.Symbol domain $ CSign.PredAsItemType $ + CSign.PredType [st, s]) + predsig $ Set.toList $ CSign.sortSet csig + -- 12. this one has \overline{\Lambda} + lamsig <- foldM (\aSig (l, x) -> + CSign.addSymbToSign aSig $ + CSign.Symbol l $ CSign.PredAsItemType $ + CSign.PredType $ take x $ repeat st) + domsig $ Map.toList $ GTypes.mods hsig + -- 13. translate sentences from HPAR to CASL + let ncsens = map (mapNamedSentence (show hlid) mapBTheory + mapBSen baseLid hsig) + nhsens + -- 14. add constraints as CASL sentences + constrsens <- foldM (\l1 sc -> do + l2 <- constr_to_sens hlid hsig (show hlid) sc + return $ l1 ++ l2) [] $ sem_constr hlid + -- 15. this is V(\Gamma_Sigma) + let makeVSen s = makeNamed ("ga_V_"++show s) + $ CBasic.mkForall [CBasic.mkVarDecl (genToken "w") st, + CBasic.mkVarDecl (genToken "x") s] + $ CBasic.mkPredication + (CBasic.mkQualPred domain $ + CBasic.Pred_type [st, s] nullRange) + [CBasic.Qual_var (genToken "w") st nullRange, + CBasic.Qual_var (genToken "x") s nullRange] + vsens = map makeVSen $ Set.toList cvars + -- 16. return results + -- trace (concatMap (\x -> show x ++ "\n") ncsens) $ + return (lamsig, csens' ++ vsens ++ domsens ++ ncsens ++ constrsens) + + +mapNamedSentence :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree => + String -> -- name of the hybrid logic, for generated names + ((sig, [Named sen]) -> + Result (CSign.CASLSign, [Named CBasic.CASLFORMULA])) -> + (sig -> sen -> Result CBasic.CASLFORMULA) -> + lid -> + GTypes.HSign sig -> + Named (GTypes.HFORMULA sen symb_items raw_sym) -> + Named CBasic.CASLFORMULA +mapNamedSentence hl mapBTheory mapBSen baseLid hsig nsen = + nsen {sentence = mapHSentence hl mapBTheory mapBSen baseLid hsig $ + sentence nsen} + +mapHSentence :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree => + String -> + ((sig, [Named sen]) -> + Result (CSign.CASLSign, [Named CBasic.CASLFORMULA])) -> + (sig -> sen -> Result CBasic.CASLFORMULA) -> + lid -> + GTypes.HSign sig -> + GTypes.HFORMULA sen symb_items raw_sym -> + CBasic.CASLFORMULA +mapHSentence hl mapBTheory mapBSen baseLid hsig hsen = + let + x = genToken "X" + st = genName $ "ST_" ++ hl + hth = GMethods.HTheoryAna hsig Set.empty [] [] emptyGlobalAnnos [] + in CBasic.mkForall [CBasic.mkVarDecl x st] $ + mapSentenceAux hl mapBTheory mapBSen baseLid hth x st 0 hsen + +isVar :: Token -> GMethods.HTheoryAna sig sen symb_items raw_sym sym -> Bool +isVar nom hth = + let + nomVars = concatMap (\x -> case x of + GTypes.ASymbol (GTypes.HSymb n GTypes.Nom) -> + [n] + _ -> []) $ + GMethods.hVars hth + in (simpleIdToId nom) `elem` nomVars + +mapSentenceAux :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree => + String -> + ((sig, [Named sen]) -> + Result (CSign.CASLSign, [Named CBasic.CASLFORMULA])) -> + (sig -> sen -> Result CBasic.CASLFORMULA) -> + lid -> + GMethods.HTheoryAna sig sen symb_items raw_sym sym -> + CBasic.VAR -> CBasic.SORT -> Int -> + GTypes.HFORMULA sen symb_items raw_sym -> + CBasic.CASLFORMULA +mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index hsen = case hsen of + GTypes.Nominal _s b i _ -> CBasic.mkStEq + (CBasic.Qual_var x st nullRange) $ + if b then CBasic.Qual_var i st nullRange + else CBasic.Application + (CBasic.mkQualOp (simpleIdToId i) $ + CBasic.Op_type CBasic.Total [] st nullRange) + [] nullRange + GTypes.Base_formula f _ -> let + hsig = GMethods.hSign hth + Result ds f' = mapBSen (GTypes.baseSig hsig) f + in case f' of + Nothing -> error $ "can't translate sentence: " ++ show ds + Just f'' -> addX st x f'' + GTypes.AtState _s nom hf _ -> + let cf = mapSentenceAux hl mapBTheory mapBSen baseLid hth x st index hf + t = if isVar nom hth then CBasic.Qual_var nom st nullRange else + CBasic.mkAppl (CBasic.mkQualOp (simpleIdToId nom) $ + CBasic.Op_type CBasic.Total [] st nullRange) + [] + in CInd.substitute x st t cf + -- mapSentenceAux i st sen does not work, + -- because i should not be a var. apply a substitution of x with i instead + GTypes.Negation hf _ -> + CBasic.Negation + (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index hf) nullRange + GTypes.Conjunction hfs _ -> + CBasic.Junction CBasic.Con + (map (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index) hfs) nullRange + GTypes.Disjunction hfs _ -> + CBasic.Junction CBasic.Dis + (map (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index) hfs) nullRange + GTypes.Implication hf1 hf2 _ -> + CBasic.Relation (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index hf1) + CBasic.Implication + (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index hf2) + nullRange + GTypes.Equivalence hf1 hf2 _ -> + CBasic.Relation (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index hf1) + CBasic.Equivalence + (mapSentenceAux hl mapBTheory mapBSen baseLid + hth x st index hf2) + nullRange + GTypes.BoxFormula _s md hf _ -> + let yName = genToken $ "Y" ++ show index in + CBasic.mkForall [CBasic.mkVarDecl yName st] $ + CBasic.mkImpl + (CBasic.mkPredication (CBasic.mkQualPred (simpleIdToId md) $ + CBasic.Pred_type [st,st] nullRange) + [CBasic.Qual_var x st nullRange, CBasic.Qual_var yName st nullRange]) $ + mapSentenceAux hl mapBTheory mapBSen baseLid hth yName st (index+1) hf + GTypes.DiamondFormula _s md hf _ -> + let yName = genToken $ "Y" ++ show index in + CBasic.mkExist [CBasic.mkVarDecl yName st] $ + CBasic.Junction CBasic.Con + [CBasic.mkPredication (CBasic.mkQualPred (simpleIdToId md) $ + CBasic.Pred_type [st,st] nullRange) + [CBasic.Qual_var x st nullRange, CBasic.Qual_var yName st nullRange], + mapSentenceAux hl mapBTheory mapBSen baseLid hth yName st (index+1) hf] + nullRange + GTypes.QuantNominals q noms hf _ -> + (case q of + GTypes.HUniversal _ -> CBasic.mkForall + GTypes.HExistential _ -> CBasic.mkExist) + (map (\n -> CBasic.mkVarDecl n st) noms) + $ mapSentenceAux hl mapBTheory mapBSen baseLid + (hth { + GMethods.hVars = foldl (\l n -> (GTypes.ASymbol $ + GTypes.HSymb (simpleIdToId n) + GTypes.Nom) + :l) + (GMethods.hVars hth) noms + } + ) + x st index hf + GTypes.QuantVarsParse _ _ _ _ -> + error "GenHyb.GenComor.mapSentenceAux: sentence not parsed" + GTypes.QuantVars q vars hf _ -> let + hsig = GMethods.hSign hth + domainSen xi si = CBasic.mkPredication + (CBasic.mkQualPred (genName $ "domain_" ++ hl) $ + CBasic.Pred_type [st, si] nullRange) + [CBasic.Qual_var x st nullRange, + CBasic.mkAppl (CBasic.Qual_op_name (simpleIdToId xi) + (addSortToOpType st $ + CBasic.Op_type CBasic.Total + [] si nullRange) + nullRange) + [CBasic.Qual_var x st nullRange]] + baseSig = GTypes.baseSig hsig + Result ds resTh = mapBTheory (baseSig, []) + (_, csens) = case resTh of + Nothing -> error $ "could not translate theory:" ++ show ds + Just th -> th + addVarAsConst bSig vi = + let Result ds' resTh' = add_symb_to_sign baseLid bSig vi + in case resTh' of + Nothing -> error $ "could not add variable as constant:" ++ show ds' + Just th -> th + getCSens vi = let + Result ds'' resTh'' = mapBTheory (addVarAsConst baseSig vi, []) + in case resTh'' of + Nothing -> + error $ + "could not translate theory with added variable:" ++ show ds'' + Just (_, sens) -> sens + -- keep the sentences that appear only in the second list of sentences + gamma_xi vi = map (\f -> + f { sentence = CBasic.Quantification + CBasic.Universal + [CBasic.Var_decl [genToken "w"] + st nullRange] + (addX st (genToken "w") $ sentence f) + nullRange + } + ) $ + filter (\s -> not (s `elem` csens)) $ + getCSens vi + vis = map (\v -> case raw_to_symbol baseLid v of + Nothing -> error $ "could not convert raw to symbol" + Just y -> y) vars + baseSigVars = foldl addVarAsConst baseSig vis + hsig' = hsig {GTypes.baseSig = baseSigVars} + cvars = map (\rs -> case raw_to_var baseLid rs of + Nothing -> error $ + "could not convert symbol to variable: " + ++ show rs + Just (v, s) -> (v, s) ) vars + senWithVarAppl = let + conds = CBasic.Junction CBasic.Con ( + (map sentence $ concatMap gamma_xi vis) + ++ + (map (\(xi,si) -> domainSen xi si) + cvars) + )nullRange + mapHF = mapSentenceAux hl mapBTheory mapBSen baseLid + (hth {GMethods.hSign = hsig'}) + x st index hf + in + case q of + GTypes.HUniversal _ -> + CBasic.mkImpl conds mapHF + GTypes.HExistential _ -> + CBasic.conjunct [conds, mapHF] + senRepl = foldl (\csen (xi,si) -> replaceVarAppls xi si csen) + senWithVarAppl cvars + in (case q of + GTypes.HUniversal _ -> CBasic.mkForall + GTypes.HExistential _ -> CBasic.mkExist) + (map (\(v,s) -> CBasic.mkVarDecl v s) cvars) senRepl + + diff --git a/GenHyb/GenInsts.hs b/GenHyb/GenInsts.hs new file mode 100644 index 0000000000..317f6b27a6 --- /dev/null +++ b/GenHyb/GenInsts.hs @@ -0,0 +1,788 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances, DeriveDataTypeable #-} +{- | +Module : ./GenHyb/GenInsts +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +Generic instances for the types used in hybridisation. +-} + +module GenHyb.GenInsts where + +--import Logic.Logic +import Common.Id +import Common.Doc +import Common.DocUtils +import qualified Data.Set as Set +import qualified Data.Map as Map +import GenHyb.GenTypes + +import ATerm.Lib +import ATC.Id () +import ATC.AS_Annotation () + +-- for HSign + +instance (Pretty sig) => Pretty (HSign sig) where + pretty = printSign False -- IMPORTANT: True for engineering syntax + +printSign :: (Pretty sig) => Bool -> HSign sig -> Doc +printSign eng hsig = + let bsig = baseSig hsig in + pretty bsig + $+$ + let nomss = Set.toList $ noms hsig + nomKey = if eng then "state" else "nominal" + modKey = if eng then "event" else "modality" + modsKey = if eng then "events" else "modalities" + in + case nomss of + [] -> empty + _ -> hsep [text (nomKey ++ (case nomss of + [_] -> "" + _ -> "s")), sepByCommas $ map pretty nomss] + $+$ + (foldl (\aDoc (i,n) -> aDoc $+$ + hsep [text ( case Map.toList $ mods hsig of + [_] -> modKey + _ -> modsKey + ), + pretty i, + text ":", + pretty n]) empty $ Map.toList $ mods hsig) + +instance (ShATermConvertible sig) => ShATermConvertible (HSign sig) where + toShATermAux att0 xv = case xv of + HSign a b c -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "HSign" [a', b', c'] []) att3 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "HSign" [a, b, c] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, HSign a' b' c') }}} + u -> fromShATermError "HSign" u + +-- for HMorphism + +instance (Pretty sig, Pretty mor) => Pretty (HMorphism sig mor) where + pretty = printMorphism + +printMorphism :: (Pretty sig, Pretty mor) => HMorphism sig mor -> Doc +printMorphism _hmor = error "printmorphism nyi" + +instance (ShATermConvertible sig, ShATermConvertible mor) + => ShATermConvertible (HMorphism sig mor) where + toShATermAux att0 xv = case xv of + HMorphism a b c d e -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + (att4, d') <- toShATerm' att3 d + (att5, e') <- toShATerm' att4 e + return $ addATerm (ShAAppl "HMorphism" [a', b', c', d', + e'] []) att5 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "HMorphism" [a, b, c, d, e] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + case fromShATerm' d att3 of + { (att4, d') -> + case fromShATerm' e att4 of + { (att5, e') -> + (att5, HMorphism a' b' c' d' e') }}}}} + u -> fromShATermError "HMorphism" u + +-- for HFORMULA + +instance (Pretty sen, Pretty raw_sym, Show symb_items) => + Pretty (HFORMULA sen symb_items raw_sym) + where + pretty = printFormula False + -- IMPORTANT: True for engineering syntax + +printFormula :: (Pretty sen, Pretty raw_sym, Show symb_items) => + Bool -> HFORMULA sen symb_items raw_sym -> Doc +printFormula eng aFrm = case aFrm of + Base_formula pfrm _ -> pretty pfrm + Nominal s _ nom _ -> if s == "" + then pretty nom + else pretty nom <+> text "::" <+> pretty s + AtState s nom frm _ -> + if eng then + keyword "At state"<+> + (if s == "" then pretty nom + else pretty nom <+> text "::" <+> pretty s) <+> + comma <+> printFormula eng aFrm + else + prettyAt <+> (if s == "" + then pretty nom + else pretty nom <+> text "::" <+> pretty s) <+> + colon <+> printFormula eng frm + BoxFormula s md frm _ -> + if eng then + keyword "Through" <+> (if s == "" + then pretty md + else pretty md <+> text "::" <+> pretty s) <+> + comma <+> keyword "always" <+> printFormula eng frm + else + lbrack <+> + (if s == "" then pretty md + else pretty md <+> text "::" <+> pretty s) <+> + rbrack <+> printFormula eng frm + DiamondFormula s md frm _ -> + if eng then + keyword "Through" <+> + (if s == "" then pretty md + else pretty md <+> text "::" <+> pretty s) <+> + comma <+> keyword "sometimes" <+> printFormula eng frm + else + text "<" <+> (if s == "" then pretty md + else pretty md <+> text "::" <+> pretty s) <+> + text ">" <+> printFormula eng frm + Negation frm _ -> notDoc <+> printFormula eng frm + Conjunction xs _ -> sepByArbitrary andDoc $ + map (printFormula eng) xs + Disjunction xs _ -> sepByArbitrary orDoc $ + map (printFormula eng) xs + Implication x y _ -> printFormula eng x <+> + implies <+> printFormula eng y + Equivalence x y _ -> printFormula eng x <+> + equiv <+> printFormula eng y + QuantVarsParse _ _ _ _ -> error $ "formula not yet analyzed" + QuantVars q rsyms frm _ -> printQuant q <+> pretty rsyms <+> + bullet <+> printFormula eng frm + -- TODO: this is now bad because we get brackets around the rsyms + QuantNominals q nomVars frm _ -> printQuant q <+> keyword nomS <+> + sepByCommas (map pretty nomVars) <+> + bullet <+> printFormula eng frm + +instance (GetRange sen, GetRange raw_sym, GetRange symb_items) => + GetRange (HFORMULA sen symb_items raw_sym) + where + getRange _ = nullRange + rangeSpan x = case x of + Base_formula a b -> joinRanges [rangeSpan a, rangeSpan b] + Negation a b -> joinRanges [rangeSpan a, rangeSpan b] + Conjunction a b -> joinRanges [rangeSpan a, rangeSpan b] + Disjunction a b -> joinRanges [rangeSpan a, rangeSpan b] + Implication a b c -> joinRanges [rangeSpan a, rangeSpan b, + rangeSpan c] + Equivalence a b c -> joinRanges [rangeSpan a, rangeSpan b, + rangeSpan c] + Nominal s a b c -> joinRanges [rangeSpan s, rangeSpan a, + rangeSpan b, rangeSpan c] + AtState s a b c -> joinRanges [rangeSpan s, rangeSpan a, + rangeSpan b, rangeSpan c] + BoxFormula s a b c -> joinRanges [rangeSpan s, rangeSpan a, + rangeSpan b, rangeSpan c] + DiamondFormula s a b c -> joinRanges [rangeSpan s, rangeSpan a, + rangeSpan b, rangeSpan c] + QuantVarsParse a b c d -> joinRanges [rangeSpan a, rangeSpan b, + rangeSpan c, rangeSpan d] + QuantVars a b c d -> joinRanges [rangeSpan a, rangeSpan b, + rangeSpan c, rangeSpan d] + QuantNominals a b c d -> joinRanges [rangeSpan a, rangeSpan b, + rangeSpan c, rangeSpan d] + +printQuant :: HQUANT -> Doc +printQuant (HUniversal s) = + if s == "" then forallH + else forallH <+> text "::" <+> pretty s +printQuant (HExistential s) = + if s == "" then existsH + else forallH <+> text "::" <+> pretty s + +instance GetRange HQUANT where + getRange = const nullRange + rangeSpan x = case x of + HUniversal _ -> [] + HExistential _ -> [] + +instance ShATermConvertible HQUANT where + toShATermAux att0 xv = case xv of + HUniversal _ -> return $ addATerm (ShAAppl "HUniversal" [] []) att0 + HExistential _ -> return $ addATerm (ShAAppl "HExistential" [] []) att0 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "HUniversal" [] _ -> (att0, HUniversal "") + ShAAppl "HExistential" [] _ -> (att0, HExistential "") + u -> fromShATermError "HQUANT" u + +instance (ShATermConvertible sen, ShATermConvertible raw_sym, + ShATermConvertible symb_items) => + ShATermConvertible (HFORMULA sen symb_items raw_sym) where + toShATermAux att0 xv = case xv of + Base_formula a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "Base_formula" [a', b'] []) att2 + Negation a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "Negation" [a', b'] []) att2 + Conjunction a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "Conjunction" [a', b'] []) att2 + Disjunction a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "Disjunction" [a', b'] []) att2 + Implication a b c -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "Implication" [a', b', c'] []) att3 + Equivalence a b c -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "Equivalence" [a', b', c'] []) att3 + Nominal s a b c -> do + (att', s') <- toShATerm' att0 s + (att1, a') <- toShATerm' att' a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "Nominal" [s', a', b', c'] []) att3 + AtState s a b c -> do + (att', s') <- toShATerm' att0 s + (att1, a') <- toShATerm' att' a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "AtState" [s', a', b', c'] []) att3 + BoxFormula s a b c -> do + (att', s') <- toShATerm' att0 s + (att1, a') <- toShATerm' att' a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "BoxFormula" [s', a', b', c'] []) att3 + DiamondFormula s a b c -> do + (att', s') <- toShATerm' att0 s + (att1, a') <- toShATerm' att' a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "DiamondFormula" [s', a', b', c'] []) att3 + QuantVarsParse a b c d -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + (att4, d') <- toShATerm' att3 d + return $ addATerm (ShAAppl "QuantVarsParse" [a', b', c', + d'] []) att4 + QuantVars a b c d -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + (att4, d') <- toShATerm' att3 d + return $ addATerm (ShAAppl "QuantVars" [a', b', c', + d'] []) att4 + QuantNominals a b c d -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + (att4, d') <- toShATerm' att3 d + return $ addATerm (ShAAppl "QuantNominals" [a', b', c', + d'] []) att4 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Base_formula" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, Base_formula a' b') }} + ShAAppl "Negation" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, Negation a' b') }} + ShAAppl "Conjunction" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, Conjunction a' b') }} + ShAAppl "Disjunction" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, Disjunction a' b') }} + ShAAppl "Implication" [a, b, c] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, Implication a' b' c') }}} + ShAAppl "Equivalence" [a, b, c] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, Equivalence a' b' c') }}} + ShAAppl "Nominal" [s, a, b, c] _ -> + case fromShATerm' s att0 of + { (att', s') -> + case fromShATerm' a att' of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, Nominal s' a' b' c') }}}} + ShAAppl "AtState" [s, a, b, c] _ -> + case fromShATerm' s att0 of + { (att', s') -> + case fromShATerm' a att' of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, AtState s' a' b' c') }}}} + ShAAppl "BoxFormula" [s, a, b, c] _ -> + case fromShATerm' s att0 of + { (att', s') -> + case fromShATerm' a att' of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, BoxFormula s' a' b' c') }}}} + ShAAppl "DiamondFormula" [s, a, b, c] _ -> + case fromShATerm' s att0 of + { (att', s') -> + case fromShATerm' a att' of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, DiamondFormula s' a' b' c') }}}} + ShAAppl "QuantVarsParse" [a, b, c, d] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + case fromShATerm' d att3 of + { (att4, d') -> + (att4, QuantVarsParse a' b' c' d') }}}} + ShAAppl "QuantVars" [a, b, c, d] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + case fromShATerm' d att3 of + { (att4, d') -> + (att4, QuantVars a' b' c' d') }}}} + ShAAppl "QuantNominals" [a, b, c, d] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + case fromShATerm' d att3 of + { (att4, d') -> + (att4, QuantNominals a' b' c' d') }}}} + u -> fromShATermError "HFORMULA" u + + +sepByArbitrary :: Doc -> [Doc] -> Doc -- move to Common.Doc +sepByArbitrary d = fsep . prepPunctuate (d <> space) + +forallH, existsH :: Doc +forallH = text "forallH" +existsH = text "existsH" + +-- for H_BASIC_SPEC + +instance Pretty NOM_ITEM where + pretty = printNomItem + +instance Pretty MOD_ITEM where + pretty = printModItem + +printNomItem :: NOM_ITEM -> Doc +printNomItem (Nom_item xs _) = + keyword (nomS ++ case xs of + [_] -> "" + _ -> "s") <+> ppWithCommas xs + +printModItem :: MOD_ITEM -> Doc +printModItem (Mod_item xs i _) = undefined + keyword (modS ++ case xs of + [_] -> "" + _ -> "s") <+> ppWithCommas xs <+> colon <+> pretty i + +instance (ShATermConvertible sen, ShATermConvertible raw_sym, + ShATermConvertible symb_items) + => ShATermConvertible (H_BASIC_ITEMS sen symb_items raw_sym) where + toShATermAux att0 xv = case xv of + Nom_decl a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "Nom_decl" [a'] []) att1 + Mod_decl a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "Mod_decl" [a'] []) att1 + Axiom_items a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "Axiom_items" [a'] []) att1 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Nom_decl" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, Nom_decl a') } + ShAAppl "Mod_decl" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, Mod_decl a') } + ShAAppl "Axiom_items" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, Axiom_items a') } + u -> fromShATermError "H_BASIC_ITEMS" u + +instance ShATermConvertible MOD_ITEM where + toShATermAux att0 xv = case xv of + Mod_item a b c -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "Mod_item" [a', b', c'] []) att3 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Mod_item" [a, b, c] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, Mod_item a' b' c') }}} + u -> fromShATermError "MOD_ITEM" u + +instance ShATermConvertible NOM_ITEM where + toShATermAux att0 xv = case xv of + Nom_item a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "Nom_item" [a', b'] []) att2 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Nom_item" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, Nom_item a' b') }} + u -> fromShATermError "NOM_ITEM" u + +instance (ShATermConvertible sen, ShATermConvertible symb_items, + ShATermConvertible raw_sym) => + ShATermConvertible (H_BASIC_SPEC sen symb_items raw_sym) where + toShATermAux att0 xv = case xv of + Basic_spec a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "Basic_spec" [a'] []) att1 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Basic_spec" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, Basic_spec a') } + u -> fromShATermError "H_BASIC_SPEC" u + +instance (GetRange sen, GetRange symb_items, GetRange raw_sym) => + GetRange (H_BASIC_SPEC sen symb_items raw_sym) + where + getRange _ = nullRange + rangeSpan (Basic_spec bis) = joinRanges [rangeSpan bis] + +instance (GetRange sen, GetRange symb_items, GetRange raw_sym) => + GetRange (H_BASIC_ITEMS sen symb_items raw_sym) where + getRange _ = nullRange + rangeSpan (Nom_decl (Nom_item toks r)) = + joinRanges [rangeSpan toks, rangeSpan r] + rangeSpan (Mod_decl (Mod_item toks i r)) = + joinRanges [rangeSpan toks, rangeSpan i, rangeSpan r] + rangeSpan (Axiom_items fms) = + joinRanges [rangeSpan fms] + +instance (Pretty sen, Pretty raw_sym, Show symb_items) => + Pretty (H_BASIC_ITEMS sen symb_items raw_sym) where + pretty = printBasicItems + +instance (Pretty sen, Pretty raw_sym, Show symb_items) => + Pretty (H_BASIC_SPEC sen symb_items raw_sym) where + pretty = printBasicSpec + +printBasicSpec :: (Pretty sen, Pretty raw_sym, Show symb_items) => + H_BASIC_SPEC sen symb_items raw_sym -> Doc +printBasicSpec (Basic_spec xs) = vcat $ map pretty xs + +printBasicItems :: (Pretty sen, Pretty raw_sym, Show symb_items) => + H_BASIC_ITEMS sen symb_items raw_sym -> Doc +printBasicItems (Axiom_items xs) = vcat $ map (addBullet . pretty) xs +printBasicItems (Nom_decl x) = pretty x +printBasicItems (Mod_decl x) = pretty x + +instance Semigroup (H_BASIC_SPEC sen symb_items raw_sym) where + (Basic_spec l1) <> (Basic_spec l2) = Basic_spec $ l1 ++ l2 + +instance Monoid (H_BASIC_SPEC sen symb_items raw_sym) where + mempty = Basic_spec [] + +-- for H_symb_items + +instance (Pretty sym, Pretty symb_items) => + Pretty (H_SYMB_ITEMS sym symb_items) + where pretty (BaseSymbItems s) = pretty s + pretty (HSymbItems _ syms _) = pretty syms + +instance (GetRange sym, GetRange symb_items) => + GetRange (H_SYMB_ITEMS sym symb_items) where + getRange (BaseSymbItems s) = getRange s + getRange (HSymbItems _ syms _) = getRange syms + rangeSpan (BaseSymbItems s) = rangeSpan s + rangeSpan (HSymbItems _ syms _) = rangeSpan syms + +instance ShATermConvertible H_SYMB_KIND where + toShATermAux att0 xv = case xv of + NomKind -> return $ addATerm (ShAAppl "NomKind" [] []) att0 + ModKind -> return $ addATerm (ShAAppl "MKind" [] []) att0 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "NomKind" [] _ -> (att0, NomKind) + ShAAppl "ModKind" [] _ -> (att0, ModKind) + u -> fromShATermError "H_SYMB_KIND" u + +instance (ShATermConvertible sym, ShATermConvertible symb_items) => + ShATermConvertible (H_SYMB_ITEMS sym symb_items) where + toShATermAux att0 xv = case xv of + BaseSymbItems a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "BaseSymbItems" [a'] []) att1 + HSymbItems a b c -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "HSymbItems" [a', b', c'] []) att3 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "BaseSymbItems" [a] _ -> + case fromShATerm' a att0 of + (att1, a') -> + (att1, BaseSymbItems a') + ShAAppl "HSymbItems" [a, b, c] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, HSymbItems a' b' c') }}} + u -> fromShATermError "H_SYMB_ITEMS" u + +-- for symb_map_items + +instance (Pretty symb_map_items) => + Pretty (H_SYMB_MAP_ITEMS symb_map_items) where + pretty (BaseSymbMapItems sitems) = pretty sitems + pretty (HSymbMapItems hsm _) = pretty hsm + +instance Pretty H_SYMB_OR_MAP where + pretty (HSymbItem i) = pretty i + pretty (HMapItem i1 i2 _) = fsep [pretty i1, mapsto <+> pretty i2] + +instance (GetRange symb_map_items) => + GetRange (H_SYMB_MAP_ITEMS symb_map_items) where + getRange (BaseSymbMapItems sitems) = getRange sitems + getRange (HSymbMapItems hsm _) = getRange hsm + rangeSpan (BaseSymbMapItems sitems) = rangeSpan sitems + rangeSpan (HSymbMapItems hsm _) = rangeSpan hsm + +instance GetRange H_SYMB_OR_MAP where + getRange (HSymbItem _) = nullRange + getRange (HMapItem _ _ p) = p + rangeSpan x = case x of + HSymbItem a -> joinRanges [rangeSpan a] + HMapItem a b c -> joinRanges [rangeSpan a, rangeSpan b, + rangeSpan c] + +instance ShATermConvertible H_SYMB_OR_MAP where + toShATermAux att0 xv = case xv of + HSymbItem a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "HSymbItem" [a'] []) att1 + HMapItem a b c -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + (att3, c') <- toShATerm' att2 c + return $ addATerm (ShAAppl "HMapItem" [a', b', c'] []) att3 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "HSymbItem" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, HSymbItem a') } + ShAAppl "HMapItem" [a, b, c] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + case fromShATerm' c att2 of + { (att3, c') -> + (att3, HMapItem a' b' c') }}} + u -> fromShATermError "SYMB_OR_MAP" u + +instance (ShATermConvertible symb_map_items) => + ShATermConvertible (H_SYMB_MAP_ITEMS symb_map_items) where + toShATermAux att0 xv = case xv of + BaseSymbMapItems sitems -> do + (att1, sitems') <- toShATerm' att0 sitems + return $ addATerm (ShAAppl "BaseSymbMapItems" [sitems'] []) att1 + HSymbMapItems a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "HSymbMapItems" [a', b'] []) att2 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "BaseSymbMapItems" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, BaseSymbMapItems a') } + ShAAppl "HSymbMapItems" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, HSymbMapItems a' b') }} + u -> fromShATermError "H_SYMB_MAP_ITEMS" u + +-- for HSymbol + +instance Pretty sym => Pretty (HSymbol sym) where + pretty (BaseSymb s) = pretty s + pretty (HSymb i _) = pretty i + +instance GetRange sym => GetRange (HSymbol sym) where + getRange (BaseSymb s) = getRange s + getRange (HSymb i _ ) = getRange i + rangeSpan (BaseSymb s) = rangeSpan s + rangeSpan (HSymb i _ ) = rangeSpan i + +instance ShATermConvertible HKind where + toShATermAux att0 xv = case xv of + Nom -> return $ addATerm (ShAAppl "Nom" [] []) att0 + Mod a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "Mod" [a'] []) att1 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Nom" [] _ -> (att0, Nom) + ShAAppl "Mod" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, Mod a') } + u -> fromShATermError "HKind" u + +instance (ShATermConvertible sym) => ShATermConvertible (HSymbol sym) where + toShATermAux att0 xv = case xv of + BaseSymb a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "BaseSymb" [a'] []) att1 + HSymb a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "HSymb" [a', b'] []) att2 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "BaseSymb" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, BaseSymb a') } + ShAAppl "HSymb" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, HSymb a' b') }} + u -> fromShATermError "HSymbol" u + +-- for HRawSymbol + + +instance (Pretty raw_sym, Pretty sym) => + Pretty (HRawSymbol sym raw_sym) where + pretty (BaseRawSymbol rs) = pretty rs + pretty (ASymbol x) = pretty x + pretty (AKindedSymb _ x) = pretty x + +instance (GetRange sym, GetRange raw_sym) => + GetRange (HRawSymbol sym raw_sym) where + getRange (BaseRawSymbol rs) = getRange rs + getRange (ASymbol x) = getRange x + getRange (AKindedSymb _ x) = getRange x + rangeSpan (BaseRawSymbol rs) = rangeSpan rs + rangeSpan (ASymbol x) = rangeSpan x + rangeSpan (AKindedSymb _ x) = rangeSpan x + +instance ShATermConvertible GKind where + toShATermAux att0 xv = case xv of + Implicit -> return $ addATerm (ShAAppl "Implicit" [] []) att0 + HKindAsG a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "HKindAsG" [a'] []) att1 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "Implicit" [] _ -> (att0, Implicit) + ShAAppl "HKindAsG" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, HKindAsG a') } + u -> fromShATermError "GKind" u + +instance (ShATermConvertible raw_sym, ShATermConvertible sym) => + ShATermConvertible (HRawSymbol sym raw_sym) where + toShATermAux att0 xv = case xv of + BaseRawSymbol a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "BaseRawSymbol" [a'] []) att1 + ASymbol a -> do + (att1, a') <- toShATerm' att0 a + return $ addATerm (ShAAppl "ASymbol" [a'] []) att1 + AKindedSymb a b -> do + (att1, a') <- toShATerm' att0 a + (att2, b') <- toShATerm' att1 b + return $ addATerm (ShAAppl "AKindedSymb" [a', b'] []) att2 + fromShATermAux ix att0 = case getShATerm ix att0 of + ShAAppl "BaseRawSymbol" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, BaseRawSymbol a') } + ShAAppl "ASymbol" [a] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + (att1, ASymbol a') } + ShAAppl "AKindedSymb" [a, b] _ -> + case fromShATerm' a att0 of + { (att1, a') -> + case fromShATerm' b att1 of + { (att2, b') -> + (att2, AKindedSymb a' b') }} + u -> fromShATermError "HRawSymbol" u diff --git a/GenHyb/GenMethods.hs b/GenHyb/GenMethods.hs new file mode 100644 index 0000000000..2ebe40e98c --- /dev/null +++ b/GenHyb/GenMethods.hs @@ -0,0 +1,2729 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + TypeSynonymInstances, FlexibleInstances, FlexibleContexts, + ExistentialQuantification, DeriveDataTypeable #-} +{- | +Module : ./GenHyb/GenMethods +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +Generic methods for the Loigc class and its subclasses. +-} +module GenHyb.GenMethods where + +import qualified GenHyb.GenTypes as GTypes +import Common.SetColimit +import Logic.Logic +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Graph.Inductive.Graph as Graph +import Common.Lib.Graph +import Common.Id as Id +import Data.List(nub) +import Common.AS_Annotation as AS_Anno +import qualified CASL.AS_Basic_CASL as CBasic +import qualified CASL.Formula as CFormula +import Common.Result +import Common.Utils (composeMap) +import Common.Parsec +import Common.AnnoState +import Common.Lexer +import Common.Token +import Common.Keywords +import Common.ExtSign +import Common.GlobalAnnotations +import Control.Monad (foldM) +import qualified Common.Lib.State as CState +import Text.ParserCombinators.Parsec +import Data.Maybe (fromJust) +import Logic.SemConstr + +--TODO: +-- sort the methods coming from Static +-- in Static +-- final_union, TODO: where is this needed at all? +-- morphism_union, TODO: can wait +-- TODO: we need is_nominal_sen, DONE +-- convertTheory, DONE +-- convertRawSyms, TODO: check that it does what it should +-- extSymKind TODO: need to distinguish base and top nominals and modalities? + +-- for class Category + +idMor :: (Category sig mor) => + GTypes.HSign sig -> GTypes.HMorphism sig mor +idMor hsig = GTypes.HMorphism hsig hsig + (ide $ GTypes.baseSig hsig) Map.empty Map.empty + +isHIncl :: (Category sig mor) => + GTypes.HMorphism sig mor -> Bool +isHIncl hmor = isInclusion (GTypes.baseMor hmor) && + Map.null (GTypes.nomMap hmor) && + Map.null (GTypes.modMap hmor) + +compHMor :: (Category sig mor) => + GTypes.HMorphism sig mor -> GTypes.HMorphism sig mor -> + Result (GTypes.HMorphism sig mor) +compHMor mor1 mor2 = + if GTypes.target mor1 == GTypes.source mor2 then do + bmor <- composeMorphisms (GTypes.baseMor mor1) (GTypes.baseMor mor2) + return $ GTypes.HMorphism (GTypes.source mor1) (GTypes.target mor2) + bmor + (composeMap + (Map.fromSet id $ GTypes.noms $ + GTypes.source mor1) + (GTypes.nomMap mor1) + (GTypes.nomMap mor2)) + (composeMap + (GTypes.mods $ GTypes.source mor1) + (GTypes.modMap mor1) + (GTypes.modMap mor2)) + else fail $ "cannot compose HMorphisms: signatures don't match" + +{- will write the following instance: +instance + Category (GTypes.HSign sig) (GTypes.HMorphism sig mor) + where + dom = GTypes.source + cod = GTypes.target + ide = GMethods.idMor + isInclusion = GMethods.isHIncl + composeMorphisms = GMethods.compHMor +-} + +-- for class Syntax + +parseSymbItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> Maybe (PrefixMap -> AParser st (GTypes.H_SYMB_ITEMS sym symb_items)) +parseSymbItems baseLid = Just $ \pm -> do + _ <- nomP False -- TODO: add a flag for the two notations!!! + _s <- optQual + aNom <- simpleId + return $ GTypes.HSymbItems GTypes.NomKind + [GTypes.HSymb (simpleIdToId aNom) GTypes.Nom] nullRange + <|> do + _ <- modP False -- TODO: add a flag for the two notations!!! + _s <- optQual + aMod <- simpleId + return $ GTypes.HSymbItems GTypes.ModKind + [GTypes.HSymb (simpleIdToId aMod) $ GTypes.Mod 2] nullRange + -- Note: only binary modalitiesies for now + <|> do + let bParser = case parse_symb_items baseLid of + Just f -> f + Nothing -> error $ + "parser for symbol items not available" + ++ " for base logic " ++ show baseLid + x <- bParser pm + return $ GTypes.BaseSymbItems x + + +parseSymbMapItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> Maybe (PrefixMap -> AParser st (GTypes.H_SYMB_MAP_ITEMS symb_map_items)) +parseSymbMapItems baseLid = Just $ \pm -> do + _ <- nomP False <|> modP False + -- TODO: add a flag for the two notations!!! + _s <- optQual + anId <- simpleId + do f <- pToken $ toKey mapsTo + anId' <- simpleId + return (GTypes.HSymbMapItems + [GTypes.HMapItem (simpleIdToId anId) + (simpleIdToId anId') $ tokPos f] + nullRange) + <|> return (GTypes.HSymbMapItems + [GTypes.HSymbItem $ simpleIdToId anId] + nullRange) + <|> do + let bParser = case parse_symb_map_items baseLid of + Just f -> f + Nothing -> + error $ "parser for symbol items not available" + ++ " for base logic " ++ show baseLid + x <- bParser pm + return $ GTypes.BaseSymbMapItems x + + +hSymbItemsName :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.H_SYMB_ITEMS sym symb_items -> [String] +hSymbItemsName lid (GTypes.BaseSymbItems sitems) = + symb_items_name lid sitems +hSymbItemsName lid (GTypes.HSymbItems _ hs _) = + map (show . (hSymName lid)) hs + +parseHBasicSpec :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -- True for eng. notation, False for math. notation + -> Bool -- admits quantification on nominals + -> Bool -- admits quantification on symbols of base logic + -> lid -- lid for base logic + -> PrefixMap + -> AParser st (GTypes.H_BASIC_SPEC sen symb_items raw_sym) +parseHBasicSpec eng hasQNominals kVars baseLid pm = + fmap GTypes.Basic_spec + (annosParser (parseBasicItems eng hasQNominals kVars baseLid pm)) + <|> (oBraceT >> cBraceT >> return (GTypes.Basic_spec [])) + +parseBasicItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (GTypes.H_BASIC_ITEMS sen symb_items raw_sym) + -- TODO: take into account ks +parseBasicItems eng hasQNominals kVars baseLid pm = + parseAxItems eng hasQNominals kVars baseLid pm + -- if this is not first, + -- the parser for basic items consumes more than it should + <|> + do (as, ps) <- keyThenList (nomP eng) simpleId + return $ GTypes.Nom_decl $ GTypes.Nom_item as ps + <|> + do (as, ps) <- keyThenList (modP eng) simpleId + _c <- colonT + ni <- getNumber + let i = read ni :: Int + return $ GTypes.Mod_decl $ GTypes.Mod_item as i ps + +modP :: Bool -> AParser st Token +modP eng = + if eng + then asKey "event" <|> asKey "events" + else asKey modalityS <|> asKey modalitiesS + +nomP :: Bool -> AParser st Token +nomP eng = + if eng + then asKey "state" <|> asKey "states" + else asKey nominalS <|> asKey nominalsS + +keyThenList :: AParser st Token -> AParser st a -> + AParser st ([a], Range) +keyThenList k p = do + c <- k + (as, cs) <- separatedBy p anComma + let ps = catRange $ c : cs + return (as, ps) + +parseAxItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (GTypes.H_BASIC_ITEMS sen symb_items raw_sym) +parseAxItems eng hasQNominals kVars baseLid pm = do + d <- dotT + (fs, ds) <- (aFormula eng hasQNominals kVars baseLid pm) + `separatedBy` dotT + (_, an) <- optSemi + let _ = catRange (d : ds) + ns = init fs ++ [appendAnno (last fs) an] + return $ GTypes.Axiom_items ns + +-- | parser for annoted formulae +aFormula :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (Annoted (GTypes.HFORMULA sen symb_items raw_sym)) +aFormula eng hasQNominals kVars baseLid pm = + allAnnoParser (topformula eng hasQNominals kVars baseLid pm) + +-- | toplevel formula parser +topformula :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +topformula eng hasQNominals kVars baseLid pm = + (andOrFormula eng hasQNominals kVars baseLid pm) + >>= (optImplForm eng hasQNominals kVars baseLid pm) + +andOrFormula :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +andOrFormula eng hasQNominals kVars baseLid pm = + (hFormula eng hasQNominals kVars baseLid pm) + >>= (optAndOr eng hasQNominals kVars baseLid pm) + +optImplForm :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + GTypes.HFORMULA sen symb_items raw_sym -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +optImplForm eng hasQNominals kVars baseLid pm f = do + _c <- CFormula.implKey + (fs, _ps) <- (andOrFormula eng hasQNominals kVars baseLid pm) + `separatedBy` CFormula.implKey + return $ makeImpl (f : fs) + <|> do + c <- asKey equivS + g <- andOrFormula eng hasQNominals kVars baseLid pm + return $ GTypes.Equivalence f g $ tokPos c + <|> return f + +makeImpl :: [GTypes.HFORMULA sen symb_items raw_sym] -> + GTypes.HFORMULA sen symb_items raw_sym +makeImpl l = + case l of + [f1, f2] -> GTypes.Implication f1 f2 nullRange + f1 : fs -> GTypes.Implication f1 (makeImpl fs) nullRange + _ -> error "Illegal argument for makeImpl in parsing of hybrid formulas" + + +optAndOr :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + GTypes.HFORMULA sen symb_items raw_sym -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +optAndOr eng hasQNominals kVars baseLid pm f = do + c <- CFormula.andKey + (fs, ps) <- (hFormula eng hasQNominals kVars baseLid pm) + `separatedBy` CFormula.andKey + return $ GTypes.Conjunction (f : fs) $ catRange $ c : ps + <|> do + c <- CFormula.orKey + (fs, ps) <- (hFormula eng hasQNominals kVars baseLid pm) + `separatedBy` CFormula.orKey + return $ GTypes.Disjunction (f : fs) $ catRange $ c : ps + <|> return f + +hFormula :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +hFormula eng hasQNominals kVars baseLid pm = + if eng + then + do + c <- asKey "At state" + n <- simpleId + s <- optQual + _ <- colonT + f <- topformula eng hasQNominals kVars baseLid pm + -- here should be formula without @? + return $ GTypes.AtState s n f $ tokPos c + <|> + do + c <- asKey notS <|> asKey negS "\"not\"" + f <- hFormula eng hasQNominals kVars baseLid pm --topformula + return $ GTypes.Negation f $ tokPos c + <|> + do + c1 <- asKey "Through" --lessS + md <- propId ["sometimes", "always"] + s <- optQual + _ <- commaT + sen <- do + c2 <- asKey "sometimes" + f <- topformula eng hasQNominals kVars baseLid pm + return $ GTypes.DiamondFormula s md f $ toRange c1 [] c2 + <|> do + c2 <- asKey "always" + f <- topformula eng hasQNominals kVars baseLid pm + return $ GTypes.BoxFormula s md f $ toRange c1 [] c2 + return sen + <|> + parenFormula eng hasQNominals kVars baseLid pm + <|> + do + (q, p) <- quant + parseQFormula baseLid eng hasQNominals kVars(q, p) pm + <|> + do + let fparser = case parse_prim_formula baseLid of + Nothing -> + error $ "no prim formula parser for logic " ++ show baseLid + Just f -> f + f <- fparser pm + return $ GTypes.Base_formula f nullRange + -- this should also catch nominals as terms. + -- We have to make sure during static analysis that this is reverted! + <|> do -- qualified symbols are nominals + nom <- simpleId + _ <- asKey "::" + qual <- simpleId + return $ GTypes.Nominal (show qual) False nom nullRange + + else + do + c <- asKey asP + n <- simpleId + s <- optQual + _ <- colonT + f <- topformula eng hasQNominals kVars baseLid pm + return $ GTypes.AtState s n f $ tokPos c + <|> + do + c <- asKey notS <|> asKey negS "\"not\"" + f <- hFormula eng hasQNominals kVars baseLid pm + return $ GTypes.Negation f $ tokPos c + <|> + do + c1 <- asKey lessS + md <- propId [greaterS] + s <- optQual + c2 <- asKey greaterS + f <- topformula eng hasQNominals kVars baseLid pm + return $ GTypes.DiamondFormula s md f $ toRange c1 [] c2 + <|> + do + c1 <- oBracketT + md <- propId ["]"] + s <- optQual + c2 <- cBracketT + f <- topformula eng hasQNominals kVars baseLid pm + return $ GTypes.BoxFormula s md f $ toRange c1 [] c2 + <|> + parenFormula eng hasQNominals kVars baseLid pm + <|> + do + (q, p) <- quant + parseQFormula baseLid eng hasQNominals kVars (q, p) pm + <|> + do + let fparser = case parse_prim_formula baseLid of + Nothing -> error $ + "no prim formula parser for logic " + ++ show baseLid + Just f -> f + f <- fparser pm + return $ GTypes.Base_formula f nullRange + -- this should also catch nominals as terms. + -- We have to make sure during static analysis that this is reverted! + <|> do -- qualified symbols are nominals + nom <- simpleId + _ <- asKey "::" + qual <- simpleId + return $ GTypes.Nominal (show qual) False nom nullRange + -- Note: always False here, no qualifications for variables + +parenFormula :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> Bool -> Bool -> lid -> PrefixMap -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +parenFormula eng hasQNominals kVars baseLid pm = do + oParenT << addAnnos + f <- topformula eng hasQNominals kVars baseLid pm << addAnnos + cParenT >> return f + +quant :: AParser st (GTypes.HQUANT, Token) +quant = choice (map (\ (q, s) -> do + t <- asKey s + str <- optQual + return (q str, t)) + [ (GTypes.HExistential, hExistsS) + , (GTypes.HUniversal, hForallS) ]) + "quantifier" + +optQual :: AParser st String +optQual = do + _ <- asKey "::" + qual <- simpleId + return $ show qual + <|> do + return "" + +parseQFormula :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> Bool -> Bool -> Bool -> (GTypes.HQUANT, Token) -> PrefixMap -> + AParser st (GTypes.HFORMULA sen symb_items raw_sym) +parseQFormula baseLid eng hasQNominals kVars (q, p) pm = + do -- first try quantification on nominals, or the parser will complain + (vs, _ps) <- keyThenList (nomP eng) simpleId + _d <- dotT + f <- topformula eng hasQNominals kVars baseLid pm + if hasQNominals then + return $ GTypes.QuantNominals q vs f nullRange + else error $ "the logic does not admit quantification on nominals" + <|> + do + let symParser = case parse_symb_items baseLid of + Nothing -> + error $ "no symbol parser for logic " + ++ show baseLid + Just f -> f + (sitems, ps) <- (symParser pm) `separatedBy` commaT + d <- dotT + f <- topformula eng hasQNominals kVars baseLid pm + if kVars then + return $ GTypes.QuantVarsParse q sitems f $ toRange p ps d + else error $ "the logic does not admit quantification on base symbols" + +-- | Any word to token +propId :: [String] -> GenParser Char st Token +propId k = pToken $ reserved (k ++ hybrid_keywords) scanAnyWords + +-- for class Sentences + +mapSentence :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> + GTypes.HMorphism sig mor -> + GTypes.HFORMULA sen symb_items raw_sym -> + Result (GTypes.HFORMULA sen symb_items raw_sym) +mapSentence baseLid hmor hsen = + case hsen of + GTypes.Base_formula sen _ -> do + sen' <- map_sen baseLid (GTypes.baseMor hmor) sen + return $ GTypes.Base_formula sen' nullRange + GTypes.Negation hsen' _ -> do + hsen'' <- mapSentence baseLid hmor hsen' + return $ GTypes.Negation hsen'' nullRange + GTypes.Conjunction hsens _ -> do + hsens' <- mapM (mapSentence baseLid hmor) hsens + return $ GTypes.Conjunction hsens' nullRange + GTypes.Disjunction hsens _ -> do + hsens' <- mapM (mapSentence baseLid hmor) hsens + return $ GTypes.Disjunction hsens' nullRange + GTypes.Implication hsen1 hsen2 _ -> do + tsen1 <- mapSentence baseLid hmor hsen1 + tsen2 <- mapSentence baseLid hmor hsen2 + return $ GTypes.Implication tsen1 tsen2 nullRange + GTypes.Equivalence hsen1 hsen2 _ -> do + tsen1 <- mapSentence baseLid hmor hsen1 + tsen2 <- mapSentence baseLid hmor hsen2 + return $ GTypes.Equivalence tsen1 tsen2 nullRange + GTypes.Nominal s b n _ -> + if b then return hsen + else let n0 = simpleIdToId n + n' = Map.findWithDefault n0 n0 $ GTypes.nomMap hmor + in return $ GTypes.Nominal s b (idToSimpleId n') nullRange + GTypes.AtState s n hsen' _ -> do + tsen' <- mapSentence baseLid hmor hsen' + let n0 = simpleIdToId n + n' = idToSimpleId $ Map.findWithDefault n0 n0 $ GTypes.nomMap hmor + return $ GTypes.AtState s n' tsen' nullRange + GTypes.BoxFormula s m hsen' _ -> do + tsen' <- mapSentence baseLid hmor hsen' + let m0 = simpleIdToId m + m' = idToSimpleId $ Map.findWithDefault m0 m0 $ GTypes.modMap hmor + return $ GTypes.BoxFormula s m' tsen' nullRange + GTypes.DiamondFormula s m hsen' _ -> do + tsen' <- mapSentence baseLid hmor hsen' + let m0 = simpleIdToId m + m' = idToSimpleId $ Map.findWithDefault m0 m0 $ GTypes.modMap hmor + return $ GTypes.DiamondFormula s m' tsen' nullRange + GTypes.QuantNominals hq noms hsen' _ -> do + tsen' <- mapSentence baseLid hmor hsen' + return $ GTypes.QuantNominals hq noms tsen' nullRange + GTypes.QuantVarsParse _ _ _ _ -> + error "cannot translate a sentence before it was analyzed" + GTypes.QuantVars hq rsyms hsen' _ -> do + {- + hincl (generated by rsyms) + ssig .......> ssig' + | | + | hmor | hmor' + | | + V V + tsig ........> csig + + Then Sen(hmor) (forall rsyms.e) = + forall (rsyms') hmor'(e) + where rsyms' are the symbols of csig \ tsig + + -} + let mSyms = convertRawSyms baseLid rsyms + case mSyms of + Nothing -> + error $ "could not convert symbols in quantification" + ++" when translating sentence" + Just syms -> do + let ssig = GTypes.source hmor + tsig = GTypes.target hmor + ssig' <- foldM (addSymbToHSign baseLid) ssig $ + map GTypes.BaseSymb syms + hincl <- --trace ("ssig:" ++ show ssig ++ "ssig':" ++ show ssig') $ + subsigInclusion baseLid ssig ssig' + let spanGr = Graph.mkGraph [(0, ssig), (1, ssig'), (2, tsig)] + [(0, 1, (0, hincl)), (0, 2, (1, hmor))] + (csig, cmors) <- signatureColimit baseLid spanGr + let hmor' = Map.findWithDefault (error "cmor missing") 1 cmors + dsig <- signatureDifference baseLid csig tsig + let rsyms' = map (symbol_to_raw baseLid) $ + -- this is an ugly hack, + -- cause signature colimits don't preserve inclusions + mostSymsOf baseLid $ GTypes.baseSig dsig + -- only base symbols, so we don't lose anything here + tsen' <- mapSentence baseLid hmor' hsen' + let transSen = GTypes.QuantVars hq rsyms' tsen' nullRange + return transSen + +mostSymsOfDiff :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> [GTypes.HSymbol sym] +mostSymsOfDiff baseLid hsig = let + bsyms = map GTypes.BaseSymb $ + mostSymsOf baseLid $ GTypes.baseSig hsig + nsyms = map (\n -> GTypes.HSymb n GTypes.Nom) $ + Set.toList $ GTypes.noms hsig + msyms = map (\(m,i) -> GTypes.HSymb m (GTypes.Mod i)) $ + Map.toList $ GTypes.mods hsig + in bsyms ++ nsyms ++ msyms + +signatureDifference :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> GTypes.HSign sig -> + Result (GTypes.HSign sig) +signatureDifference baseLid hsig1 hsig2 = do + bDiff <- signatureDiff baseLid (GTypes.baseSig hsig1) $ + GTypes.baseSig hsig2 + return $ + GTypes.HSign bDiff + (Set.difference (GTypes.noms hsig1) $ GTypes.noms hsig2) + (Map.difference (GTypes.mods hsig1) $ GTypes.mods hsig2) + +subsigInclusion :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> GTypes.HSign sig -> + Result (GTypes.HMorphism sig mor) +subsigInclusion baseLid ssig ssig' = do + bmor <- subsig_inclusion baseLid (GTypes.baseSig ssig) $ + GTypes.baseSig ssig' + return $ GTypes.HMorphism ssig ssig' bmor Map.empty Map.empty + +addSymbToHSign :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> GTypes.HSymbol sym -> + Result (GTypes.HSign sig) +addSymbToHSign baseLid hsig s = + case s of + GTypes.BaseSymb bs -> do + bsig <- add_symb_to_sign baseLid (GTypes.baseSig hsig) bs + return $ hsig {GTypes.baseSig = bsig} + GTypes.HSymb i k -> + case k of + GTypes.Nom -> addNomToSig hsig i + GTypes.Mod a -> addModToSig hsig i a + +signatureColimit :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> Gr (GTypes.HSign sig) (Int, GTypes.HMorphism sig mor) -> + Result (GTypes.HSign sig, Map.Map Int (GTypes.HMorphism sig mor)) +signatureColimit baseLid hgr = do + let bgr = emap (\(i, m) -> (i, GTypes.baseMor m)) $ nmap GTypes.baseSig hgr + (cbsig, cbmors) <- signature_colimit baseLid bgr + let ngr = emap (\(i, m) -> (i, GTypes.nomMap m)) $ nmap GTypes.noms hgr + (nomSet0, nomFuns0) = computeColimitSet ngr + (nomSet, nomFuns) = addIntToSymbols (nomSet0, nomFuns0) + mgr = emap (\(i, m) -> (i, GTypes.modMap m)) $ + nmap (\ s -> Set.fromList $ Map.keys $ GTypes.mods s) hgr + (modSet0, modFuns0) = computeColimitSet mgr + (modSet, modFuns) = addIntToSymbols (modSet0, modFuns0) + csig = GTypes.HSign cbsig nomSet $ + Map.fromList $ map (\m -> (m, 2)) $ Set.toList modSet + cmors = Map.fromList $ map (\(n, hsig) -> + (n, GTypes.HMorphism + hsig csig + (Map.findWithDefault + (error "missing morphism") + n cbmors) + (Map.findWithDefault + Map.empty n nomFuns) + (Map.findWithDefault + Map.empty n modFuns) + ) + ) + $ labNodes hgr + return (csig, cmors) + +hNegation :: GTypes.HFORMULA sen symb_items raw_sym -> + Maybe (GTypes.HFORMULA sen symb_items raw_sym) +hNegation hsen = Just $ GTypes.Negation hsen nullRange + +hSymOf :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> [Set.Set (GTypes.HSymbol sym)] +hSymOf baseLid hsig = + let bSyms = sym_of baseLid $ GTypes.baseSig hsig + nSyms = GTypes.noms hsig + mSyms = GTypes.mods hsig + in [Set.map (\x -> GTypes.HSymb x GTypes.Nom) nSyms] ++ + [Set.fromList $ map (\(m,i) -> GTypes.HSymb m (GTypes.Mod i)) $ + Map.toList mSyms] ++ + map (\ss -> Set.map (\s -> GTypes.BaseSymb s) ss) bSyms + +hSymMapOf :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HMorphism sig mor -> EndoMap (GTypes.HSymbol sym) +hSymMapOf baseLid hmor = + let mkBSymMap f = Map.mapKeys (\x -> GTypes.BaseSymb x) $ + Map.map (\x -> GTypes.BaseSymb x) f + bMap = mkBSymMap $ symmap_of baseLid $ GTypes.baseMor hmor + nMap = Map.mapKeys (\x -> GTypes.HSymb x GTypes.Nom) $ + Map.map (\x -> GTypes.HSymb x GTypes.Nom) $ GTypes.nomMap hmor + mMap = Map.mapKeys (\x -> + let i = Map.findWithDefault + (error $ "unknown modality: " ++ show x) + x $ GTypes.mods $ GTypes.source hmor + in GTypes.HSymb x (GTypes.Mod i)) $ + Map.map (\x -> + let i = Map.findWithDefault + (error $ "unknown modality: " ++ show x) + x $ GTypes.mods $ GTypes.target hmor + in GTypes.HSymb x (GTypes.Mod i)) $ GTypes.modMap hmor + in Map.union bMap $ Map.union nMap mMap + +hSymName :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSymbol sym -> Id +hSymName baseLid (GTypes.BaseSymb x) = sym_name baseLid x +hSymName _ (GTypes.HSymb x _) = x + +symKindH :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSymbol sym -> String +symKindH baseLid s = + case s of + GTypes.BaseSymb x -> symKind baseLid x + GTypes.HSymb _ (GTypes.Nom) -> "nominal" + GTypes.HSymb _ (GTypes.Mod _) -> "modality" + +extSymKindH :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSymbol sym -> String +extSymKindH baseLid s = + case s of + GTypes.BaseSymb x -> extSymKind baseLid x + GTypes.HSymb _ (GTypes.Nom) -> "nominal" + GTypes.HSymb _ (GTypes.Mod _) -> "modality" + +symsOfHSen :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> + GTypes.HSign sig -> + GTypes.HFORMULA sen symb_items raw_sym -> + [GTypes.HSymbol sym] +symsOfHSen baseLid hsig hsen = + case hsen of + GTypes.Base_formula sen _ -> + let bSyms = symsOfSen baseLid (GTypes.baseSig hsig) sen + in map (\s -> GTypes.BaseSymb s) bSyms + GTypes.Negation hsen' _ -> + symsOfHSen baseLid hsig hsen' + GTypes.Conjunction hsens _ -> + nub $ concatMap (symsOfHSen baseLid hsig) hsens + GTypes.Disjunction hsens _ -> + nub $ concatMap (symsOfHSen baseLid hsig) hsens + GTypes.Implication hsen1 hsen2 _ -> + nub $ (symsOfHSen baseLid hsig hsen1) ++ (symsOfHSen baseLid hsig hsen2) + GTypes.Equivalence hsen1 hsen2 _ -> + nub $ (symsOfHSen baseLid hsig hsen1) ++ (symsOfHSen baseLid hsig hsen2) + GTypes.Nominal _ b n _ -> + if b then [] + else [GTypes.HSymb (simpleIdToId n) GTypes.Nom] + -- TODO: ok to have empty list of syms for variables? + GTypes.AtState _ n hsen' _ -> + let syms = symsOfHSen baseLid hsig hsen' + in (GTypes.HSymb (simpleIdToId n) GTypes.Nom):syms + GTypes.BoxFormula _ m hsen' _ -> + let syms = symsOfHSen baseLid hsig hsen' + k = GTypes.Mod (2::Int) + in (GTypes.HSymb (simpleIdToId m) k):syms + GTypes.DiamondFormula _ m hsen' _ -> + let syms = symsOfHSen baseLid hsig hsen' + k = GTypes.Mod (2::Int) + in (GTypes.HSymb (simpleIdToId m) k):syms + GTypes.QuantNominals _hq _noms hsen' _ -> + symsOfHSen baseLid hsig hsen' -- TODO:vars? + GTypes.QuantVars _hq _vars hsen' _ -> + symsOfHSen baseLid hsig hsen' -- TODO:vars? + GTypes.QuantVarsParse _hq _vars _hsen' _ -> + error $ "unparsed sentence" + +rawToSymbol :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> GTypes.HRawSymbol sym raw_sym -> + Maybe (GTypes.HSymbol sym) +rawToSymbol baseLid rsym = + case rsym of + GTypes.BaseRawSymbol brsym -> + let msym = raw_to_symbol baseLid brsym + in case msym of + Nothing -> Nothing + Just sym -> Just $ GTypes.BaseSymb sym + GTypes.ASymbol x -> Just x + GTypes.AKindedSymb gk i -> + case gk of + GTypes.Implicit -> Nothing + GTypes.HKindAsG hk -> Just $ GTypes.HSymb i hk + +idToRaw :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> Id -> GTypes.HRawSymbol sym raw_sym +idToRaw baseLid anId = + let baseRawSym = id_to_raw baseLid anId + in GTypes.BaseRawSymbol baseRawSym + +emptyHSign :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> GTypes.HSign sig +emptyHSign baseLid = + let emptyBSign = empty_signature baseLid + in GTypes.HSign emptyBSign Set.empty Map.empty + +sigIntersection :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> GTypes.HSign sig -> GTypes.HSign sig -> + Result (GTypes.HSign sig) +sigIntersection baseLid hsig1 hsig2 = do + bsig <- intersection baseLid (GTypes.baseSig hsig1) $ + GTypes.baseSig hsig2 + let uNoms = Set.intersection (GTypes.noms hsig1) $ + GTypes.noms hsig2 + uMods = Map.intersection (GTypes.mods hsig1) $ + GTypes.mods hsig2 +-- TODO: fail if a modality appears in both sigs with different arities? + return $ GTypes.HSign bsig uNoms uMods + +sigUnion :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> GTypes.HSign sig -> GTypes.HSign sig -> + Result (GTypes.HSign sig) +sigUnion baseLid hsig1 hsig2 = do + bsig <- signature_union baseLid (GTypes.baseSig hsig1) $ + GTypes.baseSig hsig2 + let uNoms = Set.union (GTypes.noms hsig1) $ GTypes.noms hsig2 + uMods = Map.union (GTypes.mods hsig1) $ GTypes.mods hsig2 +-- TODO: fail if a modality appears in both sigs with different arities? + return $ GTypes.HSign bsig uNoms uMods + +isSubsig :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> GTypes.HSign sig -> GTypes.HSign sig -> Bool +isSubsig baseLid sig1 sig2 = + (is_subsig baseLid (GTypes.baseSig sig1) $ GTypes.baseSig sig1) && + (Set.isSubsetOf (GTypes.noms sig1) $ GTypes.noms sig2) && + (Map.isSubmapOf (GTypes.mods sig1) $ GTypes.mods sig2) + +hGeneratedSign :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> Set.Set (GTypes.HSymbol sym) -> GTypes.HSign sig -> + Result (GTypes.HMorphism sig mor) +hGeneratedSign baseLid kSyms hSig = do + let hSyms = Set.unions $ hSymOf baseLid hSig + if not $ Set.isSubsetOf kSyms hSyms then do + let diff = kSyms Set.\\ hSyms + error $ "Revealing: The following symbols " + ++ show diff ++ " are not in the signature" + else do + let (bSyms, nSyms, mSyms) = + foldl (\(bs, ns, ms) s -> + case s of + GTypes.BaseSymb x -> + (Set.insert x bs, ns, ms) + GTypes.HSymb i GTypes.Nom -> + (bs, Set.insert i ns, ms) + GTypes.HSymb i (GTypes.Mod a) -> + (bs, ns, Set.insert (i, a) ms) + ) (Set.empty, Set.empty, Set.empty) kSyms + bIncl <- generated_sign baseLid bSyms $ GTypes.baseSig hSig + let bSig = dom bIncl + bhSig = GTypes.HSign bSig nSyms $ Map.fromList $ Set.toList mSyms + iMor = GTypes.HMorphism bhSig hSig bIncl Map.empty Map.empty + return iMor + +hCoGeneratedSign :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> Set.Set (GTypes.HSymbol sym) -> GTypes.HSign sig -> + Result (GTypes.HMorphism sig mor) +hCoGeneratedSign baseLid kSyms hSig = do + let hSyms = Set.unions $ hSymOf baseLid hSig + if not $ Set.isSubsetOf kSyms hSyms then do + let diff = kSyms Set.\\ hSyms + error $ "Hiding: The following symbols " + ++ show diff ++ " are not in the signature" + else do + let (bSyms, nSyms, mSyms) = + foldl (\(bs, ns, ms) s -> + case s of + GTypes.BaseSymb x -> + (Set.insert x bs, ns, ms) + GTypes.HSymb i GTypes.Nom -> + (bs, Set.insert i ns, ms) + GTypes.HSymb i (GTypes.Mod a) -> + (bs, ns, Set.insert (i, a) ms) + ) (Set.empty, Set.empty, Set.empty) kSyms + bIncl <- generated_sign baseLid bSyms $ GTypes.baseSig hSig + let bSig = dom bIncl + bhSig = GTypes.HSign bSig ((GTypes.noms hSig) Set.\\ nSyms) $ + Map.difference (GTypes.mods hSig) $ + Map.fromList $ Set.toList mSyms + iMor = GTypes.HMorphism bhSig hSig bIncl Map.empty Map.empty + return iMor + +hStatSymbItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => + lid -> GTypes.HSign sig -> + [GTypes.H_SYMB_ITEMS sym symb_items] -> + Result [GTypes.HRawSymbol sym raw_sym] +hStatSymbItems baseLid hsig sitems = do + rsyms <- foldM (\rsl sitem -> + case sitem of + GTypes.BaseSymbItems bsitems -> do + brSyms <- stat_symb_items baseLid + (GTypes.baseSig hsig) [bsitems] + return $ rsl ++ map GTypes.BaseRawSymbol brSyms + GTypes.HSymbItems _hk hsyms _ -> + return $ rsl ++ map GTypes.ASymbol hsyms + --TODO: would it be better to use AKindedSymb? + ) + [] sitems + return $ reverse rsyms + +-- for StaticAnalysis + +convertHTheory :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> + Maybe ((GTypes.HSign sig, + [Named (GTypes.HFORMULA sen symb_items raw_sym)]) -> + GTypes.H_BASIC_SPEC sen symb_items raw_sym) +convertHTheory baseLid = Just $ + \(s, nsens) -> if (s == emptyHSign baseLid) && (null nsens) + then GTypes.Basic_spec [] + else error $ "convertHTheory nyi" + +statSymbMapItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> Maybe (GTypes.HSign sig) + -> [GTypes.H_SYMB_MAP_ITEMS symb_map_items] + -> Result (EndoMap (GTypes.HRawSymbol sym raw_sym)) +statSymbMapItems baseLid sig1 msig2 sitems = do + let (bm, hm) = foldl (\(b, h) x -> case x of + GTypes.BaseSymbMapItems si -> (b ++ [si], h) + _ -> (b, h ++ [x]) + ) ([],[]) sitems + bmap <- stat_symb_map_items baseLid (GTypes.baseSig sig1) + (case msig2 of + Nothing -> Nothing + Just sig2 -> Just $ GTypes.baseSig sig2) + bm + let bmap' = Map.fromList $ + map (\(x,y) -> + (GTypes.BaseRawSymbol x, GTypes.BaseRawSymbol y)) $ + Map.toList bmap + getIdKind i sig = if Set.member i $ GTypes.noms sig + then GTypes.ASymbol $ GTypes.HSymb i GTypes.Nom + else if i `elem` (Map.keys $ GTypes.mods sig) + then GTypes.ASymbol $ GTypes.HSymb i $ + GTypes.Mod 2 + else error $ + "unknown symbol " ++ show i + -- TODO: improve + statSymbMapItem sf si = + case si of + GTypes.HSymbMapItems smis _ -> + foldl (\f x -> case x of + GTypes.HSymbItem i -> + let rsym = getIdKind i sig1 + in Map.insert rsym rsym f + GTypes.HMapItem i j _ -> + let rsym1 = getIdKind i sig1 + rsym2 = case msig2 of + Nothing -> case rsym1 of + GTypes.ASymbol (GTypes.HSymb _ k) -> + GTypes.ASymbol $ GTypes.HSymb j k + _ -> error "should never happen" + -- TODO: improve + Just sig2 -> getIdKind j sig2 + in Map.insert rsym1 rsym2 f) + -- TODO: improve, kinds should match + sf smis + _ -> error "should not happen" -- TODO: better error message + bmap'' = foldl statSymbMapItem Map.empty hm + return $ Map.union bmap' bmap'' + +inducedFromMorphism :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> + EndoMap (GTypes.HRawSymbol sym raw_sym) -> + GTypes.HSign sig -> + Result (GTypes.HMorphism sig mor) +inducedFromMorphism baseLid sm hsign = do + let (bm, nm, mm) = foldl (\(b, n, m) (rs1, rs2) -> case (rs1, rs2) of + (GTypes.BaseRawSymbol s1, GTypes.BaseRawSymbol s2) -> + (b ++ [(s1, s2)], n, m) + (GTypes.AKindedSymb k1 i, GTypes.AKindedSymb k2 i') -> + case (k1, k2) of + (GTypes.HKindAsG GTypes.Nom, + GTypes.HKindAsG GTypes.Nom) -> (b, n ++ [(i, i')], m) + (GTypes.HKindAsG (GTypes.Mod _), + GTypes.HKindAsG (GTypes.Mod _)) -> (b, n, m ++ [(i, i')]) + _ -> error "kind mismatch" -- TODO:improve message + (GTypes.ASymbol hsym1, GTypes.ASymbol hsym2) -> + case (hsym1, hsym2) of + (GTypes.HSymb i k1, + GTypes.HSymb i' k2) -> + case (k1, k2) of + (GTypes.Nom, GTypes.Nom) -> (b, n ++ [(i, i')], m) + (GTypes.Mod _, GTypes.Mod _) -> (b, n, m ++ [(i, i')]) + _ -> error "kind mismatch" -- TODO:improve message + _ -> error "mismatch" -- TODO: better error message + _ -> error "mismatch" -- TODO: better error message + ) ([], [], []) $ Map.toList sm + bMor <- induced_from_morphism baseLid (Map.fromList bm) $ + GTypes.baseSig hsign + let tbSig = cod bMor + tsign = GTypes.HSign tbSig + (Set.map (\x -> Map.findWithDefault x + x $ Map.fromList nm) $ + GTypes.noms hsign) + (Map.mapKeys (\x -> Map.findWithDefault x + x $ Map.fromList mm) $ + GTypes.mods hsign) + hMor = GTypes.HMorphism hsign tsign bMor + (Map.fromList nm) (Map.fromList mm) + return hMor + +inducedFromToMorphism :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> EndoMap (GTypes.HRawSymbol sym raw_sym) -> + ExtSign (GTypes.HSign sig) (GTypes.HSymbol sym) -> + ExtSign (GTypes.HSign sig) (GTypes.HSymbol sym) -> + Result (GTypes.HMorphism sig mor) +inducedFromToMorphism baseLid sm + (ExtSign hsign1 hsyms1) + (ExtSign hsign2 hsyms2) = do + let (bm, nm, mm) = foldl (\(b, n, m) (rs1, rs2) -> case (rs1, rs2) of + (GTypes.BaseRawSymbol s1, GTypes.BaseRawSymbol s2) -> + (b ++ [(s1, s2)], n, m) + (GTypes.AKindedSymb k1 i, + GTypes.AKindedSymb k2 i') -> case (k1, k2) of + (GTypes.HKindAsG GTypes.Nom, GTypes.HKindAsG GTypes.Nom) -> + (b, n ++ [(i, i')], m) + (GTypes.HKindAsG (GTypes.Mod _), + GTypes.HKindAsG (GTypes.Mod _)) -> + (b, n, m ++ [(i, i')]) + _ -> error "kind mismatch" -- TODO:improve message + (GTypes.ASymbol hsym1, + GTypes.ASymbol hsym2) -> case (hsym1, hsym2) of + (GTypes.HSymb i k1, GTypes.HSymb i' k2) -> case (k1, k2) of + (GTypes.Nom, GTypes.Nom) -> (b, n ++ [(i, i')], m) + (GTypes.Mod _, GTypes.Mod _) -> (b, n, m ++ [(i, i')]) + _ -> error "kind mismatch" -- TODO:improve message + _ -> error "mismatch" -- TODO: better error message + _ -> error "mismatch" -- TODO: better error message + ) ([], [], []) $ Map.toList sm + bsyms1 = concatMap (\x -> case x of + GTypes.BaseSymb s -> [s] + _ -> []) $ Set.toList hsyms1 + bsyms2 = concatMap (\x -> case x of + GTypes.BaseSymb s -> [s] + _ -> []) $ Set.toList hsyms2 + bMor <- induced_from_to_morphism baseLid (Map.fromList bm) + (ExtSign (GTypes.baseSig hsign1) $ Set.fromList bsyms1) + (ExtSign (GTypes.baseSig hsign2) $ Set.fromList bsyms2) + return $ GTypes.HMorphism hsign1 hsign2 bMor + (Map.fromList nm) (Map.fromList mm) +-- TODO: should check that these actually fit the signatures + + +data HTheoryAna sig sen symb_items raw_sym sym = HTheoryAna { + hSign :: GTypes.HSign sig, + declSyms :: Set.Set (GTypes.HSymbol sym), + hSens :: [Named (GTypes.HFORMULA sen symb_items raw_sym)], + hVars :: [GTypes.HRawSymbol sym raw_sym], + globAnnos :: GlobalAnnos, + anaDiags :: [Diagnosis] + } + deriving Show + +basicHAnalysis :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> +-- flag: has quantification on nominals? + [String] -> +-- kinds allowed in quantification on base symbols, empty for none + lid -> +-- lid of the base logic, to call methods in Logic class + String -> +-- name of the hybrid logic, for qualifications + Maybe sublogics -> +-- if we make the hybridization of a sublogic, +-- check that the case theory lives in that sublogic + (GTypes.H_BASIC_SPEC sen symb_items raw_sym, + GTypes.HSign sig, + GlobalAnnos) -> + Result (GTypes.H_BASIC_SPEC sen symb_items raw_sym, + ExtSign (GTypes.HSign sig) (GTypes.HSymbol sym), + [Named (GTypes.HFORMULA sen symb_items raw_sym)]) +basicHAnalysis hasQNominals kVars baseLid hLogic mSubl (bs, inSig, ga) = let + hth = HTheoryAna inSig Set.empty [] [] ga [] + (newBs, accTh) = + CState.runState (anaBasicHSpec hasQNominals kVars baseLid hLogic bs) hth + ds = reverse $ anaDiags accTh + outSig = hSign accTh + sents = hSens accTh + (baseSig, baseSens) = (GTypes.baseSig outSig, + concatMap (getBaseSens . sentence) sents) + in case mSubl of + Nothing -> + Result ds $ Just (newBs, + ExtSign outSig $ declSyms accTh, sents) + Just aSub -> + do + let tSub = sublogicOfTheo baseLid (baseSig, baseSens) + if isSubElem tSub aSub + then Result ds $ Just (newBs, ExtSign outSig $ declSyms accTh, sents) + else fail $ + "The sublogic of the analyzed theory should be " ++ + sublogicName aSub ++ ", but it is " ++ + sublogicName tSub + +getBaseSens :: GTypes.HFORMULA sen symb_items raw_sym -> [sen] +getBaseSens s = case s of + GTypes.Base_formula f _ -> [f] + GTypes.Negation hf _ -> getBaseSens hf + GTypes.Conjunction hfs _ -> concatMap getBaseSens hfs + GTypes.Disjunction hfs _ -> concatMap getBaseSens hfs + GTypes.Implication hf1 hf2 _ -> getBaseSens hf1 ++ getBaseSens hf2 + GTypes.Equivalence hf1 hf2 _ -> getBaseSens hf1 ++ getBaseSens hf2 + GTypes.AtState _ _ hf _ -> getBaseSens hf + GTypes.BoxFormula _ _ hf _ -> getBaseSens hf + GTypes.DiamondFormula _ _ hf _ -> getBaseSens hf + _ -> [] + +anaBasicHSpec :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> [String] -> lid -> String + -> GTypes.H_BASIC_SPEC sen symb_items raw_sym + -> CState.State (HTheoryAna sig sen symb_items raw_sym sym) + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) +anaBasicHSpec hasQNominals kVars baseLid hLogic (GTypes.Basic_spec al) = + fmap GTypes.Basic_spec $ + mapAnM (anaBasicHItems hasQNominals kVars baseLid hLogic) al + +anaBasicHItems :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> [String] -> lid -> String + -> GTypes.H_BASIC_ITEMS sen symb_items raw_sym + -> CState.State (HTheoryAna sig sen symb_items raw_sym sym) + (GTypes.H_BASIC_ITEMS sen symb_items raw_sym) +anaBasicHItems hasQNominals kVars baseLid hLogic bi = + case bi of + GTypes.Nom_decl (GTypes.Nom_item noms _) -> do + hth <- CState.get + let hsign = hSign hth + let Result ds mhsign' = + foldM (\s n -> addNomToSig s $ mkId [n]) hsign noms + case mhsign' of + Nothing -> error $ "cannot add nominals" ++ show ds + Just hsign' -> do + CState.put $ hth {hSign = hsign', anaDiags = ds ++ anaDiags hth} + return bi + GTypes.Mod_decl (GTypes.Mod_item mods i _) -> do + hth <- CState.get + let hsign = hSign hth + let Result ds mhsign' = + foldM (\s m -> addModToSig s (mkId [m]) i) hsign mods + case mhsign' of + Nothing -> error $ "cannot add modalities" ++ show ds + Just hsign' -> do + CState.put $ hth { hSign = hsign', anaDiags = ds ++ anaDiags hth } + return bi + GTypes.Axiom_items annofs -> do + hth <- CState.get + let (hth', annofs') = foldl (\(h, l) f -> + let (f', h') = CState.runState + (anaHFORMULA hasQNominals + kVars baseLid hLogic f) + h + in (h', f':l)) (hth, []) annofs + let replfs = reverse annofs' + nfs = map (makeNamedSen.snd) replfs + CState.put $ hth' {hSens = nfs ++ hSens hth'} + return $ GTypes.Axiom_items $ map fst replfs + +-- | Adds a nominal to the signature +addNomToSig :: GTypes.HSign sig -> Id -> Result (GTypes.HSign sig) +addNomToSig sig nom = + let + snoms = GTypes.noms sig + in if Set.member nom snoms then + Result [mkDiag Warning "redeclaring nominal" nom] $ Just sig + else return sig {GTypes.noms = Set.insert nom snoms} + +-- | Adds a modality to the signature +addModToSig :: GTypes.HSign sig -> Id -> Int -> Result (GTypes.HSign sig) +addModToSig sig md ar = + let + smods = GTypes.mods sig + in if Map.member md smods then + Result [mkDiag Warning "redeclaring modality" md] $ Just sig + else return sig {GTypes.mods = Map.insert md ar smods} + +-- | sentence simplification + +simplifyHSen :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> GTypes.HFORMULA sen symb_items raw_sym -> + GTypes.HFORMULA sen symb_items raw_sym +simplifyHSen baseLid hsig hsen = + case hsen of + GTypes.Base_formula pfrm r -> + let pfrm' = simplify_sen baseLid (GTypes.baseSig hsig) pfrm + in GTypes.Base_formula pfrm' r + GTypes.Nominal _ _ _ _ -> + hsen + GTypes.AtState s nom frm r -> + GTypes.AtState s nom (simplifyHSen baseLid hsig frm) r + GTypes.BoxFormula s md frm r -> + GTypes.BoxFormula s md (simplifyHSen baseLid hsig frm) r + GTypes.DiamondFormula s md frm r -> + GTypes.DiamondFormula s md (simplifyHSen baseLid hsig frm) r + GTypes.Negation frm r -> + GTypes.Negation (simplifyHSen baseLid hsig frm) r + GTypes.Conjunction xs r -> + GTypes.Conjunction (map (simplifyHSen baseLid hsig) xs) r + GTypes.Disjunction xs r -> + GTypes.Disjunction (map (simplifyHSen baseLid hsig) xs) r + GTypes.Implication x y r -> + GTypes.Implication (simplifyHSen baseLid hsig x) + (simplifyHSen baseLid hsig y) r + GTypes.Equivalence x y r -> + GTypes.Equivalence (simplifyHSen baseLid hsig x) + (simplifyHSen baseLid hsig y) r + GTypes.QuantVarsParse _ _ _ _ -> + error "GenHyb.GenMethods.simplifyHSen: sentence not analyzed" + GTypes.QuantVars q vdecls frm r -> + let Result ds msig = foldM (add_symb_to_sign baseLid) + (GTypes.baseSig hsig) $ + map (\x -> fromJust $ raw_to_symbol baseLid x) vdecls + in case msig of + Nothing -> error $ "GenHyb.GenMethods.simplifyHSen:" ++ show ds + Just bsig -> GTypes.QuantVars q vdecls + (simplifyHSen baseLid hsig{GTypes.baseSig = bsig} frm) + r + GTypes.QuantNominals q noms frm r -> + GTypes.QuantNominals q noms (simplifyHSen baseLid hsig frm) r + +getNomVars :: HTheoryAna sig sen symb_items raw_sym sym -> Set.Set Id +getNomVars hth = + Set.fromList $ + concatMap (\i -> case i of + GTypes.ASymbol (GTypes.HSymb v GTypes.Nom) -> [v] + _ -> []) $ + hVars hth + +anaHFORMULA :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> [String] -> lid -> + String -> -- the name of the hybrid logic, for qualfications + Annoted (GTypes.HFORMULA sen symb_items raw_sym) -> + CState.State (HTheoryAna sig sen symb_items raw_sym sym) + (Annoted (GTypes.HFORMULA sen symb_items raw_sym), + Annoted (GTypes.HFORMULA sen symb_items raw_sym) + ) +anaHFORMULA hasQNominals kVars baseLid hLogic hf = case item hf of + GTypes.Base_formula bsen r -> do + hth <- CState.get + let (isNom, mNomName) = is_nominal_sen baseLid + (Set.union (GTypes.noms $ hSign hth) $ + getNomVars hth) + bsen + if not isNom then do + let senAnaBase = case sen_analysis baseLid of + Nothing -> + error $ "sentence analysis not implemented for logic " + ++ show baseLid + Just f -> f + emptyBasicSpec = case convertTheory baseLid of + Nothing -> + error $ "can't convert theory in logic " + ++ show baseLid + Just f -> f $ (empty_signature baseLid, []) + baseVars = concatMap (\s -> case s of + GTypes.BaseRawSymbol rs -> [rs] + _ -> [] ) $ hVars hth + baseVarsSyms = fromJust $ convertRawSyms baseLid baseVars + let Result dadd mAnaSig = foldM (add_symb_to_sign baseLid) + (GTypes.baseSig $ hSign hth) baseVarsSyms + case mAnaSig of + Nothing -> do + CState.put $ hth {anaDiags = dadd ++ anaDiags hth} + return (hf, hf) + Just anaSig -> do + let Result ds mf = senAnaBase + (emptyBasicSpec, + anaSig, + bsen) + case mf of + Nothing -> do + CState.put $ hth {anaDiags = ds ++ anaDiags hth} + return (hf, hf) + Just (f1, f2) -> do + let hf1 = hf {item = GTypes.Base_formula f1 r} + hf2 = hf {item = GTypes.Base_formula f2 r} + CState.put $ hth {anaDiags = ds ++ anaDiags hth} + return (hf1, hf2) + else case mNomName of + Nothing -> + error "Can't have nominal formula without nominal name" + -- should never happen! + Just i -> + let iNom = GTypes.ASymbol $ GTypes.HSymb i GTypes.Nom + in if iNom `elem` hVars hth then + let hf' = hf { item = GTypes.Nominal "" + True (idToSimpleId i) + nullRange } + -- "" because we default to the top logic + in return (hf', hf') + else if i `elem` (GTypes.noms $ hSign hth) then + let hf' = hf { item = GTypes.Nominal "" + False (idToSimpleId i) + nullRange } + in return (hf', hf') + else do +-- TODO: undeclared nominals are not identified as nominals in isNominalSen! + CState.put $ + hth {anaDiags = (mkDiag Error + "undeclared nominal" i) : + (anaDiags hth) } + return (hf, hf) + GTypes.Negation f r -> do + (af1, af2) <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f + let hf'= hf { item = GTypes.Negation (item af2) r} + return (hf{item = GTypes.Negation (item af1) r}, hf') + GTypes.Conjunction fs r -> do + afs' <- mapM (anaHFORMULA hasQNominals kVars baseLid hLogic) $ + map emptyAnno fs + return $ (hf { item = GTypes.Conjunction (map (item.fst) afs') r}, + hf { item = GTypes.Conjunction (map (item.snd) afs') r}) + GTypes.Disjunction fs r -> do + afs' <- mapM (anaHFORMULA hasQNominals kVars baseLid hLogic) $ + map emptyAnno fs + return $ (hf { item = GTypes.Disjunction (map (item.fst) afs') r}, + hf { item = GTypes.Disjunction (map (item.snd) afs') r}) + GTypes.Implication f1 f2 r -> do + f1' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f1 + f2' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f2 + return $ (hf {item = GTypes.Implication (item $ fst f1') + (item $ fst f2') r}, + hf {item = GTypes.Implication (item $ snd f1') + (item $ snd f2') r}) + GTypes.Equivalence f1 f2 r -> do + f1' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f1 + f2' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f2 + return $ (hf {item = GTypes.Equivalence (item $ fst f1') + (item $ fst f2') r}, + hf {item = GTypes.Equivalence (item $ snd f1') + (item $ snd f2') r}) + GTypes.Nominal s _b i _r -> + if (s /= "") && (s /= hLogic) then + error $ "Expected logic " ++ hLogic ++ + " but got " ++ s ++ "instead. Check that qualification is correct." + else do + hth <- CState.get --TODO: check that if b holds, i must be a variable? + if ( Set.member (simpleIdToId i) (GTypes.noms $ hSign hth) ) || + ( (GTypes.ASymbol $ GTypes.HSymb (simpleIdToId i) GTypes.Nom) + `elem` (hVars hth)) + then return (hf, hf) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared nominal" i) + : (anaDiags hth)} + return (hf,hf) + GTypes.AtState s i f r -> + if (s /= "") && (s /= hLogic) then + error $ "Expected logic " ++ hLogic ++ " but got " + ++ s ++ "instead. Check that qualification is correct." + else do + hth <- CState.get + if ( Set.member (simpleIdToId i) (GTypes.noms $ hSign hth) ) || + ( (GTypes.ASymbol $ GTypes.HSymb (simpleIdToId i) GTypes.Nom) + `elem` (hVars hth)) + then do + f' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f + return $ (hf { item = GTypes.AtState s i (item $ fst f') r}, + hf { item = GTypes.AtState s i (item $ snd f') r}) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared nominal" i) + : (anaDiags hth)} + return (hf,hf) + GTypes.BoxFormula s i f r -> + if (s /= "") && (s /= hLogic) then + error $ "Expected logic " ++ hLogic ++ " but got " + ++ s ++ "instead. Check that qualification is correct." + else do + hth <- CState.get + if (simpleIdToId i) `elem` (Map.keys $ GTypes.mods $ hSign hth) + then do + f' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f + return $ (hf { item = GTypes.BoxFormula s i (item $ fst f') r}, + hf { item = GTypes.BoxFormula s i (item $ snd f') r}) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared modality" i) + : (anaDiags hth)} + return (hf,hf) + GTypes.DiamondFormula s i f r -> + if (s /= "") && (s /= hLogic) then + error $ "Expected logic " ++ hLogic ++ " but got " + ++ s ++ "instead. Check that qualification is correct." + else do + hth <- CState.get + if (simpleIdToId i) `elem` (Map.keys $ GTypes.mods $ hSign hth) + then do + f' <- anaHFORMULA hasQNominals kVars baseLid hLogic $ emptyAnno f + return $ (hf { item = GTypes.DiamondFormula s i (item $ fst f') r}, + hf { item = GTypes.DiamondFormula s i (item $ snd f') r}) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared modality" i) + : (anaDiags hth)} + return (hf,hf) + GTypes.QuantVarsParse q vs f r -> do + let s = case q of + GTypes.HUniversal x -> x + GTypes.HExistential x -> x + if (s /= "") && (s /= hLogic) then + error $ "Expected logic " ++ hLogic ++ " but got " + ++ s ++ "instead. Check that qualification is correct." + else do + hth <- CState.get + if null kVars then do + CState.put $ + hth {anaDiags = (mkDiag Error + "quantification on base symbols not allowed:" + (show hf)) + : (anaDiags hth)} + return (hf, hf) + else do + let Result dsyms mrsyms = stat_symb_items baseLid + (GTypes.baseSig $ hSign hth) vs + -- the variables don't appear in hSign hth, that's why we get Nothing! + case mrsyms of + Nothing -> do + CState.put $ hth {anaDiags = dsyms ++ anaDiags hth} + return (hf, hf) + Just rsyms -> + do + let msyms = convertRawSyms baseLid rsyms + -- TODO: this should be a Result, not a Maybe, so we know which symbol failed + case msyms of + Nothing -> do + CState.put $ + hth {anaDiags = (mkDiag Error + "could not convert all raw symbols to symbols" + (show rsyms)) + : anaDiags hth} + return (hf, hf) + Just syms -> do + let symsKinds = filter (\x -> not (x `elem` kVars)) $ + map (extSymKind baseLid) syms + case symsKinds of + [] -> do + let (f', hth') = CState.runState + (anaHFORMULA hasQNominals kVars + baseLid hLogic $ emptyAnno f) $ + hth {hVars = hVars hth ++ + map GTypes.BaseRawSymbol rsyms } + CState.put $ hth {anaDiags = anaDiags hth' ++ anaDiags hth} + return $ (hf{item = GTypes.QuantVars q rsyms (item $ fst f') r}, + hf{item = GTypes.QuantVars q rsyms (item $ snd f') r}) + _ -> do -- TODO: better error message! + let diagKinds = + map (\k -> mkDiag Error + ("quantification not allowed on symbols of kind " + ++ k) + (show hf) ) + symsKinds + CState.put $ hth {anaDiags = diagKinds ++ (anaDiags hth)} + return (hf, hf) + GTypes.QuantVars _ _ _ _ -> error $ "Already analyzed sentence:" ++ show hf + GTypes.QuantNominals q ns f r -> + if hasQNominals then do + hth <- CState.get + let (f', hth') = + CState.runState (anaHFORMULA hasQNominals kVars + baseLid hLogic $ emptyAnno f) $ + hth {hVars = hVars hth ++ + map (\i -> GTypes.ASymbol $ + GTypes.HSymb (simpleIdToId i) + GTypes.Nom) ns} + CState.put $ hth {anaDiags = anaDiags hth' ++ anaDiags hth} + return $ (hf { item = GTypes.QuantNominals q ns (item $ fst f') r}, + hf { item = GTypes.QuantNominals q ns (item $ snd f') r}) + else error "the logic does not allow quantification on nominals" + +convertRawSyms :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> [raw_sym] -> Maybe [sym] +convertRawSyms baseLid rawSymList = + let mSymList = map (raw_to_symbol baseLid) rawSymList + in if Nothing `elem` mSymList then + -- trace (show mSymList) $ + Nothing + else -- trace "convertRawSyms2" $ + Just $ map fromJust mSymList + +-- translate constraints to CASL sentences +-- for some this can be done independent of the underlying logic +-- for others, this requires logic-dependent analysis + +constrToSens :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> GTypes.HSign sig -> String -> + SemanticConstraint -> Result ([Named CBasic.CASLFORMULA]) +constrToSens lid hsign a c = + let binMods = map fst $ + filter (\(_, y) -> y == 2) $ + Map.toList $ GTypes.mods hsign + st = genName $ "ST_" ++ a + in case c of + ReflexiveMod -> + -- forall w : st . m(w,w) + return $ + map (\m -> makeNamed ("ga_reflexive_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w") st] $ + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w") st nullRange, + CBasic.Qual_var (genToken "w") st nullRange] + ) + binMods + SymmetricMod -> +-- forall w1, w2 : st . m(w1,w2) => m(w2, w1) + return $ + map (\m -> makeNamed ("ga_symmetric_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st] $ + CBasic.mkImpl + (CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange]) + (CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w2") st nullRange, + CBasic.Qual_var (genToken "w1") st nullRange]) + ) + binMods + TransitiveMod -> +-- forall w1, w2,w3 : st . m(w1,w2) /\ m(w2, w3) => m(w1, w3) + return $ + map (\m -> makeNamed ("ga_transitive_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st, + CBasic.mkVarDecl (genToken "w3") st] $ + CBasic.mkImpl + (CBasic.conjunct + [ CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange], + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w2") st nullRange, + CBasic.Qual_var (genToken "w3") st nullRange] + ] + ) + (CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w3") st nullRange]) + ) + binMods + SerialMod -> +-- forall w1 : st . exists w2 : st . m(w1, w2) + return $ + map (\m -> makeNamed ("ga_serial_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st] $ + CBasic.mkExist [CBasic.mkVarDecl (genToken "w2") st] $ + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange] + ) + binMods + EuclideanMod -> +-- forall w1, w2,w3 : st . m(w1,w2) /\ m(w1, w3) => m(w2, w3) + return $ + map (\m -> makeNamed ("ga_Euclidean_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st, + CBasic.mkVarDecl (genToken "w3") st] $ + CBasic.mkImpl + (CBasic.conjunct + [ CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange], + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w3") st nullRange] + ] + ) + (CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w2") st nullRange, + CBasic.Qual_var (genToken "w3") st nullRange]) + ) + binMods + FunctionalMod -> +-- forall w1 : st . exists! w2 : st . m(w1, w2) + return $ + map (\m -> makeNamed ("ga_functional_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st] $ + CBasic.Quantification + CBasic.Unique_existential + [CBasic.mkVarDecl (genToken "w2") st] + (CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange] + ) + nullRange + ) + binMods + LinearMod -> +-- forall w1, w2,w3 : st . m(w1,w2) /\ m(w1, w3) +-- => (m(w2, w3) \/ m(w3, w2) \/ w3 = w2) + return $ + map (\m -> makeNamed ("ga_linear_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st, + CBasic.mkVarDecl (genToken "w3") st] $ + CBasic.mkImpl + (CBasic.conjunct + [ CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange], + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w3") st nullRange] + ] + ) + (CBasic.disjunct + [CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w2") st nullRange, + CBasic.Qual_var (genToken "w3") st nullRange], + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w3") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange], + CBasic.mkStEq (CBasic.mkVarTerm (genToken "w2") st) + (CBasic.mkVarTerm (genToken "w3") st) + ] + ) + ) + binMods + TotalMod -> +-- forall w1, w2 : st . m(w1,w2) \/ m(w2, w1) + return $ + map (\m -> makeNamed ("ga_total_" ++ show m) $ + CBasic.mkForall [CBasic.mkVarDecl (genToken "w1") st, + CBasic.mkVarDecl (genToken "w2") st] $ + CBasic.disjunct + [CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w1") st nullRange, + CBasic.Qual_var (genToken "w2") st nullRange], + CBasic.mkPredication + (CBasic.mkQualPred m $ + CBasic.Pred_type [st, st] nullRange) + [CBasic.Qual_var (genToken "w2") st nullRange, + CBasic.Qual_var (genToken "w1") st nullRange] + ] + ) + binMods + _ -> constr_to_sens lid (GTypes.baseSig hsign) a c + + +senAnalysis :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => Bool -> [String] -> lid -> String -> + Maybe ((GTypes.H_BASIC_SPEC sen symb_items raw_sym, + GTypes.HSign sig, + GTypes.HFORMULA sen symb_items raw_sym + ) -> + Result (GTypes.HFORMULA sen symb_items raw_sym, + GTypes.HFORMULA sen symb_items raw_sym) + ) +senAnalysis hasQNominals kVars baseLid hLogic = Just $ + \ (_hBSpec, hsign, hsen) -> do + let + hth = HTheoryAna hsign Set.empty [] [] emptyGlobalAnnos [] + f = Annoted hsen nullRange [] [] + (annofs, _hth') = + CState.runState (anaHFORMULA hasQNominals + kVars baseLid hLogic f) hth + return (item $ fst annofs, item $ snd annofs) + +isNominalSenH :: Logic lid sublogics basic_spec sen + symb_items symb_map_items sig + mor sym raw_sym proof_tree + => lid -> Set.Set Id -> + GTypes.HFORMULA sen symb_items raw_sym + -> (Bool, Maybe Id) +isNominalSenH baseLid noms (GTypes.Base_formula sen _) = + is_nominal_sen baseLid noms sen +isNominalSenH _ _ _ = (False, Nothing) + +-------------------------------------------------------------------- +-- double hybridization +-------------------------------------------------------------------- + +senHAnalysis :: (Show sym, + Show raw_sym, + Show sen, + Show symb_items, + Show sublogics', + Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree') + => Bool -> [String] -> hlid -> String -> + Maybe ((GTypes.H_BASIC_SPEC (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym), + GTypes.HSign (GTypes.HSign sig), + GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + ) -> + Result (GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym), + GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + ) + ) +senHAnalysis hasQNominals kVars hlid hhLogic = Just $ + \ (_hBSpec, hsign, hsen) -> do + let + hth = HTheoryAna hsign Set.empty [] [] emptyGlobalAnnos [] + f = Annoted hsen nullRange [] [] + (annofs, _hth') = + CState.runState (anaLHFORMULA hasQNominals kVars hlid hhLogic f) hth + return (item $ fst annofs, item $ snd annofs) + +basicHHAnalysis :: (Show sym, + Show raw_sym, + Show sen, + Show symb_items, + Show sublogics', + Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + ) + => Bool -> +-- flag: has quantification on nominals? + [String] -> +-- kinds allowed in quantification on base symbols, empty for none + hlid -> +-- lid of the base logic, to call methods in Logic class + String -> + -- name of the hybrid logic, for qualifications + Maybe sublogics' -> +-- if we make the hybridization of a sublogic, +-- check that the case theory lives in that sublogic + (GTypes.H_BASIC_SPEC (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym), + GTypes.HSign (GTypes.HSign sig), GlobalAnnos) -> + Result (GTypes.H_BASIC_SPEC (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym), + ExtSign (GTypes.HSign (GTypes.HSign sig)) + (GTypes.HSymbol (GTypes.HSymbol sym)), + [Named (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + )] + ) +basicHHAnalysis hasQNominals kVars hlid hhLogic mSubl (bs, inSig, ga) = let + hth = HTheoryAna inSig Set.empty [] [] ga [] + (newBs, accTh) = + CState.runState (anaBasicHHSpec hasQNominals kVars hlid hhLogic bs) hth + ds = reverse $ anaDiags accTh + outSig = hSign accTh + sents = hSens accTh + (baseSig, baseSens) = (GTypes.baseSig outSig, + concatMap (\s -> case sentence s of + GTypes.Base_formula f _ -> [f] + _ -> []) sents) + in case mSubl of + Nothing -> + Result ds $ + Just (newBs, ExtSign outSig $ declSyms accTh, sents) + Just aSub -> do + let tSub = sublogicOfTheo hlid (baseSig, baseSens) + if isSubElem tSub aSub then + Result ds $ Just (newBs, ExtSign outSig $ declSyms accTh, sents) + else fail $ "The sublogic of the analyzed theory should be " ++ + sublogicName aSub ++ ", but it is " ++ sublogicName tSub + +anaBasicHHSpec :: (Show sym, + Show raw_sym, + Show sen, + Show symb_items, + Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + ) + => Bool -> [String] -> hlid -> String + -> GTypes.H_BASIC_SPEC (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + -> CState.State + (HTheoryAna (GTypes.HSign sig) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + (GTypes.HSymbol sym) + ) + (GTypes.H_BASIC_SPEC (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +anaBasicHHSpec hasQNominals kVars hlid hhLogic (GTypes.Basic_spec al) = + fmap GTypes.Basic_spec $ + mapAnM (anaBasicHHItems hasQNominals kVars hlid hhLogic) al + +anaBasicHHItems :: (Show sym, + Show raw_sym, + Show sen, + Show symb_items, + Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + ) + => Bool -> [String] -> hlid -> String + -> GTypes.H_BASIC_ITEMS (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + -> CState.State (HTheoryAna (GTypes.HSign sig) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + (GTypes.HSymbol sym)) + (GTypes.H_BASIC_ITEMS + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +anaBasicHHItems hasQNominals kVars hlid hhLogic bi = + case bi of + GTypes.Nom_decl (GTypes.Nom_item noms _) -> do + hth <- CState.get + let hsign = hSign hth + let Result ds mhsign' = foldM (\s n -> addNomToSig s $ mkId [n]) + hsign noms + case mhsign' of + Nothing -> error $ "cannot add nominals" ++ show ds + Just hsign' -> do + CState.put $ hth {hSign = hsign', anaDiags = ds ++ anaDiags hth} + return bi + GTypes.Mod_decl (GTypes.Mod_item mods i _) -> do + hth <- CState.get + let hsign = hSign hth + let Result ds mhsign' = foldM (\s m -> addModToSig s (mkId [m]) i) + hsign mods + case mhsign' of + Nothing -> error $ "cannot add modalities" ++ show ds + Just hsign' -> do + CState.put $ hth { hSign = hsign', anaDiags = ds ++ anaDiags hth } + return bi + GTypes.Axiom_items annofs -> do + hth <- CState.get + let (hth', annofs') = foldl (\(h, l) f -> + let (f', h') = + CState.runState + (anaLHFORMULA hasQNominals + kVars hlid hhLogic f) h + in (h', f':l)) (hth, []) annofs + let replfs = reverse annofs' + nfs = map (makeNamedSen.snd) replfs + CState.put $ hth' {hSens = nfs ++ hSens hth'} + return $ GTypes.Axiom_items $ map fst replfs + +downcastHSen :: String -> + GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) -> + Result (GTypes.HFORMULA sen symb_items raw_sym) +downcastHSen hLogic hhsen = + case hhsen of + GTypes.Base_formula hsen _ -> return hsen + GTypes.Nominal s b i r-> + if (s == hLogic) then +-- TODO: if s is "", warning that the default logic +-- changes from hLogic to its base? + error $ "Cannot convert nominal from " ++ + hLogic ++ "to a sentence in the base logic" + else return $ GTypes.Nominal s b i r + GTypes.AtState s nom frm r -> + if (s == hLogic) then + error $ "Cannot convert sentence from " ++ + hLogic ++ "to a sentence in the base logic" + else do + frm' <- downcastHSen hLogic frm + return $ GTypes.AtState s nom frm' r + GTypes.BoxFormula s md frm r -> + if (s == hLogic) then + error $ "Cannot convert sentence from " ++ + hLogic ++ "to a sentence in the base logic" + else do + frm' <- downcastHSen hLogic frm + return $ GTypes.BoxFormula s md frm' r + GTypes.DiamondFormula s md frm r -> + if (s == hLogic) then + error $ "Cannot convert sentence from " ++ + hLogic ++ "to a sentence in the base logic" + else do + frm' <- downcastHSen hLogic frm + return $ GTypes.DiamondFormula s md frm' r + GTypes.Negation frm r -> do + frm' <- downcastHSen hLogic frm + return $ GTypes.Negation frm' r + GTypes.Conjunction xs r -> do + xs' <- mapM (downcastHSen hLogic) xs + return $ GTypes.Conjunction xs' r + GTypes.Disjunction xs r -> do + xs' <- mapM (downcastHSen hLogic) xs + return $ GTypes.Disjunction xs' r + GTypes.Implication x y r -> do + x' <- downcastHSen hLogic x + y' <- downcastHSen hLogic y + return $ GTypes.Implication x' y' r + GTypes.Equivalence x y r -> do + x' <- downcastHSen hLogic x + y' <- downcastHSen hLogic y + return $ GTypes.Equivalence x' y' r + _ -> + error $ "Cannot convert quantified sentence from " ++ + hLogic ++ "to a sentence in the base logic" + +anaLHFORMULA :: (Show sym, + Show raw_sym, + Show sen, + Show symb_items, + Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + ) + => Bool -> [String] -> hlid -> String -> + Annoted (GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) -> + CState.State (HTheoryAna (GTypes.HSign sig) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + (GTypes.HSymbol sym)) + (Annoted (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)), + Annoted (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) + ) +anaLHFORMULA hasQNominals kVars hlid hhLogic hhf = case item hhf of + GTypes.Base_formula hsen r -> do + hth <- CState.get + let allNoms = Set.union (getNomVars hth) $ + Set.union (GTypes.noms $ hSign hth) + (GTypes.noms $ GTypes.baseSig $ hSign hth) + let (isNom, mNomName) = is_nominal_sen hlid allNoms hsen +-- TODO: perhaps add the variables too? + if not isNom then do + let senAnaBase = case sen_analysis hlid of + Nothing -> error $ "sentence analysis not implemented for logic " + ++ show hlid + Just f -> f + emptyBasicSpec = case convertTheory hlid of + Nothing -> error $ "can't convert theory in logic " + ++ show hlid + Just f -> f $ (empty_signature hlid, []) + baseVars = concatMap (\s -> case s of + GTypes.BaseRawSymbol rs -> [rs] + _ -> [] ) $ hVars hth + baseVarsSyms = fromJust $ convertRawSyms hlid baseVars + let Result dadd mAnaSig = foldM (add_symb_to_sign hlid) + (GTypes.baseSig $ hSign hth) baseVarsSyms + case mAnaSig of + Nothing -> do + CState.put $ hth {anaDiags = dadd ++ anaDiags hth} + return (hhf, hhf) + Just anaSig -> do + let Result ds mf = senAnaBase + (emptyBasicSpec, + anaSig, + hsen) + case mf of + Nothing -> do + CState.put $ hth {anaDiags = ds ++ anaDiags hth} + return (hhf, hhf) + Just (f1, f2) -> do + let hhf1 = hhf {item = GTypes.Base_formula f1 r} + hhf2 = hhf {item = GTypes.Base_formula f2 r} + CState.put $ hth {anaDiags = ds ++ anaDiags hth} + return (hhf1, hhf2) + else case mNomName of + Nothing -> error "Can't have nominal formula without nominal name" + -- should never happen! + Just i -> -- trace ("i:" ++ show i) $ + let iNom = GTypes.ASymbol $ GTypes.HSymb i GTypes.Nom + in if iNom `elem` hVars hth then + let hhf' = hhf { item = GTypes.Nominal "" True + (idToSimpleId i) nullRange } + -- TODO: should variables always be top? + in return (hhf', hhf') + else if i `elem` (GTypes.noms $ hSign hth) then + let hhf' = hhf { item = GTypes.Nominal "" False + (idToSimpleId i) nullRange } + -- top layer + in return (hhf', hhf') + else if i `elem` + (GTypes.noms $ GTypes.baseSig $ hSign hth ) + then let hhf' = hhf { item = GTypes.Base_formula + (GTypes.Nominal "" + False + (idToSimpleId i) + nullRange) + nullRange } + -- lower layer + in return (hhf', hhf') + else do +-- TODO: undeclared nominals are not identified as nominals in isNominalSen! + CState.put $ + hth {anaDiags = (mkDiag Error + "undeclared nominal" i) + : (anaDiags hth) } + return (hhf, hhf) + GTypes.Negation f r -> do + (af1, af2) <- anaLHFORMULA hasQNominals kVars hlid hhLogic (emptyAnno f) + let hhf'= hhf { item = GTypes.Negation (item af2) r} + return (hhf{item = GTypes.Negation (item af1) r}, hhf') + GTypes.Conjunction fs r -> do + afs' <- mapM (anaLHFORMULA hasQNominals kVars hlid hhLogic) $ + map emptyAnno fs + return $ (hhf { item = GTypes.Conjunction (map (item.fst) afs') r}, + hhf { item = GTypes.Conjunction (map (item.snd) afs') r}) + GTypes.Disjunction fs r -> do + afs' <- mapM (anaLHFORMULA hasQNominals kVars hlid hhLogic) $ + map emptyAnno fs + return $ (hhf { item = GTypes.Disjunction (map (item.fst) afs') r}, + hhf { item = GTypes.Disjunction (map (item.snd) afs') r}) + GTypes.Implication f1 f2 r -> do + f1' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f1 + f2' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f2 + return $ (hhf {item = GTypes.Implication (item $ fst f1') + (item $ fst f2') r}, + hhf {item = GTypes.Implication (item $ snd f1') + (item $ snd f2') r}) + GTypes.Equivalence f1 f2 r -> do + f1' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f1 + f2' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f2 + return $ (hhf {item = GTypes.Equivalence (item $ fst f1') + (item $ fst f2') r}, + hhf {item = GTypes.Equivalence (item $ snd f1') + (item $ snd f2') r}) + GTypes.Nominal s b i r -> + if (s /= language_name hlid) then do +-- if s is hlid, then the nominal has been qualified +-- with the name of the lower level logic +-- TODO: better pass the name of the toplogic and check. +-- Thus one could downcast defaults too... + hth <- CState.get --TODO: check that if b holds, i must be a variable? + if ( Set.member (simpleIdToId i) (GTypes.noms $ hSign hth) ) || + ( (GTypes.ASymbol $ GTypes.HSymb (simpleIdToId i) GTypes.Nom) + `elem` (hVars hth)) + then return (hhf, hhf) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared nominal" i) + : (anaDiags hth)} + return (hhf,hhf) + else anaLHFORMULA hasQNominals kVars hlid hhLogic $ + emptyAnno $ + GTypes.Base_formula (GTypes.Nominal s b i r) nullRange + GTypes.AtState s i f r -> + if (s /= language_name hlid) then do + hth <- CState.get + if ( Set.member (simpleIdToId i) (GTypes.noms $ hSign hth) ) || + ( (GTypes.ASymbol $ GTypes.HSymb (simpleIdToId i) GTypes.Nom) + `elem` (hVars hth)) + then do + f' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f + return $ (hhf { item = GTypes.AtState s i (item $ fst f') r}, + hhf { item = GTypes.AtState s i (item $ snd f') r}) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared nominal" i) + : (anaDiags hth)} + return (hhf,hhf) + else do + let Result diag mhsen = downcastHSen hhLogic f + case mhsen of + Nothing -> error $ "could not convert formula " ++ show f ++ + " to lower layer of hybridization:" ++ show diag + Just hsen -> + anaLHFORMULA hasQNominals kVars hlid hhLogic $ + emptyAnno $ + GTypes.Base_formula (GTypes.AtState s i hsen r) nullRange + GTypes.BoxFormula s i f r -> + if (s /= language_name hlid) then do + hth <- CState.get + if (simpleIdToId i) `elem` (Map.keys $ GTypes.mods $ hSign hth) + then do + f' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f + return $ (hhf { item = GTypes.BoxFormula s i (item $ fst f') r}, + hhf { item = GTypes.BoxFormula s i (item $ snd f') r}) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared modality" i) + : (anaDiags hth)} + return (hhf,hhf) + else do + let Result diag mhsen = downcastHSen hhLogic f + case mhsen of + Nothing -> error $ "could not convert formula " ++ show f ++ + " to lower layer of hybridization:" ++ show diag + Just hsen -> + anaLHFORMULA hasQNominals kVars hlid hhLogic $ + emptyAnno $ + GTypes.Base_formula (GTypes.BoxFormula s i hsen r) nullRange + GTypes.DiamondFormula s i f r -> + if (s /= language_name hlid) then do + hth <- CState.get + if (simpleIdToId i) `elem` (Map.keys $ GTypes.mods $ hSign hth) + then do + f' <- anaLHFORMULA hasQNominals kVars hlid hhLogic $ emptyAnno f + return $ (hhf { item = GTypes.DiamondFormula s i (item $ fst f') r}, + hhf { item = GTypes.DiamondFormula s i (item $ snd f') r}) + else do + CState.put $ hth {anaDiags = (mkDiag Error "undeclared modality" i) + : (anaDiags hth)} + return (hhf,hhf) + else do + let Result diag mhsen = downcastHSen hhLogic f + case mhsen of + Nothing -> error $ "could not convert formula " ++ show f ++ + " to lower layer of hybridization:" ++ show diag + Just hsen -> + anaLHFORMULA hasQNominals kVars hlid hhLogic $ + emptyAnno $ + GTypes.Base_formula (GTypes.DiamondFormula s i hsen r) nullRange + GTypes.QuantVarsParse q vs f r -> do + let s = case q of + GTypes.HUniversal x -> x + GTypes.HExistential x -> x + if (s /= language_name hlid) then do + hth <- CState.get + if null kVars then do + CState.put $ + hth {anaDiags = (mkDiag Error + "quantification on base symbols not allowed:" + (show hhf)) + : (anaDiags hth)} + return (hhf, hhf) + else do + let Result dsyms mrsyms = + stat_symb_items hlid (GTypes.baseSig $ hSign hth) vs + case mrsyms of + Nothing -> do + CState.put $ hth {anaDiags = dsyms ++ anaDiags hth} + return (hhf, hhf) + Just rsyms -> do + let msyms = convertRawSyms hlid rsyms +-- TODO: this should be a Result, not a Maybe, so we know which symbols failed + case msyms of + Nothing -> do + CState.put $ + hth {anaDiags = (mkDiag Error + "could not convert all raw symbols to symbols" + (show rsyms)) + : anaDiags hth} + return (hhf, hhf) + Just syms -> do + let symsKinds = filter (\x -> not (x `elem` kVars)) $ + map (extSymKind hlid) syms + case symsKinds of + [] -> do + let (f', _) = CState.runState + (anaLHFORMULA hasQNominals kVars + hlid hhLogic $ emptyAnno f) $ + hth {hVars = hVars hth ++ + map GTypes.BaseRawSymbol rsyms } + --trace ("f' : " ++ show f' ) $ + return $ (hhf{item = GTypes.QuantVars q rsyms (item $ fst f') r}, + hhf{item = GTypes.QuantVars q rsyms (item $ snd f') r}) + _ -> do -- TODO: better error message! + let diagKinds = + map (\k -> mkDiag Error + ("quantification not allowed on symbols of kind " + ++ k) (show hhf) ) + symsKinds + CState.put $ hth {anaDiags = diagKinds ++ (anaDiags hth)} + return (hhf, hhf) + else do +-- here downcastHSen on f is not enough, +-- we must also downcast the list of variables +-- only GTypes.BaseSymbItems are allowed + let Result diag mhsen = downcastHSen hhLogic f + case mhsen of + Nothing -> error $ "could not convert formula " ++ show f ++ + " to lower layer of hybridization:" ++ show diag + Just hsen -> do + let vs' = map (\x -> case x of + GTypes.BaseSymbItems y -> y + _ -> error $ "only base symbols allowed" ++ + " in lower layer quantification:" + ++ show x ) + vs + anaLHFORMULA hasQNominals kVars hlid hhLogic $ + emptyAnno $ + GTypes.Base_formula (GTypes.QuantVarsParse q vs' hsen r) nullRange + GTypes.QuantVars _ _ _ _ -> + error $ "Already analyzed sentence:" ++ show hhf + GTypes.QuantNominals q ns f r -> do + let s = case q of + GTypes.HUniversal x -> x + GTypes.HExistential x -> x + if (s /= language_name hlid) then do + if hasQNominals then do + hth <- CState.get + let (f',_) = CState.runState + (anaLHFORMULA hasQNominals kVars + hlid hhLogic $ emptyAnno f) $ + hth {hVars = hVars hth ++ + map (\i -> GTypes.ASymbol $ + GTypes.HSymb (simpleIdToId i) + GTypes.Nom) + ns} + return $ (hhf { item = GTypes.QuantNominals q ns (item $ fst f') r}, + hhf { item = GTypes.QuantNominals q ns (item $ snd f') r}) + else error "the logic does not allow quantification on nominals" + else do + let Result diag mhsen = downcastHSen hhLogic f + case mhsen of + Nothing -> error $ "could not convert formula " ++ show f ++ + " to lower layer of hybridization:" ++ show diag + Just hsen -> + anaLHFORMULA hasQNominals kVars hlid hhLogic $ + emptyAnno $ + GTypes.Base_formula (GTypes.QuantNominals q ns hsen r) nullRange + +------------------------------------ +-- parser for double hybridization +------------------------------------ + +parseHHBasicSpec :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -- True for eng. notation, False for math. notation + -> Bool -- admits quantification on nominals + -> Bool -- admits quantification on symbols of base logic + -> hlid -- lid for base logic + -> PrefixMap + -> AParser st (GTypes.H_BASIC_SPEC + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +parseHHBasicSpec eng hasQNominals kVars hlid pm = + fmap GTypes.Basic_spec + (annosParser (parseHHBasicItems eng hasQNominals kVars hlid pm)) + <|> (oBraceT >> cBraceT >> return (GTypes.Basic_spec [])) + +parseHHBasicItems :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (GTypes.H_BASIC_ITEMS + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +parseHHBasicItems eng hasQNominals kVars hlid pm = + parseHHAxItems eng hasQNominals kVars hlid pm +-- if this is not first, +-- the parser for basic items consumes more than it should + <|> + do (as, ps) <- keyThenList (nomP eng) simpleId + return $ GTypes.Nom_decl $ GTypes.Nom_item as ps + <|> + do (as, ps) <- keyThenList (modP eng) simpleId + _c <- colonT + ni <- getNumber + let i = read ni :: Int + return $ GTypes.Mod_decl $ GTypes.Mod_item as i ps + +parseHHAxItems :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (GTypes.H_BASIC_ITEMS + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +parseHHAxItems eng hasQNominals kVars hlid pm = do + d <- dotT + (fs, ds) <- (aHHFormula eng hasQNominals kVars hlid pm) + `separatedBy` dotT + (_, an) <- optSemi + let _ = catRange (d : ds) + ns = init fs ++ [appendAnno (last fs) an] + return $ GTypes.Axiom_items ns + +-- | parser for annoted formulae +aHHFormula :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (Annoted (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym))) +aHHFormula eng hasQNominals kVars hlid pm = + allAnnoParser (topHHformula eng hasQNominals kVars hlid pm) + +-- | toplevel formula parser +topHHformula :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +topHHformula eng hasQNominals kVars hlid pm = + (andOrHHFormula eng hasQNominals kVars hlid pm) + >>= (optImplHHForm eng hasQNominals kVars hlid pm) + +andOrHHFormula :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +andOrHHFormula eng hasQNominals kVars hlid pm = + (hhFormula eng hasQNominals kVars hlid pm) + >>= (optAndOrHH eng hasQNominals kVars hlid pm) + +optImplHHForm :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap + -> GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + -> AParser st (GTypes.HFORMULA + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +optImplHHForm eng hasQNominals kVars hlid pm f = do + _c <- CFormula.implKey + (fs, _ps) <- (andOrHHFormula eng hasQNominals kVars hlid pm) + `separatedBy` CFormula.implKey + return $ makeImpl (f : fs) + <|> do + c <- asKey equivS + g <- andOrHHFormula eng hasQNominals kVars hlid pm + return $ GTypes.Equivalence f g $ tokPos c + <|> return f + +optAndOrHH :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym) + -> AParser st (GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +optAndOrHH eng hasQNominals kVars hlid pm f = do + c <- CFormula.andKey + (fs, ps) <- (hhFormula eng hasQNominals kVars hlid pm) + `separatedBy` CFormula.andKey + return $ GTypes.Conjunction (f : fs) $ catRange $ c : ps + <|> do + c <- CFormula.orKey + (fs, ps) <- (hhFormula eng hasQNominals kVars hlid pm) + `separatedBy` CFormula.orKey + return $ GTypes.Disjunction (f : fs) $ catRange $ c : ps + <|> return f + +hhFormula :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +hhFormula eng hasQNominals kVars hlid pm = + if eng + then + do + c <- asKey "At state" + n <- simpleId + s <- optQual + _ <- colonT + f <- topHHformula eng hasQNominals kVars hlid pm + -- here should be formula without @? + return $ GTypes.AtState s n f $ tokPos c + <|> + do + c <- asKey notS <|> asKey negS "\"not\"" + f <- hhFormula eng hasQNominals kVars hlid pm --topformula + return $ GTypes.Negation f $ tokPos c + <|> + do + c1 <- asKey "Through" --lessS + md <- propId ["sometimes", "always"] + s <- optQual + _ <- commaT + sen <- do + c2 <- asKey "sometimes" + f <- topHHformula eng hasQNominals kVars hlid pm + return $ GTypes.DiamondFormula s md f $ toRange c1 [] c2 + <|> do + c2 <- asKey "always" + f <- topHHformula eng hasQNominals kVars hlid pm + return $ GTypes.BoxFormula s md f $ toRange c1 [] c2 + return sen + <|> + parenHHFormula eng hasQNominals kVars hlid pm + <|> + do + (q, p) <- quant + let s = case q of + GTypes.HUniversal x -> x + GTypes.HExistential x -> x + if (s /= show hlid) then + parseQHHFormula eng hasQNominals kVars hlid (q, p) pm + else do + let (hasQNominalsBase, kVarsBase) = fromJust $ hyb_params hlid + case parse_q_formula hlid of + Nothing -> error "should never happen" +-- TODO: improve error message + Just qFormParser -> do + f <- qFormParser eng hasQNominalsBase + (not $ null kVarsBase) (q, p) pm + return $ GTypes.Base_formula f nullRange + <|> + do + let fparser = case parse_prim_formula hlid of + Nothing -> + error $ "no prim formula parser for logic " ++ show hlid + Just f -> f + f <- fparser pm + return $ GTypes.Base_formula f nullRange + -- this should also catch nominals as terms. + -- We have to make sure during static analysis that this is reverted! + <|> do -- qualified symbols are nominals + nom <- simpleId + _ <- asKey "::" + qual <- simpleId + return $ GTypes.Nominal (show qual) False nom nullRange + + else + do + c <- asKey asP + n <- simpleId + s <- optQual + _ <- colonT + f <- topHHformula eng hasQNominals kVars hlid pm + return $ GTypes.AtState s n f $ tokPos c + <|> + do + c <- asKey notS <|> asKey negS "\"not\"" + f <- hhFormula eng hasQNominals kVars hlid pm + return $ GTypes.Negation f $ tokPos c + <|> + do + c1 <- asKey lessS + md <- propId [greaterS] + s <- optQual + c2 <- asKey greaterS + f <- topHHformula eng hasQNominals kVars hlid pm + return $ GTypes.DiamondFormula s md f $ toRange c1 [] c2 + <|> + do + c1 <- oBracketT + md <- propId ["]"] + s <- optQual + c2 <- cBracketT + f <- topHHformula eng hasQNominals kVars hlid pm + return $ GTypes.BoxFormula s md f $ toRange c1 [] c2 + <|> + parenHHFormula eng hasQNominals kVars hlid pm + <|> + do + (q, p) <- quant + let s = case q of + GTypes.HUniversal x -> x + GTypes.HExistential x -> x + if (s /= show hlid) then + parseQHHFormula eng hasQNominals kVars hlid (q, p) pm + else do + let (hasQNominalsBase, kVarsBase) = fromJust $ hyb_params hlid + case parse_q_formula hlid of + Nothing -> error "should never happen" + -- TODO: improve error message + Just qFormParser -> do + f <- qFormParser eng hasQNominalsBase + (not $ null kVarsBase) (q, p) pm + return $ GTypes.Base_formula f nullRange + <|> + do + let fparser = case parse_prim_formula hlid of + Nothing -> + error $ "no prim formula parser for logic " ++ show hlid + Just f -> f + f <- fparser pm + return $ GTypes.Base_formula f nullRange + -- this should also catch nominals as terms. + -- We have to make sure during static analysis that this is reverted! + <|> do -- qualified symbols are nominals + nom <- simpleId + _ <- asKey "::" + qual <- simpleId + return $ GTypes.Nominal (show qual) False nom nullRange + -- Note: always False here, no qualifications for variables + +parenHHFormula :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> PrefixMap -> + AParser st (GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +parenHHFormula eng hasQNominals kVars hlid pm = do + oParenT << addAnnos + f <- topHHformula eng hasQNominals kVars hlid pm << addAnnos + cParenT >> return f + +parseQHHFormula :: Logic hlid + sublogics' + (GTypes.H_BASIC_SPEC sen symb_items raw_sym) + (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.H_SYMB_MAP_ITEMS symb_map_items) + (GTypes.HSign sig) + (GTypes.HMorphism sig mor) + (GTypes.HSymbol sym) + (GTypes.HRawSymbol sym raw_sym) + proof_tree' + => Bool -> Bool -> Bool -> hlid -> (GTypes.HQUANT, Token) -> PrefixMap + -> AParser st (GTypes.HFORMULA (GTypes.HFORMULA sen symb_items raw_sym) + (GTypes.H_SYMB_ITEMS sym symb_items) + (GTypes.HRawSymbol sym raw_sym)) +parseQHHFormula eng hasQNominals kVars hlid (q, p) pm = + do -- first try quantification on nominals, or the parser will complain + (vs, _ps) <- keyThenList (nomP eng) simpleId + _d <- dotT + f <- topHHformula eng hasQNominals kVars hlid pm + if hasQNominals then + return $ GTypes.QuantNominals q vs f nullRange + else error $ "the logic does not admit quantification on nominals" + <|> + do + let symParser = case parse_symb_items hlid of + Nothing -> + error $ "no symbol parser for logic " ++ show hlid + Just f -> f + (sitems, ps) <- (symParser pm) `separatedBy` commaT + d <- dotT + f <- topHHformula eng hasQNominals kVars hlid pm + if kVars then + return $ GTypes.QuantVarsParse q sitems f $ toRange p ps d + else error $ "the logic does not admit quantification on base symbols" diff --git a/GenHyb/GenTypes.hs b/GenHyb/GenTypes.hs new file mode 100644 index 0000000000..a0e66b3b2f --- /dev/null +++ b/GenHyb/GenTypes.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances, DeriveDataTypeable #-} +{- | +Module : ./GenHyb/GenTypes +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +Generic types for hybridisation of logics. +-} + +module GenHyb.GenTypes where + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Common.Id as Id +import Data.Data +import Common.AS_Annotation as AS_Anno + +-- | generic hybrid signatures +data HSign sig = HSign { + baseSig :: sig, + noms :: Set.Set Id, + mods :: Map.Map Id Int} + deriving (Show, Eq, Ord, Typeable, Data) + + +-- | generic hybrid signature morphisms +data HMorphism sig mor = HMorphism + { source :: HSign sig + , target :: HSign sig + , baseMor :: mor + , nomMap :: Map.Map Id Id + , modMap :: Map.Map Id Id + } deriving (Show, Eq, Ord, Typeable, Data) + +-- | generic hybrid formulas + +data HFORMULA sen symb_items raw_sym = + Base_formula sen Id.Range + -- add a Maybe String to handle multiple layers of hybridization + -- base sentences + | Negation (HFORMULA sen symb_items raw_sym) Id.Range + -- pos: not + | Conjunction [HFORMULA sen symb_items raw_sym] Id.Range + -- pos: "/\"s + | Disjunction [HFORMULA sen symb_items raw_sym] Id.Range + -- pos: "\/"s + | Implication (HFORMULA sen symb_items raw_sym) + (HFORMULA sen symb_items raw_sym) Id.Range + -- pos: "=>" + | Equivalence (HFORMULA sen symb_items raw_sym) + (HFORMULA sen symb_items raw_sym) Id.Range + -- pos: "<=>" + | Nominal String Bool Id.Token Id.Range + -- the String is the optional qualification, + -- leave empty for the topmost logic + -- the bool flag is true for nominal variables! + -- nominals as sentences + | AtState String Id.Token + (HFORMULA sen symb_items raw_sym) Id.Range + -- at_i formulas + | BoxFormula String Id.Token + (HFORMULA sen symb_items raw_sym) Id.Range + -- pos: "< >" + | DiamondFormula String Id.Token + (HFORMULA sen symb_items raw_sym) Id.Range + -- pos: "[ ]" + | QuantVarsParse HQUANT [symb_items] + (HFORMULA sen symb_items raw_sym) Id.Range + -- pos: QUANTIFIER, semi colons, dot + | QuantVars HQUANT [raw_sym] + (HFORMULA sen symb_items raw_sym) Id.Range + | QuantNominals HQUANT [Id.Token] + (HFORMULA sen symb_items raw_sym) Id.Range + deriving (Show, Eq, Ord, Typeable, Data) + +nomS, modS :: String +nomS = "nominal" +modS = "modality" + +data HQUANT = HUniversal String | HExistential String + -- the quantifier must have a logic identifier, + -- and if it's empty it defaults to the current logic + deriving (Show, Eq, Ord, Typeable, Data) + +-- | generic hybrid basic spec +data NOM_ITEM = Nom_item [Token] Range + deriving (Show, Typeable, Data) + +data MOD_ITEM = Mod_item [Token] Int Range + deriving (Show, Typeable, Data) + +data H_BASIC_ITEMS sen symb_items raw_sym = + Nom_decl NOM_ITEM + | Mod_decl MOD_ITEM + | Axiom_items [AS_Anno.Annoted (HFORMULA sen symb_items raw_sym)] + deriving (Show, Typeable, Data) + +newtype H_BASIC_SPEC sen symb_items raw_sym = + Basic_spec [AS_Anno.Annoted (H_BASIC_ITEMS sen symb_items raw_sym)] + deriving (Show, Typeable, Data) + +-- | generic symb_items + +data H_SYMB_KIND = NomKind | ModKind + deriving (Show, Eq, Ord, Typeable, Data) + +data H_SYMB_ITEMS sym symb_items = + BaseSymbItems symb_items + | HSymbItems H_SYMB_KIND [HSymbol sym] Id.Range + deriving (Show, Eq, Ord, Typeable, Data) + +-- | generic symb_map_items + +data H_SYMB_MAP_ITEMS symb_map_items = + BaseSymbMapItems symb_map_items + | HSymbMapItems [H_SYMB_OR_MAP] Id.Range + deriving (Show, Eq, Ord, Typeable, Data) + +data H_SYMB_OR_MAP = HSymbItem Id | HMapItem Id Id Id.Range + deriving (Show, Eq, Ord, Typeable, Data) + +-- | generic hybrid symbols + +data HSymbol sym = BaseSymb sym + | HSymb Id HKind + deriving (Show, Eq, Ord, Typeable, Data) + +data HKind = Mod Int | Nom + deriving (Show, Eq, Ord, Typeable, Data) + +-- | generic raw symbols + +data HRawSymbol sym raw_sym = + BaseRawSymbol raw_sym + -- in the next two alternatives, only modalities and nominals + | ASymbol (HSymbol sym) + | AKindedSymb GKind Id + deriving (Show, Eq, Ord, Typeable, Data) + +data GKind = Implicit + -- it seems to me we never need this, we can rely on base logic for this! + | HKindAsG HKind + deriving (Show, Eq, Ord, Typeable, Data) diff --git a/GenHyb/Logic_Hyb.hs b/GenHyb/Logic_Hyb.hs new file mode 100644 index 0000000000..652080203f --- /dev/null +++ b/GenHyb/Logic_Hyb.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{- | +Module : ./GenHyb/Logic_Hyb.hs +Description : Instances of Logic and other classes for the logic Framework +Copyright : (c) M. Codescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : experimental +Portability : portable + +-} + +module GenHyb.Logic_Hyb where + +import ATC.HDef () + +import Logic.Logic +-- import Logic.SemConstr +import Logic.HDef + +import Data.Monoid () + +import Common.DefaultMorphism + +type Morphism = DefaultMorphism HLogicDef + +-- lid for the dummy logic +data Hyb = Hyb deriving Show + +instance Language Hyb where + description _ = "Dummy logic for dynamic generation of hybridized logics." + +instance Semigroup HLogicDef where + _ <> _ = error "GenHyb.Logic_Hyb: Semigroup HLogicDef" + +instance Monoid HLogicDef where + mempty = error "GenHyb.Logic_Hyb: Monoid HLogicDef" + mappend _ _ = mempty + +-- syntax +instance Syntax Hyb HLogicDef () () () + +-- sentences +instance Sentences Hyb () HLogicDef Morphism () + +-- static analysis +instance StaticAnalysis Hyb HLogicDef () () () + HLogicDef Morphism () () where + empty_signature Hyb = error + "Logic Hyb does not have an empty signature." + +-- instance of logic for Hyb +instance Logic Hyb () HLogicDef () () () HLogicDef Morphism () () () diff --git a/GenHyb/WriteFile.hs b/GenHyb/WriteFile.hs new file mode 100644 index 0000000000..a6229958c5 --- /dev/null +++ b/GenHyb/WriteFile.hs @@ -0,0 +1,752 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances, ExistentialQuantification, DeriveDataTypeable #-} +{- | +Module : ./GenHyb/WriteFile +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable (imports Logic.Logic) + +Write the new Logic instance. +-} + +module GenHyb.WriteFile where + +import qualified Data.Map as Map + +import Logic.HDef +import Logic.Logic +import Logic.Comorphism + +import Logic.Grothendieck +import Logic.ExtSign + +import qualified GenHyb.Logic_Hyb as GLogic + +import System.Directory + +import Static.DevGraph +import Static.DgUtils +import Static.GTheory + +import Common.IRI +import Common.Result + +import qualified Framework.Analysis as FAna +import Framework.WriteLogicUtils + +import Data.List +-- import Debug.Trace +-- import Syntax.AS_Structured + +import qualified CASL.Logic_CASL as CLogic + +-- comorphism definition + +anaHComDef :: HComDef -> DGraph -> LogicGraph -> IO DGraph +anaHComDef hcd dg lg = do + let com = newHComName hcd + hLogic = sourceHLogic hcd + bcom = baseComName hcd + Result ds mcom = lookupComorphism bcom lg + case mcom of + Nothing -> + error $ "could not find base comorphism:" ++ + show bcom ++ + "\nOriginal error:" ++ show ds + Just bc -> do + let Result ds' maybeLid = lookupLogic "GenHyb.anaHComDef" hLogic lg + case maybeLid of + Nothing -> + error $ "could not find hybrid logic:" ++ + show hLogic ++ + "\nOriginal error:" ++ show ds' + Just hlid -> do + buildComorInstance lg bc hlid com + FAna.addComorphism2ComorphismList $ com + return dg + +buildComorInstance :: LogicGraph -> AnyComorphism -> + AnyLogic -> String -> IO () +buildComorInstance lg bc hlid com = do + writeFile ("Comorphisms/" ++ com ++ ".hs") $ + comDef lg bc hlid com + return () + +comDef :: LogicGraph -> AnyComorphism -> AnyLogic -> String -> String +comDef _lg (Comorphism baseCid) (Logic hLid) com = let + + hLogic = show hLid + bCom = show baseCid + header = mkCompOpt [multiOpt, synOpt, flexOpt] + mod_decl = mkModDecl $ "Comorphisms." ++ com + + hLogicPath = hLogic ++".Logic_" ++ hLogic -- import this for the lid + (hSublType, sublPath) = + if sublogicsTypeName hLid == ("","") + then ("()","") + else sublogicsTypeName hLid + (hBasicSpecType, basicSpecPath) = basicSpecTypeName hLid + (hSenType, senPath) = sentenceTypeName hLid + (hSiType, siPath) = symbItemsTypeName hLid + (hSmiType, smiPath) = + if symbMapItemsTypeName hLid == ("","") + then ("()","") + else symbMapItemsTypeName hLid + (hSignType, signPath) = signTypeName hLid + (hMorType, morPath) = morphismTypeName hLid + (hSymType, symPath) = symbolTypeName hLid + (hRSymType, rsymPath) = rawSymbolTypeName hLid + (hPtType, ptPath) = + if proofTreeTypeName hLid == ("","") + then ("()","") + else proofTreeTypeName hLid + import1 = + let importFiles = + filter (\x -> not $ null x ) $ + nub $ [hLogicPath, sublPath, basicSpecPath, + senPath, siPath, smiPath, signPath, morPath, + symPath, rsymPath, ptPath] + in if null importFiles + then error "empty imports, helpers for hybrid logic not set" + else mkImports importFiles + + (sublTypeCASL, sublPathCASL) = sublogicsTypeName CLogic.CASL + (basicSpecTypeCASL, basicSpecPathCASL) = basicSpecTypeName CLogic.CASL + (senTypeCASL, senPathCASL) = sentenceTypeName CLogic.CASL + (siTypeCASL, siPathCASL) = symbItemsTypeName CLogic.CASL + (smiTypeCASL, smiPathCASL) = symbMapItemsTypeName CLogic.CASL + (signTypeCASL, signPathCASL) = signTypeName CLogic.CASL + (morTypeCASL, morPathCASL) = morphismTypeName CLogic.CASL + (symTypeCASL, symPathCASL) = symbolTypeName CLogic.CASL + (rsymTypeCASL, rsymPathCASL) = rawSymbolTypeName CLogic.CASL + (ptTypeCASL, ptPathCASL) = proofTreeTypeName CLogic.CASL + import2 = + let importFiles = filter (\x -> not $ null x ) $ nub $ + [sublPathCASL, basicSpecPathCASL, + senPathCASL, siPathCASL, smiPathCASL, + signPathCASL, morPathCASL, + symPathCASL, rsymPathCASL, ptPathCASL] + in if null importFiles + then error "empty imports, helpers for CASL logic not set" + -- should never happen, they are set + else mkImports importFiles + imports = ["import Logic.Logic", + "import Logic.Comorphism", + "import qualified Data.Set as Set", + "import qualified Data.Map as Map", + "import Common.Result", + "import Common.AS_Annotation", + "import Common.Id", + "import qualified GenHyb.GenTypes as GTypes", + -- for methods only + "import qualified GenHyb.GenComor as GComor" + ] + + cPath = mkImports[com_path baseCid] + + mkCid = mkLid com + + -- comorphism + + genSourceLogic = mkImpl "sourceLogic" com hLogic + + genTargetLogic = mkImpl "targetLogic" com "CASL" + + genSourceSublogic = mkImpl "sourceSublogic" com $ + "top_sublogic " ++ hLogic + + genMapSublogic = mkImpl "mapSublogic" com + "const $ Just cFol { cons_features = emptyMapConsFeature }" + + genMapTheory = mkImpl "map_theory" com $ + "GComor.mapTheoryConstr " ++ bCom ++ " " ++ hLogic + + genModelExpansion = mkImpl "has_model_expansion" com "True" + + genLanguageName = mkImpl "language_name" com $ show com + + mkLangInst = mkInst "Language" com [] [genLanguageName] + + mkComInst = mkInst "Comorphism" com + [hLogic, hSublType, hBasicSpecType, hSenType, hSiType, + hSmiType, hSignType, hMorType, hSymType, hRSymType, + hPtType, + "CASL", sublTypeCASL, basicSpecTypeCASL, senTypeCASL, + siTypeCASL, smiTypeCASL, signTypeCASL, morTypeCASL, + symTypeCASL, rsymTypeCASL, ptTypeCASL] + [genSourceLogic, genSourceSublogic, genTargetLogic, + genMapSublogic, genMapTheory, genModelExpansion] + + body = intercalate "\n\n" $ + [mod_decl, import1, import2] ++ + imports ++ + [cPath, mkCid, mkLangInst, mkComInst] + in header ++ "\n" ++ body + +-- logic definition + +anaHLogicDef :: HLogicDef -> DGraph -> LogicGraph -> IO (DGraph, LogicGraph) +anaHLogicDef hld dg lg = do + let l = newHybridLogicName hld + (baseLogic, _msubl) = baseLogicName hld + hld' = if isExtension hld then + let baseHld = Map.findWithDefault + (error $ "Hybrid logic " + ++ baseLogic ++ " not found") + baseLogic $ knownHybLogics lg + in hld {baseLogicName = baseLogicName baseHld, + semConstrs = semConstrs hld ++ semConstrs baseHld, + varKinds = varKinds hld ++ varKinds baseHld} + else hld + hlds = "HLogicDef \"" ++ l ++ "\" " + ++ (show $ baseLogicName hld') ++ " " + ++ (show $ isExtension hld') ++ " " + ++ (show $ semConstrs hld') ++ " " + ++ (show $ varKinds hld') + -- trace ("hlds:" ++ hlds) $ + buildLogicInstance hld' lg + FAna.addLogic2LogicList l + FAna.addHLogic $ "(\"" ++ l ++ "\", " ++ hlds ++ ")" + let dg' = addHLogicDef2DG hld' dg + lg' = lg {knownHybLogics = Map.insert l hld' $ knownHybLogics lg} + (baseLogic', _) = baseLogicName hld' + -- because if the new logic was declared as an extension, + -- we want to add the comorphism from its base + FAna.addComorphism2ComorphismList $ baseLogic' ++ "2" ++ l + return (dg', lg') + + +-- creates a node for the logic definition +addHLogicDef2DG :: HLogicDef -> DGraph -> DGraph +addHLogicDef2DG hld dg = + let node = getNewNodeDG dg + name = newHybridLogicName hld + nodeName = emptyNodeName { getName = mkIRI name } + info = newNodeInfo DGBasic + extSign = makeExtSign GLogic.Hyb hld + gth = noSensGTheory GLogic.Hyb extSign startSigId + nodeLabel = newInfoNodeLab nodeName info gth + dg1 = insNodeDG (node, nodeLabel) dg + + emptyNode = EmptyNode $ Logic GLogic.Hyb + genSig = GenSig emptyNode [] emptyNode + nodeSig = NodeSig node $ G_sign GLogic.Hyb extSign startSigId + gEntry = SpecEntry $ ExtGenSig genSig nodeSig + dg2 = dg1 { globalEnv = Map.insert (mkIRI name) gEntry $ globalEnv dg1 } + in dg2 + +buildLogicInstance :: HLogicDef -> LogicGraph -> IO () +buildLogicInstance hld lg = do + let l = newHybridLogicName hld + (baseLogic, _msubl) = baseLogicName hld + exists <- doesDirectoryExist l + if exists then + error $ "The directory " ++ l ++ " already exists.\n" ++ + "Please choose a different object logic name." else do + createDirectory l + let typeDefs = writeTypes hld lg + logicInst = writeLogic hld lg + defaultImpDef = writeImplicitCom hld lg + writeFile (l ++ "/" ++ "AS_" ++ l ++ ".hs") typeDefs + writeFile ("Comorphisms/" ++ baseLogic ++ "2" ++ l ++ ".hs") defaultImpDef + writeFile (l ++ "/" ++ "Logic_" ++ l ++ ".hs") logicInst + return () + +writeImplicitCom :: HLogicDef -> LogicGraph -> String +writeImplicitCom hld lg = let + l = newHybridLogicName hld + (logic, _msubl) = baseLogicName hld + Result ds maybeLid = lookupLogic "GenHyb.writeLogic:" logic lg + cid = logic ++ "2" ++ l + in case maybeLid of + Nothing -> error $ "logic not found:" ++ show ds + Just (Logic baseLid) -> let + header = mkCompOpt [multiOpt, synOpt, flexOpt] + mod_decl = mkModDecl $ "Comorphisms." ++ cid + (sublType, sublPath) = + if sublogicsTypeName baseLid == ("","") + then ("()","") else sublogicsTypeName baseLid + (basicSpecType, basicSpecPath) = basicSpecTypeName baseLid + (senType, senPath) = sentenceTypeName baseLid + (siType, siPath) = symbItemsTypeName baseLid + (smiType, smiPath) = + if symbMapItemsTypeName baseLid == ("","") + then ("()","") else symbMapItemsTypeName baseLid + (signType, signPath) = signTypeName baseLid + (morType, morPath) = morphismTypeName baseLid + (symType, symPath) = symbolTypeName baseLid + (rsymType, rsymPath) = rawSymbolTypeName baseLid + (ptType, ptPath) = + if proofTreeTypeName baseLid == ("","") + then ("()","") else proofTreeTypeName baseLid + import1 = let importFiles = filter (\x -> not $ null x) $ + nub $ [sublPath, basicSpecPath, + senPath, siPath, smiPath, signPath, + morPath, symPath, rsymPath, ptPath] + in if null importFiles + then error "empty imports, " + ++ "helpers for base logic not set" + else mkImports importFiles + hSublType = "()" + hBasicSpecType = l ++ "_BASIC_SPEC" + hSenType = l ++ "_FORMULA" + hSiType = l ++ "_SYMB_ITEMS" + hSmiType = l ++ "_SYMB_MAP_ITEMS" + hSignType = l ++ "_Sign" + hMorType = l ++ "_Morphism" + hSymType = l ++ "_Symbol" + hRSymType = l ++ "_RawSymbol" + hPtType = "()" + imports = ["import Logic.Logic", + "import Logic.Comorphism", + "import qualified Data.Set as Set", + "import qualified Data.Map as Map", + "import Common.Result", + "import Common.AS_Annotation", + "import Common.Id", + "import qualified GenHyb.GenTypes as GTypes" + -- for methods only + ] + genImports = ["import " ++ l ++ "." ++ "Logic_" ++ l, + "import " ++ l ++ ".AS_" ++ l, + "import " ++ logic ++ "." ++ "Logic_" ++ logic] + mkCid = mkLid cid + lang = mkInst "Language" cid [] [] + + -- comorphism + + genSourceLogic = mkImpl "sourceLogic" cid logic + + genTargetLogic = mkImpl "targetLogic" cid l + + genSourceSublogic = mkImpl "sourceSublogic" cid $ + "top_sublogic " ++ logic + + genMapSublogic = mkImpl "mapSublogic" cid "const $ Just ()" + + genInclCom = mkImpl "isInclusionComorphism" cid "True" + + genMapTheory = mkImpl "map_theory" (cid ++ " (sig, nsens)") $ + "do\n"++ + " let tsig = GTypes.HSign sig " ++ + "(Set.singleton $ genName $ \"i_\" ++ (show " + ++ cid ++ ") ) Map.empty\n" ++ + " tsens = map ( \\nsen -> nsen{ sentence = " ++ + "GTypes.Base_formula (sentence nsen) nullRange} ) nsens\n" ++ + " return (tsig, tsens)" + + genMapSen = mkImpl "map_sentence" + (cid ++ " _ s") + "return $ GTypes.Base_formula s nullRange" + + + mkComInst = mkInst "Comorphism" cid + [logic, sublType, basicSpecType, senType, siType, + smiType, signType, morType, symType, + rsymType, ptType, + l, hSublType, hBasicSpecType, hSenType, hSiType, + hSmiType, hSignType, hMorType, hSymType, + hRSymType, hPtType] + [genSourceLogic, genSourceSublogic, genTargetLogic, + genMapSublogic, genMapTheory, genMapSen, genInclCom] + + body = intercalate "\n\n" $ + [mod_decl] ++ imports ++ genImports ++ + [import1, mkCid, lang, mkComInst] + in header ++ "\n" ++ body + + +writeTypes :: HLogicDef -> LogicGraph -> String +writeTypes hld lg = + let + l = newHybridLogicName hld + (logic, _msubl) = baseLogicName hld + Result ds maybeLid = lookupLogic "GenHyb.writeLogic:" logic lg + in case maybeLid of + Nothing -> error $ show ds + Just (Logic baseLid) -> + let + header = mkCompOpt [multiOpt, synOpt, flexOpt] + mod_decl = mkModDecl $ l ++ "." ++ "AS_" ++ l + gimports = [ "import qualified Data.Map as Map", + "import qualified GenHyb.GenTypes as GTypes" + ] ++ + ["import " ++ logic ++ "." ++ "Logic_" ++ logic] + (_sublType, sublPath) = sublogicsTypeName baseLid + (_basicSpecType, basicSpecPath) = basicSpecTypeName baseLid + (senType, senPath) = sentenceTypeName baseLid + (siType, siPath) = symbItemsTypeName baseLid + (smiType, smiPath) = symbMapItemsTypeName baseLid + (signType, signPath) = signTypeName baseLid + (morType, morPath) = morphismTypeName baseLid + (symType, symPath) = symbolTypeName baseLid + (rsymType, rsymPath) = rawSymbolTypeName baseLid + (_ptType, ptPath) = proofTreeTypeName baseLid + import1 = + let importFiles = filter (\x -> not $ null x) $ nub $ + [sublPath, basicSpecPath, + senPath, siPath, smiPath, signPath, morPath, + symPath, rsymPath, ptPath] + in if null importFiles + then error "empty imports, helpers for base logic not set" + else mkImports importFiles + -- drift = "--DrIFT command \n {-! global: GetRange !-}" + + --hSublType = "()" + -- H_BASIC_SPEC sen symb_items raw_sym + hBasicSpecType = "type " ++ l ++ "_BASIC_SPEC = GTypes.H_BASIC_SPEC " + ++ senType ++ " " ++ siType ++ " " ++ rsymType + -- HFORMULA sen symb_items raw_sym + hSenType = "type " ++ l ++ "_FORMULA = GTypes.HFORMULA " ++ senType + ++ " " ++ siType ++ " " ++ rsymType + -- H_SYMB_ITEMS sym symb_items + hSiType = "type " ++ l ++ "_SYMB_ITEMS = GTypes.H_SYMB_ITEMS " ++ + symType ++ " " ++ siType + -- H_SYMB_MAP_ITEMS symb_map_items + hSmiType = "type " ++ l ++ + "_SYMB_MAP_ITEMS = GTypes.H_SYMB_MAP_ITEMS " ++ smiType + -- HSign sig + hSignType = "type " ++ l ++ "_Sign = GTypes.HSign " ++ signType + -- HMorphism sig mor + hMorType = "type " ++ l ++ "_Morphism = GTypes.HMorphism " ++ + signType ++ " " ++ morType + -- HSymbol sym + hSymType = "type " ++ l ++ + "_Symbol = GTypes.HSymbol " ++ symType + -- HRawSymbol sym raw_sym + hRSymType = "type " ++ l ++ + "_RawSymbol = GTypes.HRawSymbol " ++ symType ++ + " " ++ rsymType + --hPtType = "()" + + body = intercalate "\n\n" $ + [mod_decl] ++ gimports ++ [import1, + hBasicSpecType, hSenType, hSiType, + hSmiType, hSignType, hMorType, + hSymType, hRSymType] + in header ++ "\n" ++ body + +writeLogic :: HLogicDef -> LogicGraph -> String +writeLogic hld lg = let + -- logic constituents + l = newHybridLogicName hld + (logic, msubl) = baseLogicName hld + Result ds maybeLid = lookupLogic "GenHyb.writeLogic:" logic lg + hasQNominals = ("nominal", Nothing) `elem` (varKinds hld) + kVars = filter (\x -> not (x == "nominal")) $ map fst $ varKinds hld + constrs = show $ semConstrs hld + in case maybeLid of + Nothing -> error $ show ds + Just (Logic baseLid) -> let + -- module declaration + header = mkCompOpt [multiOpt, synOpt, flexOpt] + mod_decl = mkModDecl $ l ++ "." ++ "Logic_" ++ l + + gimports = ["import Logic.Logic", + "import Logic.SemConstr", + "import qualified Data.Map as Map", + "import qualified GenHyb.GenTypes as GTypes", + "import qualified GenHyb.GenMethods as GMethods", + "import GenHyb.GenInsts ()" ] ++ + ["import " ++ logic ++ "." ++ "Logic_" ++ logic, + "import " ++ l ++ ".AS_" ++ l ] + + (_sublType, sublPath) = sublogicsTypeName baseLid + (_basicSpecType, basicSpecPath) = basicSpecTypeName baseLid + (_senType, senPath) = sentenceTypeName baseLid + (_siType, siPath) = symbItemsTypeName baseLid + (_smiType, smiPath) = symbMapItemsTypeName baseLid + (_signType, signPath) = signTypeName baseLid + (_morType, morPath) = morphismTypeName baseLid + (_symType, symPath) = symbolTypeName baseLid + (_rsymType, rsymPath) = rawSymbolTypeName baseLid + (_ptType, ptPath) = proofTreeTypeName baseLid + import1 = + let importFiles = filter (\x -> not $ null x) $ + nub $ [sublPath, basicSpecPath, + senPath, siPath, smiPath, + signPath, morPath, + symPath, rsymPath, ptPath] + in if null importFiles + then error "empty imports, helpers for base logic not set" + else mkImports importFiles + + -- inBracks s = "(" ++ s ++ ")" + + hSublType = "()" + -- H_BASIC_SPEC sen symb_items raw_sym + hBasicSpecType = l ++ "_BASIC_SPEC" + -- HFORMULA sen symb_items raw_sym + hSenType = l ++ "_FORMULA" + -- H_SYMB_ITEMS sym symb_items + hSiType = l ++ "_SYMB_ITEMS" + hSmiType = l ++ "_SYMB_MAP_ITEMS" + -- HSign sig + hSignType = l ++ "_Sign" + -- HMorphism sig mor + hMorType = l ++ "_Morphism" + -- HSymbol sym + hSymType = l ++ "_Symbol" + -- HRawSymbol sym raw_sym + hRSymType = l ++ "_RawSymbol" + hPtType = "()" + + -- lid + newLid = mkLid l + + -- language + descriptionI = mkImpl "description" l "\"User-defined hybrid logic.\"" + lang = mkInst "Language" l [] [descriptionI] + + -- category + + genDom = mkImpl "dom" "" "GTypes.source" + genCod = mkImpl "cod" "" "GTypes.target" + genIde = mkImpl "ide" "" "GMethods.idMor" + genIsIncl = mkImpl "isInclusion" "" "GMethods.isHIncl" + genCompMor = mkImpl "composeMorphisms" "" "GMethods.compHMor" + + category = mkInst "Category" "" [hSignType, hMorType] + [genDom, genCod, genIde, genIsIncl, genCompMor] + + -- syntax + + bspecParser = case data_logic baseLid of + Nothing -> "parseHBasicSpec" + _ -> "parseHHBasicSpec" + + genParseBasicSpec = mkImpl "parse_basic_spec" l $ + "Just $ GMethods." ++ bspecParser ++ " False " ++ + -- IMPORTANT: ^ toggle True and False for the two syntaxes + (if hasQNominals then "True " else "False ") ++ + (show $ not $ null kVars) ++ " " ++ logic + + genParseSymbItems = mkImpl "parse_symb_items" l $ + "GMethods.parseSymbItems " ++ logic + + genParseSymbMapItems = mkImpl "parse_symb_map_items" l $ + "GMethods.parseSymbMapItems " ++ logic + + genSymbItemsName = mkImpl "symb_items_name" l $ + "GMethods.hSymbItemsName " ++ logic + + syntax = mkInst "Syntax" l + [hBasicSpecType, hSymType, hSiType, hSmiType] + [genParseBasicSpec, genParseSymbItems, genParseSymbMapItems, + genSymbItemsName] + + -- sentences + + genMapSen = mkImpl "map_sen" l $ + "GMethods.mapSentence " ++ logic + + genSimplifySen = mkImpl "simplify_sen" l $ + "GMethods.simplifyHSen " ++ logic + + genNegation = mkImpl "negation" l "GMethods.hNegation" + + genSymOf = mkImpl "sym_of" l $ "GMethods.hSymOf " ++ logic + + genSymName = mkImpl "sym_name" l $ "GMethods.hSymName " ++ logic + + genSymKind = mkImpl "symKind" l $ "GMethods.symKindH " ++ logic + + genExtSymKind = mkImpl "extSymKind" l $ + "GMethods.extSymKindH " ++ logic + + genSymsOfSen = mkImpl "symsOfSen" l $ + "GMethods.symsOfHSen " ++ logic + + genMostSymsOf = mkImpl "mostSymsOf" l $ + "GMethods.mostSymsOfDiff " ++ logic + + genIsNominalSen = mkImpl "is_nominal_sen" l $ + "GMethods.isNominalSenH " ++ logic + + + sentences = mkInst "Sentences" l + [hSenType, hSignType, hMorType, hSymType] + [genMapSen, genSimplifySen, genNegation, + genSymOf, genSymName, genIsNominalSen, + genSymKind, genExtSymKind, genSymsOfSen, + genMostSymsOf] + + -- static + + genConvertTheory = mkImpl "convertTheory" l $ + "GMethods.convertHTheory " ++ logic + + anaF = case data_logic baseLid of + Nothing -> "basicHAnalysis" + _ -> "basicHHAnalysis" + + genBasicAnalysis = + mkImpl "basic_analysis" l $ + "Just $ GMethods." ++ anaF ++ + (if hasQNominals then " True " else " False ") ++ + (show kVars) ++ " " ++ logic + ++ " \"" ++ l ++ "\"" ++ + (case msubl of + Nothing -> + " Nothing" + Just sName -> + " (" ++ (show $ parseSublogic baseLid sName) ++ ")" + ) + + senAnaF = case data_logic baseLid of + Nothing -> "senAnalysis" + _ -> "senHAnalysis" + + genSenAnalysis = + mkImpl "sen_analysis" l $ + "GMethods." ++ senAnaF ++ + (if hasQNominals then " True " else " False ") ++ + (show kVars) ++ " " ++ logic ++ " \"" ++ l ++ "\"" + + genStatSymbMapItems = mkImpl "stat_symb_map_items" l $ + "GMethods.statSymbMapItems " ++ logic + + genStatSymbItems = mkImpl "stat_symb_items" l $ + "GMethods.hStatSymbItems " ++ logic + + genSigIntersection = mkImpl "intersection" l $ + "GMethods.sigIntersection " ++ logic + + genSigColimit = mkImpl "signature_colimit" l $ + "GMethods.signatureColimit " ++ logic + + genGeneratedSig = mkImpl "generated_sign" l + $ "GMethods.hGeneratedSign " ++ logic + + genCoGeneratedSig = mkImpl "cogenerated_sign" l + $ "GMethods.hCoGeneratedSign " ++ logic + + genSymbolToRaw = mkImpl "symbol_to_raw" l "GTypes.ASymbol" + + genRawToSymbol = mkImpl "raw_to_symbol" l $ + "GMethods.rawToSymbol " ++ logic + + genIdToRaw = mkImpl "id_to_raw" l $ + "GMethods.idToRaw " ++ logic + + genEmptySig = mkImpl "empty_signature" l $ + "GMethods.emptyHSign " ++ logic + + genAddSymbToSign = mkImpl "add_symb_to_sign" l $ + "GMethods.addSymbToHSign " ++ logic + + genSigDiff = mkImpl "signatureDiff" l $ + "GMethods.signatureDifference " ++ logic + + genIsSubsig = mkImpl "is_subsig" l $ + "GMethods.isSubsig " ++ logic + + genSubsigIncl = mkImpl "subsig_inclusion" l $ + "GMethods.subsigInclusion " ++ logic + + genSigUnion = mkImpl "signature_union" l $ + "GMethods.sigUnion " ++ logic + + genInducedFromMorphism = mkImpl "induced_from_morphism" l $ + "GMethods.inducedFromMorphism " ++ logic + + genInducedFromToMorphism = mkImpl "induced_from_to_morphism" l $ + "GMethods.inducedFromToMorphism " ++ logic + + static = mkInst "StaticAnalysis" l + [hBasicSpecType, hSenType, hSiType, hSmiType, + hSignType, hMorType, hSymType, hRSymType] + [genBasicAnalysis, genSenAnalysis, + genStatSymbItems, genStatSymbMapItems, + genSigIntersection, genSigColimit, + genGeneratedSig, genCoGeneratedSig, + genSymbolToRaw, genRawToSymbol, genIdToRaw, + genEmptySig, genAddSymbToSign, genSigUnion, genSigDiff, + genIsSubsig, genSubsigIncl, genConvertTheory, + genInducedFromMorphism, genInducedFromToMorphism] + + + -- logic + + genSemConstr = mkImpl "sem_constr" l + constrs + + genConstrToSens = mkImpl "constr_to_sens" (l ++ " sig _") $ + "GMethods.constrToSens " ++ logic ++ + " sig \"" ++ l ++ "\"" + + genData = mkImpl "data_logic" l $ "Just $ Logic " ++ logic + + genHybParams = let + qn = if hasQNominals then "True " else "False " + -- qKinds = + in mkImpl "hyb_params" l $ + "Just $ (" ++ qn ++ ", " ++ show kVars ++ ")" + + genParsePrimFormula = mkImpl "parse_prim_formula" l $ + "Just $ GMethods.hFormula False " ++ + -- IMPORTANT: ^ toggle True/False for the two syntaxes! + (if hasQNominals then "True " + else "False ") ++ + (show $ not $ null kVars) ++ " " ++ logic + + genParseQFormula = mkImpl "parse_q_formula" l $ + "Just $ GMethods.parseQFormula " ++ logic + + typeDefFile = l ++ ".AS_" ++ l + + genBasicSpecType = mkImpl "basicSpecTypeName" l $ + "(\"" ++ hBasicSpecType ++ + "\", \"" ++ typeDefFile ++ "\")" + + --genSublType = mkImpl "sublogicsTypeName" l $ + -- "(\"\", \"\")" -- default implementation is fine + + genSenType = mkImpl "sentenceTypeName" l $ + "(\"" ++ hSenType ++ "\", \"" + ++ typeDefFile ++ "\")" + genSymbItemsType = mkImpl "symbItemsTypeName" l $ + "(\"" ++ hSiType ++ "\", \"" + ++ typeDefFile ++ "\")" + + genSymbMapItemsType = mkImpl "symbMapItemsTypeName" l $ + "(\"" ++ hSmiType ++ "\", \"" + ++ typeDefFile ++ "\")" + + genSignType = mkImpl "signTypeName" l $ + "(\"" ++ hSignType ++ "\", \"" + ++ typeDefFile ++ "\")" + genMorType = mkImpl "morphismTypeName" l $ + "(\"" ++ hMorType ++ "\", \"" + ++ typeDefFile ++ "\")" + genSymType = mkImpl "symbolTypeName" l $ + "(\"" ++ hSymType ++ "\", \"" + ++ typeDefFile ++ "\")" + genRSymType = mkImpl "rawSymbolTypeName" l $ + "(\"" ++ hRSymType ++ "\", \"" + ++ typeDefFile ++ "\")" + + genEmptyProofTree = mkImpl "empty_proof_tree" l "()" + + + logicInst = mkInst "Logic" l + [hSublType, hBasicSpecType, hSenType, + hSiType, hSmiType, hSignType, hMorType, + hSymType, hRSymType, hPtType] + [genSemConstr, genConstrToSens, + genParsePrimFormula, genData, + genEmptyProofTree, genHybParams, genParseQFormula, + genBasicSpecType, genSenType, genSymbItemsType, + genSymbMapItemsType, genSignType, genMorType, + genSymType,genRSymType] + + + body = intercalate "\n\n" $ + [mod_decl] ++ gimports ++ + [import1, newLid, lang, category, + syntax, sentences, static, logicInst] + + in header ++ "\n" ++ body diff --git a/HPAR/AS_Basic_HPAR.der.hs b/HPAR/AS_Basic_HPAR.der.hs new file mode 100644 index 0000000000..17ce21b95d --- /dev/null +++ b/HPAR/AS_Basic_HPAR.der.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./HPAR/AS_Basic_HPAR.der.hs +Description : Abstract syntax for hybrid partial algebras +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : experimental +Portability : portable + +Definition of abstract syntax for hybrid partial algebras +-} + +module HPAR.AS_Basic_HPAR + ( HFORMULA (..) -- datatype for HPAR Formulas + , H_BASIC_ITEMS (..) -- Items of a Basic Spec + , H_BASIC_SPEC (..) -- Basic Spec + , H_SYMB_ITEMS (..) -- List of symbols + , H_SYMB_KIND (..) -- symbol kinds + , HQUANT (..) -- quantifiers + , NOM_ITEM (..) -- nominals + , MOD_ITEM (..) -- modalities + ) where + +import Common.Id as Id +import Common.Doc +import Common.DocUtils +import Common.AS_Annotation as AS_Anno + +import Data.Data +import qualified RigidCASL.AS_Rigid as PARBasic +import qualified CASL.AS_Basic_CASL as CASLBasic +import qualified CASL.ToDoc as CPrint +import RigidCASL.Print_AS () + +-- DrIFT command +{-! global: GetRange !-} + +-- | predicates = propositions +data NOM_ITEM = Nom_item [Id.Token] Id.Range + deriving (Show, Typeable, Data) + +-- | modalities with arities +data MOD_ITEM = Mod_item [Id.Token] Int Id.Range + deriving (Show, Typeable, Data) + +newtype H_BASIC_SPEC = Basic_spec [AS_Anno.Annoted H_BASIC_ITEMS] + deriving (Show, Typeable, Data) + +instance Semigroup H_BASIC_SPEC where + (Basic_spec l1) <> (Basic_spec l2) = Basic_spec $ l1 ++ l2 + +instance Monoid H_BASIC_SPEC where + mempty = Basic_spec [] + +data H_BASIC_ITEMS = + PAR_decl (CASLBasic.BASIC_ITEMS () PARBasic.R_SIG_ITEM ()) + | Nom_decl NOM_ITEM + | Mod_decl MOD_ITEM + | Axiom_items [AS_Anno.Annoted HFORMULA] + -- pos: dots + deriving (Show, Typeable, Data) + +-- | Datatype for hybrid propositional formulas +-- we need logical connectives between arbitrary hybrid formulas +-- so we need to cover these cases too +-- does this lead to parsing ambiguities? +-- no: we can always have connectives at the global level +-- and only predications are from the basic level +-- at parsing time! +-- maybe in the case of quantifications for FOL we can have trouble +-- no: we use forallH and existsH +data HFORMULA = + Base_formula CASLBasic.CASLFORMULA Id.Range + -- base sentences + | Negation HFORMULA Id.Range + -- pos: not + | Conjunction [HFORMULA] Id.Range + -- pos: "/\"s + | Disjunction [HFORMULA] Id.Range + -- pos: "\/"s + | Implication HFORMULA HFORMULA Id.Range + -- pos: "=>" + | Equivalence HFORMULA HFORMULA Id.Range + -- pos: "<=>" + | Nominal Bool Id.Token Id.Range -- the bool flag is true for nominal variables! + -- nominals as sentences + | AtState Id.Token HFORMULA Id.Range + -- at_i formulas + | BoxFormula Id.Token HFORMULA Id.Range + -- pos: "< >" + | DiamondFormula Id.Token HFORMULA Id.Range + -- pos: "[ ]" + | QuantRigidVars HQUANT [CASLBasic.VAR_DECL] HFORMULA Id.Range -- always use these, because we only have first-order variables + -- pos: QUANTIFIER, semi colons, dot + | QuantNominals HQUANT [Id.Token] HFORMULA Id.Range -- need to change this from Token to Token.Logic_name to allow layered hybridization + deriving (Show, Eq, Ord, Typeable, Data) + +data HQUANT = HUniversal | HExistential -- the quantifier must have a logic identifier, and if it's missing it defaults to the current logic + deriving (Show, Eq, Ord, Typeable, Data) + +data H_SYMB_KIND = BaseSymbol CASLBasic.SYMB_KIND + | NomKind | ModKind + deriving (Show, Eq, Ord, Typeable, Data) + +data H_SYMB_ITEMS = Symb_items H_SYMB_KIND [CASLBasic.SYMB] Id.Range + -- pos: SYMB_KIND, commas + deriving (Show, Eq, Ord, Typeable, Data) + +{- All about pretty printing +we chose the easy way here :) -} +instance Pretty HFORMULA where + pretty = printFormula +instance Pretty H_BASIC_SPEC where + pretty = printBasicSpec +instance Pretty H_SYMB_ITEMS where + pretty = printSymbItems +instance Pretty H_BASIC_ITEMS where + pretty = printBasicItems +instance Pretty NOM_ITEM where + pretty = printNomItem +instance Pretty MOD_ITEM where + pretty = printModItem + + +sepByArbitrary :: Doc -> [Doc] -> Doc -- move to Common.Doc +sepByArbitrary d = fsep . prepPunctuate (d <> space) + +forallH, existsH :: Doc +forallH = text "forallH" +existsH = text "existsH" + +-- Pretty printing for formulas +printFormula :: HFORMULA -> Doc +printFormula aFrm = + case aFrm of + Base_formula pfrm _ -> pretty pfrm -- we know that it must be an instance of pretty so we can call pretty instead of CPrint.printFormula pfrm + Nominal _ nom _ -> pretty nom + AtState nom frm _ -> prettyAt <+> pretty nom <+> colon <+> printFormula frm + BoxFormula md frm _ -> lbrack <+> pretty md <+> rbrack <+> printFormula frm + DiamondFormula md frm _ -> text "<" <+> pretty md <+> text ">" <+> printFormula frm + Negation frm _ -> notDoc <+> printFormula frm + Conjunction xs _ -> sepByArbitrary andDoc $ + map printFormula xs + Disjunction xs _ -> sepByArbitrary orDoc $ + map printFormula xs + Implication x y _ -> printFormula x <+> + implies <+> printFormula y + Equivalence x y _ -> printFormula x <+> + equiv <+> printFormula y + QuantRigidVars q vdecls frm _ -> printQuant q <+> CPrint.printVarDecls vdecls <+> bullet <+> printFormula frm + QuantNominals q noms frm _ -> printQuant q <+> keyword nomS <+> sepByCommas (map pretty noms) <+> bullet <+> printFormula frm + +printQuant :: HQUANT -> Doc +printQuant HUniversal = forallH +printQuant HExistential = existsH + +nomS, modS :: String +nomS = "nominal" +modS = "modality" + +printNomItem :: NOM_ITEM -> Doc +printNomItem (Nom_item xs _) = + keyword (nomS ++ case xs of + [_] -> "" + _ -> "s") <+> ppWithCommas xs + +printModItem :: MOD_ITEM -> Doc +printModItem (Mod_item xs i _) = undefined + keyword (modS ++ case xs of + [_] -> "" + _ -> "s") <+> ppWithCommas xs <+> colon <+> pretty i + + +printBasicSpec :: H_BASIC_SPEC -> Doc +printBasicSpec (Basic_spec xs) = vcat $ map pretty xs + +printBasicItems :: H_BASIC_ITEMS -> Doc +printBasicItems (Axiom_items xs) = vcat $ map (addBullet . pretty) xs +printBasicItems (PAR_decl x) = pretty x +printBasicItems (Nom_decl x) = pretty x +printBasicItems (Mod_decl x) = pretty x + + +printSymbItems :: H_SYMB_ITEMS -> Doc +printSymbItems (Symb_items _k xs _) = + fsep $ map pretty xs --TODO: improve + diff --git a/HPAR/Logic_HPAR.hs b/HPAR/Logic_HPAR.hs new file mode 100644 index 0000000000..4ef7fd4da7 --- /dev/null +++ b/HPAR/Logic_HPAR.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{- | +Module : ./HPAR/Logic_HPAR.hs +Description : Instance of class Logic for HPAR +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : experimental +Portability : portable + + +Instance of class Logic for HPAR. +-} + +module HPAR.Logic_HPAR where + +import Logic.Logic +import Logic.SemConstr +import HPAR.AS_Basic_HPAR +import HPAR.Sign +import HPAR.Morphism +import HPAR.ATC_HPAR () +import HPAR.Parse_AS +import HPAR.StaticAna + +import qualified HPAR.Symbol as HSym +import qualified Data.Map as Map + + +import qualified CASL.AS_Basic_CASL as CBasic +import qualified CASL.Sign as CSign () +import qualified CASL.Morphism as CMor +import HPAR.SimplifySen +import CASL.Logic_CASL () + +import qualified RigidCASL.Logic_RigidCASL as RLogic + +data HPAR = HPAR deriving Show + +instance Language HPAR where + description _ = "HPAR\n" ++ + "hybrid rigid partial algebras" + +instance Category HSign HMorphism where + ide = idMor + inverse = error "inverse nyi" + composeMorphisms = error "compose morphisms nyi" + dom = source + cod = target + isInclusion = isInclusionMor + legal_mor = error "legal mor nyi" + +instance Syntax HPAR H_BASIC_SPEC HSym.HSymbol H_SYMB_ITEMS CBasic.SYMB_MAP_ITEMS where + -- parsersAndPrinters HPAR = makeDefault (basicSpec, pretty) TODO: default implementation is fine + parse_basic_spec HPAR = Just $ basicSpec + parse_symb_items HPAR = error "parse symb items nyi" -- Just $ symbItems [rigidS] + parse_symb_map_items HPAR = error "parse symb map items nyi" -- Just $ symbMapItems hybrid_reserved_words + +instance Sentences HPAR HFORMULA HSign HMorphism HSym.HSymbol where + map_sen HPAR = error "map_sen nyi" -- return . mapSen map_H_FORMULA h + sym_of HPAR = HSym.symOf -- TODO:this loses modalities and nominals!!! + symmap_of HPAR hmor = Map.mapKeys (\x -> HSym.BSymbol x) $ Map.map (\x -> HSym.BSymbol x) $ CMor.morphismToSymbMap $ baseMor hmor -- TODO: this loses modalities and nominals + sym_name HPAR = HSym.symName + simplify_sen HPAR = simplifyHPARSen + --print_sign HPAR = pretty + --print_named HPAR = error "nyi" --printTheoryFormula + +instance StaticAnalysis HPAR H_BASIC_SPEC HFORMULA + H_SYMB_ITEMS CBasic.SYMB_MAP_ITEMS + HSign + HMorphism + HSym.HSymbol CMor.RawSymbol where + basic_analysis HPAR = Just $ basicAnalysis + stat_symb_map_items HPAR = error "sym_name nyi" --statSymbMapItems + stat_symb_items HPAR = error "sym_name nyi" --statSymbItems + symbol_to_raw HPAR = error "sym_name nyi" -- symbolToRaw + id_to_raw HPAR = error "sym_name nyi" --idToRaw + matches HPAR = error "nyi" --CASL.Morphism.matches + empty_signature HPAR = emptySig + signature_union HPAR = error "sig union nyi" --return . addSig addRigidExt s + intersection HPAR = error "nyi" --return . interSig interRigidExt s + morphism_union HPAR = error "nyi" --plainMorphismUnion (addSig addRigidExt) + final_union HPAR = error "nyi" --finalUnion (addSig addRigidExt) + is_subsig HPAR = isSubSigOf + subsig_inclusion HPAR s1 s2 = return $ inclusionMap s1 s2 + cogenerated_sign HPAR = error "nyi" --cogeneratedSign emptyMorExt + generated_sign HPAR = error "nyi" -- generatedSign emptyMorExt + induced_from_morphism HPAR = error "nyi" -- inducedFromMorphism emptyMorExt + induced_from_to_morphism HPAR = error "nyi" --inducedFromToMorphism + -- emptyMorExt isSubRigidExt diffRigidExt + theory_to_taxonomy HPAR = error "nyi" --convTaxo + +instance Logic HPAR () + H_BASIC_SPEC HFORMULA H_SYMB_ITEMS CBasic.SYMB_MAP_ITEMS + HSign + HMorphism + HSym.HSymbol CMor.RawSymbol () where + stability _ = Experimental + empty_proof_tree _ = () + sem_constr _ = [ SameInterpretation "rigid sort" + , SameInterpretation "rigid op" + , SameDomain True] + data_logic _ = Just $ Logic RLogic.RigidCASL + diff --git a/HPAR/Morphism.hs b/HPAR/Morphism.hs new file mode 100644 index 0000000000..7c4d3238e8 --- /dev/null +++ b/HPAR/Morphism.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./HPAR/Morphism.hs +Description : Morphisms in HPAR +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.cm +Stability : experimental +Portability : portable + + Definition of morphisms for HPAR + +-} + +module HPAR.Morphism + ( HMorphism (..) -- datatype for Morphisms + , pretty -- pretty printing + , idMor -- identity morphism + --, isLegalMorphism -- check if morhpism is ok + , composeMor -- composition + , inclusionMap -- inclusion map + , isInclusionMor + --, mapSentence -- map of sentences + --, mapSentenceH -- map of sentences, without Result type + --, applyMap -- application function for maps + --, applyMorphismProp + --, applyMorphismNom + --, morphismUnion + ) where + +import Data.Data +import qualified Data.Map as Map + +import qualified RigidCASL.Sign as PARSign +import HPAR.Sign as Sign +import qualified CASL.Morphism as CASL_Mor + +import Common.Id as Id +import Common.Result +import Common.Doc +import Common.DocUtils + +{- | The datatype for morphisms in propositional logic as +maps of sets -} +data HMorphism = HMorphism + { source :: HSign + , target :: HSign + , baseMor :: CASL_Mor.Morphism () () () -- TODO:this should be a morphism in RigidCASL!!! + , nomMap :: Map.Map Id Id + , modMap :: Map.Map Id Id + } deriving (Show, Eq, Ord, Typeable, Data) + +instance Pretty HMorphism where + pretty = printMorphism + +isInclusionMor :: HMorphism -> Bool +isInclusionMor hmor = CASL_Mor.isInclusionMorphism (const True) $ baseMor hmor + -- the const might have to change if baseMor also changes + + +-- | Constructs an id-morphism +idMor :: HSign -> HMorphism +idMor a = HMorphism{ + source = a, + target = a, + baseMor = CASL_Mor.embedMorphism () (PARSign.caslSign $ baseSig a) (PARSign.caslSign $ baseSig a), + nomMap = Map.empty, + modMap = Map.empty + } + +{- +-- | Determines whether a morphism is valid +isLegalMorphism :: HMorphism -> Result () +isLegalMorphism pmor = + let psource = PSign.items $ propSig $ source pmor + nsource = noms $ source pmor + ptarget = PSign.items $ propSig $ target pmor + ntarget = noms $ target pmor + pdom = Map.keysSet $ propMap pmor + pcodom = Set.map (applyMorphismProp pmor) psource + ndom = Map.keysSet $ nomMap pmor + ncodom = Set.map (applyMorphismNom pmor) nsource + in unless (Set.isSubsetOf pcodom ptarget && Set.isSubsetOf pdom psource + &&Set.isSubsetOf ncodom ntarget && Set.isSubsetOf ndom nsource) $ + fail "illegal hybrid propositional morphism" +-} + +{- + +-- | Application funtion for props +applyMorphismProp :: HMorphism -> Id -> Id +applyMorphismProp mor = PMorphism.applyMap $ propMap mor + +-- | Application funtion for noms +applyMorphismNom :: HMorphism -> Id -> Id +applyMorphismNom mor = PMorphism.applyMap $ nomMap mor + +-- | Application funtion for noms +applyMorphismNom :: HMorphism -> Id -> Id +applyMorphismNom mor = PMorphism.applyMap $ nomMap mor + +-} + +-- | Composition of morphisms in propositional Logic +composeMor :: HMorphism -> HMorphism -> Result HMorphism +composeMor _ _ = error "composeMor nyi"{- + let fSource = source f + gTarget = target g + fpMap = propMap f + gpMap = propMap g + fnMap = nomMap f + gnMap = nomMap g + in return HMorphism -- TODO: this always works???? + { source = fSource + , target = gTarget + , propMap = if Map.null gpMap then fpMap else + Set.fold ( \ i -> let j = applyMorphismProp g (applyMorphismProp f i) in + if i == j then id else Map.insert i j) + Map.empty $ PSign.items $ propSig fSource + , nomMap = if Map.null gnMap then fnMap else + Set.fold ( \ i -> let j = applyMorphismNom g (applyMorphismNom f i) in + if i == j then id else Map.insert i j) + Map.empty $ noms fSource + } +-} + +-- | Pretty printing for Morphisms +printMorphism :: HMorphism -> Doc +printMorphism _ = error "printMorphism nyi" + {-pretty (source m) <> text "-->" <> pretty (target m) + <> vcat (map ( \ (x, y) -> lparen <> pretty x <> text "," + <> pretty y <> rparen) $ Map.assocs $ propMap m) + <> vcat (map ( \ (x, y) -> lparen <> pretty x <> text "," + <> pretty y <> rparen) $ Map.assocs $ nomMap m) +-} + +-- | Inclusion map of a subsig into a supersig +inclusionMap :: HSign -> HSign -> HMorphism +inclusionMap s1 s2 = HMorphism + { source = s1 + , target = s2 + , baseMor = CASL_Mor.embedMorphism () (PARSign.caslSign $ baseSig s1) (PARSign.caslSign $ baseSig s2) + --CASL_Mor.sigInclusion CASL_Mor.emptyMorExt (baseSig s1) $ baseSig s2 -- undefined -- should be inclusion between the base sigs + , nomMap = Map.empty + , modMap = Map.empty } + + +{- | sentence translation along signature morphism +here just the renaming of formulae ----------------------- TODO +mapSentence :: Morphism -> AS_BASIC.FORMULA -> Result.Result AS_BASIC.FORMULA +mapSentence mor = return . mapSentenceH mor + +mapSentenceH :: Morphism -> AS_BASIC.FORMULA -> AS_BASIC.FORMULA +mapSentenceH mor frm = case frm of + AS_BASIC.Negation form rn -> AS_BASIC.Negation (mapSentenceH mor form) rn + AS_BASIC.Conjunction form rn -> + AS_BASIC.Conjunction (map (mapSentenceH mor) form) rn + AS_BASIC.Disjunction form rn -> + AS_BASIC.Disjunction (map (mapSentenceH mor) form) rn + AS_BASIC.Implication form1 form2 rn -> AS_BASIC.Implication + (mapSentenceH mor form1) (mapSentenceH mor form2) rn + AS_BASIC.Equivalence form1 form2 rn -> AS_BASIC.Equivalence + (mapSentenceH mor form1) (mapSentenceH mor form2) rn + AS_BASIC.True_atom rn -> AS_BASIC.True_atom rn + AS_BASIC.False_atom rn -> AS_BASIC.False_atom rn + AS_BASIC.Predication predH -> AS_BASIC.Predication + $ id2SimpleId $ applyMorphism mor $ Id.simpleIdToId predH +-} + +{- TODO +morphismUnion :: HMorphism -> HMorphism -> Result.Result HMorphism +morphismUnion mor1 mor2 = + let pmap1 = propMap mor1 + pmap2 = propMap mor2 + nmap1 = nomMap mor1 + nmap2 = nomMap mor2 + p1 = source mor1 + p2 = source mor2 + up1 = Set.difference (items p1) $ Map.keysSet pmap1 + up2 = Set.difference (items p2) $ Map.keysSet pmap2 + (pds, pmap) = foldr ( \ (i, j) (ds, m) -> case Map.lookup i m of + Nothing -> (ds, Map.insert i j m) + Just k -> if j == k then (ds, m) else + (Diag Error + ("incompatible mapping of prop " ++ showId i " to " + ++ showId j " and " ++ showId k "") + nullRange : ds, m)) ([], pmap1) + (Map.toList pmap2 ++ map (\ a -> (a, a)) + (Set.toList $ Set.union up1 up2)) + in if null pds then return Morphism + { source = unite p1 p2 + , target = unite (target mor1) $ target mor2 + , propMap = pmap } else Result pds Nothing +-} + + + diff --git a/HPAR/Parse_AS.hs b/HPAR/Parse_AS.hs new file mode 100644 index 0000000000..0d40f69de6 --- /dev/null +++ b/HPAR/Parse_AS.hs @@ -0,0 +1,203 @@ +{- | +Module : ./HPAR/Parse_AS.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +Parser for HPAR +-} + +module HPAR.Parse_AS where + +--import CASL.Formula +import qualified CASL.Parse_AS_Basic as CParse +import qualified CASL.Formula as CFormula + + +import Common.Parsec +import Common.AS_Annotation +import Common.AnnoState +import Common.Id +import Common.Keywords +import Common.Lexer +import Common.Token +import Common.GlobalAnnotations +--import qualified RigidCASL.AS_Rigid as PAR_AS +import RigidCASL.Parse_AS () +import Text.ParserCombinators.Parsec + +import qualified HPAR.AS_Basic_HPAR as HPAR_AS + +-- | Toplevel parser for basic specs +basicSpec :: PrefixMap -> AParser st HPAR_AS.H_BASIC_SPEC +basicSpec _ks = + fmap HPAR_AS.Basic_spec (annosParser parseBasicItems) + -- should be the method for H_BASIC_ITEMS + <|> (oBraceT >> cBraceT >> return (HPAR_AS.Basic_spec [])) + + +parseBasicItems :: AParser st HPAR_AS.H_BASIC_ITEMS -- TODO: take into account ks +parseBasicItems = + parseAxItems -- if this is not first, the parser for basic items consumes more than it should + <|> + do (as, ps) <- keyThenList nomP simpleId + return $ HPAR_AS.Nom_decl $ HPAR_AS.Nom_item as ps + <|> + do (as, ps) <- keyThenList modP simpleId + _c <- colonT + ni <- getNumber + let i = read ni :: Int + return $ HPAR_AS.Mod_decl $ HPAR_AS.Mod_item as i ps + <|> + do x <- CParse.basicItems hybrid_keywords + return $ HPAR_AS.PAR_decl x + + +modP :: AParser st Token +modP = asKey modalityS <|> asKey modalitiesS + +nomP :: AParser st Token +nomP = asKey nominalS <|> asKey nominalsS + +keyThenList :: AParser st Token -> AParser st a -> + AParser st ([a], Range) +keyThenList k p = do + c <- k + (as, cs) <- separatedBy p anComma + let ps = catRange $ c : cs + return (as, ps) + +-- | Toplevel parser for formulae +aFormula :: AParser st (Annoted HPAR_AS.HFORMULA) +aFormula = allAnnoParser topformula + +parseAxItems :: AParser st HPAR_AS.H_BASIC_ITEMS +parseAxItems = do + d <- dotT + (fs, ds) <- aFormula `separatedBy` dotT + (_, an) <- optSemi + let _ = catRange (d : ds) + ns = init fs ++ [appendAnno (last fs) an] + return $ HPAR_AS.Axiom_items ns + + + +parenFormula :: AParser st HPAR_AS.HFORMULA +parenFormula = do + oParenT << addAnnos + f <- topformula << addAnnos + cParenT >> return f + +-- | Parser for at +atKey :: AParser st Token +atKey = asKey asP + +-- | Any word to token +propId :: [String] -> GenParser Char st Token +propId k = pToken $ reserved (k ++ hybrid_keywords) scanAnyWords + +hFormula :: AParser st HPAR_AS.HFORMULA +hFormula = + do + c <- atKey + n <- simpleId + _ <- colonT + f <- topformula -- here should be formula without @? + return $ HPAR_AS.AtState n f $ tokPos c + <|> + do + c <- asKey notS <|> asKey negS "\"not\"" + f <- hFormula --topformula + return $ HPAR_AS.Negation f $ tokPos c + <|> + do + c1 <- asKey lessS + md <- propId [greaterS] + c2 <- asKey greaterS + f <- topformula + return $ HPAR_AS.DiamondFormula md f $ toRange c1 [] c2 + <|> + do + c1 <- oBracketT + md <- propId ["]"] + c2 <- cBracketT + f <- topformula + return $ HPAR_AS.BoxFormula md f $ toRange c1 [] c2 + <|> + parenFormula + <|> + do + (q, p) <- quant + parseQFormula (q, p) + <|> + do + f <- CFormula.primFormula hybrid_keywords + return $ HPAR_AS.Base_formula f nullRange + -- this should also catch nominals as terms. + -- We have to make sure during static analysis that this is reverted! + + +parseQFormula :: (HPAR_AS.HQUANT, Token) -> AParser st HPAR_AS.HFORMULA +parseQFormula (q, p) = + do -- first try quantification on nominals, or the parser will complain + (vs, _ps) <- keyThenList nomP simpleId + _d <- dotT -- TODO: range + f <- topformula + return $ HPAR_AS.QuantNominals q vs f nullRange + <|> + do + (vs, ps) <- CFormula.varDecls [] + d <- dotT + f <- topformula + return $ HPAR_AS.QuantRigidVars q vs f $ toRange p ps d + +andOrFormula :: AParser st HPAR_AS.HFORMULA +andOrFormula = hFormula >>= optAndOr + +optAndOr :: HPAR_AS.HFORMULA -> AParser st HPAR_AS.HFORMULA +optAndOr f = do + c <- CFormula.andKey + (fs, ps) <- hFormula `separatedBy` CFormula.andKey + return $ HPAR_AS.Conjunction (f : fs) $ catRange $ c : ps + <|> do + c <- CFormula.orKey + (fs, ps) <- hFormula `separatedBy` CFormula.orKey + return $ HPAR_AS.Disjunction (f : fs) $ catRange $ c : ps + <|> return f + +topformula :: AParser st HPAR_AS.HFORMULA +topformula = andOrFormula >>= optImplForm + +optImplForm :: HPAR_AS.HFORMULA -> AParser st HPAR_AS.HFORMULA +optImplForm f = do + _c <- CFormula.implKey + (fs, _ps) <- andOrFormula `separatedBy` CFormula.implKey --TODO: range? + return $ makeImpl (f : fs) + <|> do + c <- asKey equivS + g <- andOrFormula + return $ HPAR_AS.Equivalence f g $ tokPos c + <|> return f + +makeImpl :: [HPAR_AS.HFORMULA] -> HPAR_AS.HFORMULA +makeImpl l = + case l of + [f1, f2] -> HPAR_AS.Implication f1 f2 nullRange + f1 : fs -> HPAR_AS.Implication f1 (makeImpl fs) nullRange + _ -> error "Illegal argument for makeImpl in parsing of hybrid formulas" + +instance TermParser HPAR_AS.HFORMULA where + termParser = aToTermParser hFormula + +quant :: AParser st (HPAR_AS.HQUANT, Token) +quant = choice (map (\ (q, s) -> do + t <- asKey s + return (q, t)) + [ (HPAR_AS.HExistential, hExistsS) + , (HPAR_AS.HUniversal, hForallS) ]) + "quantifier" + + diff --git a/HPAR/Print_AS.hs b/HPAR/Print_AS.hs new file mode 100644 index 0000000000..3a8c199d3c --- /dev/null +++ b/HPAR/Print_AS.hs @@ -0,0 +1,17 @@ + +{- | +Module : ./HPAR/Print_AS.hs +Copyright : (c)R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +printing rigid declarations +-} + +module HPAR.Print_AS where + + + diff --git a/HPAR/Sign.hs b/HPAR/Sign.hs new file mode 100644 index 0000000000..f9e20d7847 --- /dev/null +++ b/HPAR/Sign.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./HPAR/Sign.hs +Description : Signature for hybrid partial algebras +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : experimental +Portability : portable + + Definition of signatures for hybrid partial algebras + + +-} + +module HPAR.Sign + (HSign (..) -- signatures + --, id2SimpleId + , pretty -- pretty printing + , isLegalSignature -- is a signature ok? + --, addPropToSig + , addNomToSig + , addModToSig + --, unite -- union of signatures + , emptySig -- empty signature + , isSubSigOf -- is subsignature? + , sigDiff -- Difference of Signatures + , sigUnion -- Union for Logic.Logic + , symOf -- symbols of a signature + ) where + +import Data.Data +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Common.Lib.Rel as Rel + +import Common.Id +import Common.Result +import Common.Doc +import Common.DocUtils + +import qualified RigidCASL.Sign as PARSign +import RigidCASL.Print_AS () +import qualified CASL.Sign as CSign + +import Logic.Logic +import qualified RigidCASL.Logic_RigidCASL as Base + +{- | Datatype for hybrid propositional Signatures +Signatures consist of a propositional signature and a set of nominals. +-} +data HSign = HSign { + baseSig :: PARSign.RSign, + noms :: Set.Set Id, + mods :: Map.Map Id Int} + deriving (Show, Eq, Ord, Typeable, Data) + +instance Pretty HSign where + pretty = printSign + +{- | determines whether a signature is vaild +a signature is not legal when the same name is used for +both a nominal and a proposition-} +isLegalSignature :: HSign -> Bool +isLegalSignature sig = let + -- propSet = PSign.items $ propSig sig + nomsSet = noms sig + modsSet = Map.keysSet $ mods sig + in -- Set.intersection propSet nomsSet == Set.empty && + Set.intersection nomsSet modsSet == Set.empty + -- TODO: improve - noms and mods must be disjoint with the signature too + +-- | pretty printing for signatures +printSign :: HSign -> Doc +printSign s = + let bsig = baseSig s in + pretty (bsig {CSign.sortRel = Rel.difference (Rel.transReduce $ CSign.sortRel bsig) + . Rel.transReduce $ Rel.fromSet $ Set.map (\x->(x,x)) $ PARSign.rigidSorts $ CSign.extendedInfo bsig, + CSign.opMap = CSign.diffOpMapSet (CSign.opMap bsig) $ PARSign.rigidOps $ CSign.extendedInfo bsig, + CSign.predMap = CSign.diffMapSet (CSign.predMap bsig) $ PARSign.rigidPreds $ CSign.extendedInfo bsig}) + -- this ensures that the rigid symbols are not displayed as non-rigid + $+$ + let nomss = Set.toList $ noms s in + case nomss of + [] -> empty + _ -> hsep [text ("nominal" ++ (case nomss of + [_] -> "" + _ -> "s")), sepByCommas $ map pretty nomss] + $+$ + (foldl (\aDoc (i,n) -> aDoc $+$ + hsep [text ( case Map.toList $ mods s of + [_] -> "modality" + _ -> "modalities" + ), + pretty i, + text ":", + pretty n]) empty $ Map.toList $ mods s) + -- hsep [text "modality", sepByCommas $ map pretty $ Set.toList $ noms s] + + +-- | Adds a nominal to the signature +addNomToSig :: HSign -> Id -> Result HSign +addNomToSig sig nom = + let + snoms = noms sig + in if Set.member nom snoms then Result [mkDiag Warning "redeclaring nominal" nom] $ Just sig + else return sig {noms = Set.insert nom snoms} + +-- | Adds a modality to the signature +addModToSig :: HSign -> Id -> Int -> Result HSign +addModToSig sig md ar = + let + smods = mods sig + in if Map.member md smods then Result [mkDiag Warning "redeclaring modality" md] $ Just sig + else return sig {mods = Map.insert md ar smods} + +-- | The empty signature +emptySig :: HSign +emptySig = HSign { + baseSig = CSign.emptySign PARSign.emptyRigidExt, + noms = Set.empty, + mods = Map.empty} + +-- | Determines if sig1 is subsignature of sig2 +isSubSigOf :: HSign -> HSign -> Bool +isSubSigOf sig1 sig2 = + (is_subsig (Base.RigidCASL) (baseSig sig1) $ baseSig sig2) + --(CSign.isSubSig PARSign.isSubRigidExt (baseSig sig1) $ baseSig sig2) + && + (Set.isSubsetOf (noms sig1) $ noms sig2) + && + (Set.isSubsetOf (modSet sig1) $ modSet sig2) + where + modSet sig = Set.fromList $ Map.toList $ mods sig + +-- | difference of Signatures +sigDiff :: HSign -> HSign -> HSign +sigDiff _sig1 _sig2 = undefined + --HSign { + -- propSig = PSign.sigDiff (propSig sig1) $ propSig sig2, + -- noms = Set.difference (noms sig1) $ noms sig2} + +-- | union of Signatures +sigUnion :: HSign -> HSign -> Result HSign +sigUnion = undefined + +symOf :: HSign -> Set.Set CSign.Symbol +symOf _sig = undefined diff --git a/HPAR/SimplifySen.hs b/HPAR/SimplifySen.hs new file mode 100644 index 0000000000..653f33b1b4 --- /dev/null +++ b/HPAR/SimplifySen.hs @@ -0,0 +1,54 @@ +{- | +Module : ./HPAR/SimplifySen.hs +Description : simplification of formulas and terms for output after analysis +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +Simplification of formulas and terms for output after analysis + +-} + +module HPAR.SimplifySen where + +import CASL.SimplifySen +import Common.Lib.State + +import qualified CASL.Sign as CSign +import qualified HPAR.Sign as HSign +import qualified RigidCASL.Sign as RSign +import qualified HPAR.AS_Basic_HPAR as HBasic + +simplifyHPARSen :: HSign.HSign -> HBasic.HFORMULA -> HBasic.HFORMULA +simplifyHPARSen hsig hsen = + case hsen of + HBasic.Base_formula pfrm r -> + let pfrm' = simplifyCASLSen (RSign.caslSign $ HSign.baseSig hsig) pfrm + in HBasic.Base_formula pfrm' r + HBasic.Nominal _ _ _ -> + hsen + HBasic.AtState nom frm r -> + HBasic.AtState nom (simplifyHPARSen hsig frm) r + HBasic.BoxFormula md frm r -> + HBasic.BoxFormula md (simplifyHPARSen hsig frm) r + HBasic.DiamondFormula md frm r -> + HBasic.DiamondFormula md (simplifyHPARSen hsig frm) r + HBasic.Negation frm r -> + HBasic.Negation (simplifyHPARSen hsig frm) r + HBasic.Conjunction xs r -> + HBasic.Conjunction (map (simplifyHPARSen hsig) xs) r + HBasic.Disjunction xs r -> + HBasic.Disjunction (map (simplifyHPARSen hsig) xs) r + HBasic.Implication x y r -> + HBasic.Implication (simplifyHPARSen hsig x) (simplifyHPARSen hsig y) r + HBasic.Equivalence x y r -> + HBasic.Equivalence (simplifyHPARSen hsig x) (simplifyHPARSen hsig y) r + HBasic.QuantRigidVars q vdecls frm r -> + let csig = execState (mapM_ CSign.addVars vdecls) $ HSign.baseSig hsig + hsig' = hsig{HSign.baseSig = csig} + in HBasic.QuantRigidVars q vdecls (simplifyHPARSen hsig' frm) r + HBasic.QuantNominals q noms frm r -> + HBasic.QuantNominals q noms (simplifyHPARSen hsig frm) r diff --git a/HPAR/StaticAna.hs b/HPAR/StaticAna.hs new file mode 100644 index 0000000000..419e123484 --- /dev/null +++ b/HPAR/StaticAna.hs @@ -0,0 +1,222 @@ +{- | +Module : ./HPAR/StaticAna.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +static analysis of hybrid partial algebras +-} + +module HPAR.StaticAna where + +import qualified HPAR.AS_Basic_HPAR as HBasic +import HPAR.Print_AS () +import qualified HPAR.Sign as HSign + +import qualified RigidCASL.StaticAna as RAna +import qualified RigidCASL.Sign as RSign + +import qualified CASL.Sign as CSign +import CASL.MixfixParser +import qualified CASL.StaticAna as CAna +import CASL.AS_Basic_CASL + +import Common.AS_Annotation +import Common.GlobalAnnotations +import Common.Lib.State +import Common.Id +import Common.Result +import Common.ExtSign +import Control.Monad (foldM) + +import qualified HPAR.Symbol as HSym + +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- in addition to what CASL static analysis does +-- must check that all modalities and nominals that appear in formulas have been declared + + +data HTheoryAna = HTheoryAna { + hSign :: HSign.HSign, + declSyms :: Set.Set CSign.Symbol, + hSens :: [Named HBasic.HFORMULA], + hVars :: Map.Map SIMPLE_ID SORT, + anaDiags :: [Diagnosis] + } + deriving Show + +basicAnalysis :: (HBasic.H_BASIC_SPEC, HSign.HSign, GlobalAnnos) + -> Result (HBasic.H_BASIC_SPEC, ExtSign HSign.HSign HSym.HSymbol, [Named HBasic.HFORMULA]) +basicAnalysis (bs, inSig, ga) = + let bSig' = let bSig = HSign.baseSig inSig + in bSig {CSign.globAnnos = CAna.addAssocs bSig ga } + inSig' = inSig {HSign.baseSig = bSig'} + hth = HTheoryAna inSig' Set.empty [] Map.empty [] + (newBs, accTh) = runState (anaBasicSpec bs) hth + ds = reverse $ anaDiags accTh + outSig = hSign accTh + sents = hSens accTh + in Result ds $ Just (newBs, ExtSign outSig (Set.map (\x -> HSym.BSymbol x) $ declSyms accTh), sents) + +anaBasicSpec :: HBasic.H_BASIC_SPEC -> State HTheoryAna HBasic.H_BASIC_SPEC +anaBasicSpec (HBasic.Basic_spec al) = fmap HBasic.Basic_spec $ + mapAnM anaBasicItems al + +anaBasicItems :: HBasic.H_BASIC_ITEMS -> State HTheoryAna HBasic.H_BASIC_ITEMS +anaBasicItems bi = + case bi of + HBasic.PAR_decl pbi -> do + hth <- get + let hsign = hSign hth + csign = HSign.baseSig hsign + (pbi', asig) = runState (CAna.ana_BASIC_ITEMS RAna.typeAnaF + RAna.anaRBasicItem RAna.anaRSigItem + RAna.anaMix pbi) csign + hsign' = hsign {HSign.baseSig = asig} + put $ hth { hSign = hsign', anaDiags = CSign.envDiags asig ++ anaDiags hth} + return $ HBasic.PAR_decl pbi' + HBasic.Nom_decl (HBasic.Nom_item noms _) -> do + hth <- get + let hsign = hSign hth + let Result ds mhsign' = foldM (\s n -> HSign.addNomToSig s $ mkId [n]) hsign noms + case mhsign' of + Nothing -> error $ "cannot add nominals" ++ show ds + Just hsign' -> do + put $ hth {hSign = hsign', anaDiags = ds ++ anaDiags hth} + return bi + HBasic.Mod_decl (HBasic.Mod_item mods i _) -> do + hth <- get + let hsign = hSign hth + let Result ds mhsign' = foldM (\s m -> HSign.addModToSig s (mkId [m]) i) hsign mods + case mhsign' of + Nothing -> error $ "cannot add modalities" ++ show ds + Just hsign' -> do + put $ hth { hSign = hsign', anaDiags = ds ++ anaDiags hth } + return bi + HBasic.Axiom_items annofs -> do + hth <- get + let (hth', annofs') = foldl (\(h, l) f -> let (f', h') = runState (anaHFORMULA f) h + in (h', f':l)) (hth, []) annofs + let replfs = reverse annofs' + nfs = map (makeNamedSen.snd) replfs + put $ hth' {hSens = nfs ++ hSens hth'} + return $ HBasic.Axiom_items $ map fst replfs + +anaHFORMULA :: Annoted HBasic.HFORMULA -> State HTheoryAna (Annoted HBasic.HFORMULA, Annoted HBasic.HFORMULA) +anaHFORMULA hf = case item hf of + HBasic.Base_formula bsen r -> case bsen of + Mixfix_formula (Mixfix_token i) -> do + hth <- get + let (d, hf') = if i `elem` (Map.keys $ hVars hth) then (Nothing, hf { item = HBasic.Nominal True i r}) + else if Set.member (simpleIdToId i) (HSign.noms $ hSign hth) + then (Nothing, hf { item = HBasic.Nominal False i r}) + else (Just $ mkDiag Error "undeclared nominal" i, hf) + -- here we check whether the nominal is a variable or not! + case d of + Nothing -> return (hf', hf') + Just x -> do + put $ hth {anaDiags = x : (anaDiags hth) } + return (hf, hf) + f -> do + hth <- get + let bsig = HSign.baseSig $ hSign hth + Result ds1 msig = CSign.addSymbToSign (RSign.caslSign bsig) $ + CSign.Symbol (genName "ST") CSign.SortAsItemType + case msig of + Nothing -> do + put $ hth {anaDiags = ds1 ++ anaDiags hth} + return (hf, hf) + Just bsig0 -> do + let allIds = CAna.getAllIds (Basic_spec []) emptyMix bsig0 + mix = emptyMix { mixRules = makeRules (CSign.globAnnos bsig0) allIds } + Result ds3 mf = CAna.anaForm (const return) mix + bsig0{CSign.varMap = Map.union (CSign.varMap bsig0) $ + hVars hth} + f + case mf of + Nothing -> do + put $ hth {anaDiags = ds3 ++ anaDiags hth} + return (hf, hf) + Just (f1, f2) -> let hf1 = hf {item = HBasic.Base_formula f1 r} + hf2 = hf {item = HBasic.Base_formula f2 r} + in return (hf1, hf2) + HBasic.Negation f r -> do + (af1, af2) <- anaHFORMULA $ emptyAnno f + let hf'= hf { item = HBasic.Negation (item af2) r} + return (hf{item = HBasic.Negation (item af1) r}, hf') + HBasic.Conjunction fs r -> do + afs' <- mapM anaHFORMULA $ map emptyAnno fs + return $ (hf { item = HBasic.Conjunction (map (item.fst) afs') r}, + hf { item = HBasic.Conjunction (map (item.snd) afs') r}) + HBasic.Disjunction fs r -> do + afs' <- mapM anaHFORMULA $ map emptyAnno fs + return $ (hf { item = HBasic.Disjunction (map (item.fst) afs') r}, + hf { item = HBasic.Disjunction (map (item.snd) afs') r}) + HBasic.Implication f1 f2 r -> do + f1' <- anaHFORMULA $ emptyAnno f1 + f2' <- anaHFORMULA $ emptyAnno f2 + return $ (hf {item = HBasic.Implication (item $ fst f1') (item $ fst f2') r}, + hf {item = HBasic.Implication (item $ snd f1') (item $ snd f2') r}) + HBasic.Equivalence f1 f2 r -> do + f1' <- anaHFORMULA $ emptyAnno f1 + f2' <- anaHFORMULA $ emptyAnno f2 + return $ (hf {item = HBasic.Equivalence (item $ fst f1') (item $ fst f2') r}, + hf {item = HBasic.Equivalence (item $ snd f1') (item $ snd f2') r}) + HBasic.Nominal _b i _r -> do + hth <- get + if ( Set.member (simpleIdToId i) (HSign.noms $ hSign hth) ) || + ( (i, genName "ST") `elem` (Map.toList $ hVars hth)) + then return (hf, hf) + else do + put $ hth {anaDiags = (mkDiag Error "undeclared nominal" i) : (anaDiags hth)} + return (hf,hf) + HBasic.AtState i f r -> do + hth <- get + if ( Set.member (simpleIdToId i) (HSign.noms $ hSign hth) ) || + ( (i, genName "ST") `elem` (Map.toList $ hVars hth)) + then do + f' <- anaHFORMULA $ emptyAnno f + return $ (hf { item = HBasic.AtState i (item $ fst f') r}, + hf { item = HBasic.AtState i (item $ snd f') r}) + else do + put $ hth {anaDiags = (mkDiag Error "undeclared nominal" i) : (anaDiags hth)} + return (hf,hf) + HBasic.BoxFormula i f r -> do + hth <- get + if (simpleIdToId i) `elem` (Map.keys $ HSign.mods $ hSign hth) + then do + f' <- anaHFORMULA $ emptyAnno f + return $ (hf { item = HBasic.BoxFormula i (item $ fst f') r}, + hf { item = HBasic.BoxFormula i (item $ snd f') r}) + else do + put $ hth {anaDiags = (mkDiag Error "undeclared modality" i) : (anaDiags hth)} + return (hf,hf) + HBasic.DiamondFormula i f r -> do + hth <- get + if (simpleIdToId i) `elem` (Map.keys $ HSign.mods $ hSign hth) + then do + f' <- anaHFORMULA $ emptyAnno f + return $ (hf { item = HBasic.DiamondFormula i (item $ fst f') r}, + hf { item = HBasic.DiamondFormula i (item $ snd f') r}) + else do + put $ hth {anaDiags = (mkDiag Error "undeclared modality" i) : (anaDiags hth)} + return (hf,hf) + HBasic.QuantRigidVars q vs f r -> do + hth <- get + let -- bsig = HSign.baseSig $ hSign hth + varPars = concatMap (\(Var_decl xs s _) -> map (\x -> (x,s)) xs) vs + (f', _) = runState (anaHFORMULA $ emptyAnno f) $ + hth {hVars = Map.union (hVars hth) $ Map.fromList $ varPars } + return $ (hf{item = HBasic.QuantRigidVars q vs (item $ fst f') r}, + hf{item = HBasic.QuantRigidVars q vs (item $ snd f') r}) + HBasic.QuantNominals q ns f r -> do + hth <- get + let (f',_) = runState (anaHFORMULA $ emptyAnno f) $ + hth {hVars = Map.union (hVars hth) $ Map.fromList $ map (\i -> (i, genName "ST") ) ns} + return $ (hf { item = HBasic.QuantNominals q ns (item $ fst f') r}, + hf { item = HBasic.QuantNominals q ns (item $ snd f') r}) diff --git a/HPAR/Symbol.hs b/HPAR/Symbol.hs new file mode 100644 index 0000000000..a2e6080c11 --- /dev/null +++ b/HPAR/Symbol.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./HPAR/Symbol.hs +Description : Morphisms in HPAR +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.cm +Stability : experimental +Portability : portable + + Definition of symbols for HPAR + +-} + +module HPAR.Symbol where + +import qualified CASL.Sign as CSign +import qualified HPAR.Sign as HSign +import Common.Id +import Common.DocUtils +import Data.Data +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified CASL.Morphism as CMor + +-- symbols + +data HSymbol = BSymbol CSign.Symbol + | HSymb Id HKind + deriving (Show, Eq, Ord, Typeable, Data) + +data HKind = NKind | MKind Int + deriving (Show, Eq, Ord, Typeable, Data) + +instance Pretty HSymbol where + pretty (BSymbol s) = pretty s + pretty (HSymb i _) = pretty i + +instance GetRange HSymbol where + getRange (BSymbol s) = getRange s + getRange (HSymb i _ ) = getRange i + rangeSpan (BSymbol s) = rangeSpan s + rangeSpan (HSymb i _ ) = rangeSpan i + +-- raw symbols + +data HRawSymbol = ASymbol HSymbol + | AKindedSymb HKind Id -- does this suffice? + deriving (Show, Eq, Ord, Typeable, Data) + +symOf :: HSign.HSign -> [Set.Set HSymbol] +symOf hsign = + let + bSyms = CMor.symOf $ HSign.baseSig hsign + nSyms = HSign.noms hsign + mSyms = HSign.mods hsign + in [Set.map (\x -> HSymb x NKind) nSyms] ++ + [Set.fromList $ map (\(m,i) -> HSymb m (MKind i)) $ Map.toList mSyms] ++ + map (\ss -> Set.map (\s -> BSymbol s) ss) bSyms + +symName :: HSymbol -> Id +symName (BSymbol s) = CSign.symName s +symName (HSymb i _) = i + diff --git a/Hybrid/Keywords.hs b/Hybrid/Keywords.hs index 0dec5ef0c4..dcb77bf6ac 100644 --- a/Hybrid/Keywords.hs +++ b/Hybrid/Keywords.hs @@ -17,8 +17,8 @@ String constants for keywords to be used for parsing and printing module Hybrid.Keywords where -nominalS :: String -nominalS = "nominal" +--nominalS :: String +--nominalS = "nominal" -nominalsS :: String -nominalsS = "nominals" +--nominalsS :: String +--nominalsS = "nominals" diff --git a/Hybrid/Parse_AS.hs b/Hybrid/Parse_AS.hs index f22ec10609..c5329742e7 100644 --- a/Hybrid/Parse_AS.hs +++ b/Hybrid/Parse_AS.hs @@ -22,7 +22,7 @@ import Common.Keywords import Common.Lexer import Common.Token import Hybrid.AS_Hybrid -import Hybrid.Keywords +import Hybrid.Keywords () import Text.ParserCombinators.Parsec hybrid_reserved_words :: [String] diff --git a/Hybrid/Print_AS.hs b/Hybrid/Print_AS.hs index 752e98a473..19dd949059 100644 --- a/Hybrid/Print_AS.hs +++ b/Hybrid/Print_AS.hs @@ -24,7 +24,7 @@ import qualified Common.Lib.MapSet as MapSet import Hybrid.AS_Hybrid import Hybrid.HybridSign -import Hybrid.Keywords +import Hybrid.Keywords () import qualified Data.Map as Map diff --git a/Logic/Comorphism.hs b/Logic/Comorphism.hs index 667b5d01c2..267ffc6da6 100644 --- a/Logic/Comorphism.hs +++ b/Logic/Comorphism.hs @@ -138,6 +138,9 @@ class (Language cid, -- expansion preserves satisfaction eps :: cid -> Bool eps _ = True + -- helpers for hybridization + com_path :: cid -> String + com_path _ = "" -- a comorphism is a generalized theoroidal comorphism (GTC) -- if the presence of an axiom in a theory -- impacts on the signature of the translated theory along the GTC diff --git a/Logic/Grothendieck.hs b/Logic/Grothendieck.hs index 3d527b78fd..c621685c05 100644 --- a/Logic/Grothendieck.hs +++ b/Logic/Grothendieck.hs @@ -107,6 +107,7 @@ import Logic.ExtSign import Logic.Logic import Logic.Modification import Logic.Morphism +import Logic.HDef import ATerm.Lib @@ -432,6 +433,7 @@ data LogicGraph = LogicGraph , currentSublogic :: Maybe G_sublogics , currentTargetBase :: Maybe (LibName, String) , sublogicBasedTheories :: Map.Map AnyLogic SublogicBasedTheories + , knownHybLogics :: Map.Map String HLogicDef , comorphisms :: Map.Map String AnyComorphism , inclusions :: Map.Map (String, String) AnyComorphism , unions :: Map.Map (String, String) (AnyComorphism, AnyComorphism) @@ -451,6 +453,7 @@ emptyLogicGraph = LogicGraph , currentSublogic = Nothing , currentTargetBase = Nothing , sublogicBasedTheories = Map.empty + , knownHybLogics = Map.empty , comorphisms = Map.empty , inclusions = Map.empty , unions = Map.empty diff --git a/Logic/HDef.hs b/Logic/HDef.hs new file mode 100644 index 0000000000..33829952d4 --- /dev/null +++ b/Logic/HDef.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./Logic/HDef.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : non-portable(Grothendieck) + +Definitions of hybridizations of logics and comorphisms, with their parameters. + +-} + + +module Logic.HDef where + +import Data.Typeable +import Common.Id +import Common.Doc +import Common.DocUtils +import Logic.SemConstr + +-- DrIFT command: +{-! global: GetRange !-} + +data HLogicDef = HLogicDef { + newHybridLogicName :: String, + baseLogicName :: (String, Maybe String), -- the second string is the sublogic + isExtension :: Bool, + semConstrs :: [SemanticConstraint], + varKinds :: [(String, Maybe Token)] + } deriving (Show, Typeable, Eq, Ord) + +instance GetRange HLogicDef where + getRange = getRange . show + rangeSpan = rangeSpan . show + +instance Pretty HLogicDef where + pretty = printHLogicDef + +printHLogicDef :: HLogicDef -> Doc +printHLogicDef hld = + text "logic" $+$ text (newHybridLogicName hld) + +data HComDef = HComDef { + newHComName :: String, + baseComName :: String, + sourceHLogic :: String + } deriving (Show, Typeable, Eq, Ord) + +instance GetRange HComDef where + getRange = getRange . show + rangeSpan = rangeSpan . show + +instance Pretty HComDef where + pretty = printHComDef + +printHComDef :: HComDef -> Doc +printHComDef hcd = + text "comorphism" $+$ text (newHComName hcd) diff --git a/Logic/Logic.hs b/Logic/Logic.hs index 76d8bffb1a..8af8b61bd4 100644 --- a/Logic/Logic.hs +++ b/Logic/Logic.hs @@ -161,6 +161,11 @@ import Data.Ord import Data.Typeable import Control.Monad (unless) import qualified Control.Monad.Fail as Fail +import Logic.SemConstr + +import CASL.AS_Basic_CASL + +import qualified GenHyb.GenTypes as GTypes -- | Stability of logic implementations data Stability = Stable | Testing | Unstable | Experimental @@ -194,7 +199,7 @@ class Show lid => Language lid where -- short description = first line of description short_description :: Language lid => lid -> String short_description l = head ((lines $ description l) ++ [""]) - + {- | Categories are given as usual: objects, morphisms, identities, domain, codomain and composition. The type id is the name, or the identity of the category. It is an argument to all functions @@ -356,6 +361,9 @@ class (Language lid, Category sign morphism, Ord sentence, print_named :: lid -> Named sentence -> Doc print_named _ = printAnnoted (addBullet . pretty) . fromLabelledSen + is_nominal_sen :: lid -> Set.Set Id -> sentence -> (Bool, Maybe Id) + is_nominal_sen _ _ _ = (False, Nothing) + -- --------------------- symbols --------------------------- -- | dependency ordered list of symbol sets for a signature @@ -388,6 +396,9 @@ class (Language lid, Category sign morphism, Ord sentence, -- | a logic dependent kind of a symbol symKind :: lid -> symbol -> String symKind _ _ = "defaultKind" + -- | extended kind of symbol, to allow consts in CASL + extSymKind :: lid -> symbol -> String + extSymKind = symKind -- | the symbols occuring in a sentence (any order) symsOfSen :: lid -> sign -> sentence -> [symbol] symsOfSen _ _ _ = [] @@ -465,9 +476,12 @@ class ( Syntax lid basic_spec symbol symb_items symb_map_items -> Maybe ((basic_spec, sign, GlobalAnnos) -> Result (basic_spec, ExtSign sign symbol, [Named sentence])) basic_analysis _ = Nothing - -- | Analysis of just sentences + {- | Analysis of just sentences + the result is a pair because in CASL logics we want to use both + representations of the formula - for display and for translation + -} sen_analysis :: lid - -> Maybe ((basic_spec, sign, sentence) -> Result sentence) + -> Maybe ((basic_spec, sign, sentence) -> Result (sentence, sentence)) sen_analysis _ = Nothing -- | a basic analysis with additional arguments extBasicAnalysis :: lid -> IRI -> LibName @@ -532,6 +546,10 @@ class ( Syntax lid basic_spec symbol symb_items symb_map_items in the CASL RefMan p. 192. -} symbol_to_raw :: lid -> symbol -> raw_symbol symbol_to_raw l _ = statError l "symbol_to_raw" + {- | convert a raw symbol to symbol, when possible + -} + raw_to_symbol :: lid -> raw_symbol -> Maybe symbol + raw_to_symbol _ _ = Nothing {- | Construe an identifier, like f, as a raw symbol. See CASL RefMan p. 192, function IDAsSym -} id_to_raw :: lid -> Id -> raw_symbol @@ -540,14 +558,20 @@ class ( Syntax lid basic_spec symbol symb_items symb_map_items example, f:s->t matches f. See CASL RefMan p. 192 -} matches :: lid -> symbol -> raw_symbol -> Bool matches _ _ _ = True + {- | convert a raw symbol to a CASL variable -} + raw_to_var :: lid -> raw_symbol -> Maybe (Token, Id) + raw_to_var _ _ = Nothing -- ------------- operations on signatures and morphisms ----------- -- | the empty (initial) signature, see CASL RefMan p. 193 empty_signature :: lid -> sign - -- | adds a symbol to a given signature + -- TODO: remove this! adds a symbol to a given signature add_symb_to_sign :: lid -> sign -> symbol -> Result sign add_symb_to_sign l _ _ = statFail l "add_symb_to_sign" + -- | extend the signature with nominals + add_noms_to_sign :: lid -> sign -> Set.Set Id -> Result sign + add_noms_to_sign _ s _ = return s -- | union of signatures, see CASL RefMan p. 193 signature_union :: lid -> sign -> sign -> Result sign signature_union l _ _ = statFail l "signature_union" @@ -637,9 +661,9 @@ class ( Syntax lid basic_spec symbol symb_items symb_map_items printTheory :: StaticAnalysis lid basic_spec sentence symb_items symb_map_items sign morphism symbol raw_symbol => Maybe IRI -> lid -> (sign, [Named sentence]) -> Doc -printTheory sm lid th@(s, l) = case +printTheory sm lid (s, l) = case (convertTheory lid, basicSpecPrinter sm lid) of - (Just c, Just p) -> p (c th) + -- TODO: for now (Just c, Just p) -> p (c (s,l)) _ -> print_sign lid s $++$ vsep (map (print_named lid) l) -- | guarded inclusion @@ -744,6 +768,60 @@ class (StaticAnalysis lid parse_basic_sen :: lid -> Maybe (basic_spec -> AParser st sentence) parse_basic_sen _ = Nothing + -- formula parser, no extra argument of type basic_spec + + parse_formula :: lid -> Maybe (AParser st sentence) + parse_formula _ = Nothing + + -- prim formula parser, for hybridization + + parse_prim_formula :: lid -> Maybe (PrefixMap -> AParser st sentence) + parse_prim_formula _ = Nothing + + {- + case data_logic hlid of + Just (Logic baseLid) -> do + f <- parseQFormula eng hasQNominalsBase + (not $ null kVarsBase) baseLid (q, p) + gives a type mismatch, + although the required Logic instance has the same baseLid and + the types should be determined by the functional dependency + to fix this, we record in parse_q_formula + the method (parseQFormula baseLid) for each logic + and we call it for hlid + UGLY solution! + -} + + parse_q_formula :: lid -> + Maybe (Bool -> Bool -> Bool -> + (GTypes.HQUANT, Token) -> + PrefixMap -> + AParser st sentence) + parse_q_formula _ = Nothing + + -- semantic constraints, that will determine sentences when + -- translating from a hybrid logic to FOL + + sem_constr :: lid -> [SemanticConstraint] + sem_constr _ = [] + + -- for each hybrid logic, store the kinds allowed in quantifications + -- and if it allows quantification on nominals, to be able to set + -- the right parameters for the analysis in recursive calls, + -- for double hybridization + + hyb_params :: lid -> Maybe (Bool, [String]) + hyb_params _ = Nothing + + -- logic dependent translation of constraints to CASL formulas + + constr_to_sens :: lid -> sign -> String -> SemanticConstraint -> + Result ([Named CASLFORMULA]) + constr_to_sens lid _ _ _ = + fail $ + "translation of constraints to CASL formulas " ++ + "not implemented for logic " ++ show lid + -- | stability of the implementation stability :: lid -> Stability stability _ = Experimental @@ -859,6 +937,29 @@ class (StaticAnalysis lid -> Result (sign, [Named sentence]) -- no logic should throw an error here addOmdocToTheory _ _ t _ = return t + -- helpers for hybridization + -- for each type, its name and the file where it is defined + -- ("","") for default () + sublogicsTypeName :: lid -> (String, String) + sublogicsTypeName _ = ("","") + basicSpecTypeName :: lid -> (String, String) + basicSpecTypeName _ = ("","") + sentenceTypeName :: lid -> (String, String) + sentenceTypeName _ = ("","") + symbItemsTypeName :: lid -> (String, String) + symbItemsTypeName _ = ("","") + symbMapItemsTypeName :: lid -> (String, String) + symbMapItemsTypeName _ = ("","") + signTypeName :: lid -> (String, String) + signTypeName _ = ("","") + morphismTypeName :: lid -> (String, String) + morphismTypeName _ = ("","") + symbolTypeName :: lid -> (String, String) + symbolTypeName _ = ("","") + rawSymbolTypeName :: lid -> (String, String) + rawSymbolTypeName _ = ("","") + proofTreeTypeName :: lid -> (String, String) + proofTreeTypeName _ = ("","") -- | sublogic of a theory sublogicOfTheo :: lid -> (sign, [sentence]) -> sublogics @@ -868,6 +969,8 @@ class (StaticAnalysis lid + + {- The class of logics which can be used as logical frameworks, in which object logics can be specified by the user. Currently the only logics implementing this class are LF, Maude, and Isabelle, with the latter two only having diff --git a/Logic/SemConstr.hs b/Logic/SemConstr.hs new file mode 100644 index 0000000000..d8a8c9c630 --- /dev/null +++ b/Logic/SemConstr.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./Logic/SemConstr.hss +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt +Maintainer : till@informatik.uni-bremen.de +Stability : provisional +Portability : non-portable(Grothendieck) + +Semantic constraints for hybridization of institutions. + +-} + + +module Logic.SemConstr where + +import Data.Typeable +import Common.Id + +-- DrIFT command: +{-! global: GetRange !-} + +data SemanticConstraint = + ReflexiveMod | TransitiveMod | SymmetricMod | + SerialMod | EuclideanMod | FunctionalMod | + LinearMod | TotalMod | SameInterpretation String | + SameDomain Bool -- True for rigid partial, False for partial + deriving (Eq, Ord, Show, Typeable) + +instance GetRange SemanticConstraint where + getRange = getRange . show + rangeSpan = rangeSpan . show + diff --git a/Makefile b/Makefile index ff7c5e3f69..9186ff750c 100755 --- a/Makefile +++ b/Makefile @@ -98,6 +98,7 @@ GENRULECALL = $(GENRULES) -r ShATermConvertible \ GENRULECALL2 = $(GENRULES) -r ShATermLG \ -i ATerm.Lib -i ATC.Grothendieck + DRIFT = utils/DrIFT HADDOCK = haddock @@ -116,7 +117,7 @@ derived_sources += $(GTK_GLADE_HSFILES) # the list of logics that need ShATermConvertible instances logics = CASL HasCASL Isabelle Modal Hybrid TopHybrid Temporal \ - CoCASL COL CspCASL CASL_DL \ + CoCASL COL CspCASL CASL_DL RigidCASL HPAR \ SoftFOL ConstraintCASL Propositional RelationalScheme VSE OMDoc DFOL \ LF Framework Maude ExtModal CommonLogic CSL QBF Adl HolLight Fpl THF \ FreeCAD OWL2 RDF CSMOF QVTR TPTP NeSyPatterns @@ -200,7 +201,8 @@ TESTTARGETS := $(subst .hs,,$(TESTTARGETFILES)) # files generated by DriFT drifted_files = Common/AS_Annotation.hs \ - CASL/AS_Basic_CASL.hs Modal/AS_Modal.hs Hybrid/AS_Hybrid.hs TopHybrid/AS_TopHybrid.hs \ + CASL/AS_Basic_CASL.hs Modal/AS_Modal.hs Hybrid/AS_Hybrid.hs \ + RigidCASL/AS_Rigid.hs TopHybrid/AS_TopHybrid.hs \ Syntax/AS_Structured.hs Syntax/AS_Architecture.hs Syntax/AS_Library.hs \ Propositional/AS_BASIC_Propositional.hs \ CoCASL/AS_CoCASL.hs COL/AS_COL.hs \ @@ -216,11 +218,11 @@ drifted_files = Common/AS_Annotation.hs \ atc_files = Common/AS_Annotation.der.hs Common/DefaultMorphism.hs \ Syntax/AS_Structured.der.hs Syntax/AS_Architecture.der.hs \ Common/GlobalAnnotations.hs Syntax/AS_Library.der.hs \ - Logic/Prover.hs Common/LibName.hs Common/ExtSign.hs \ + Logic/Prover.hs Logic/HDef.hs Logic/SemConstr.hs Common/LibName.hs Common/ExtSign.hs \ Common/Consistency.hs Common/ProofTree.hs \ Static/DgUtils.hs Static/XGraph.hs Static/DevGraph.hs \ Common/Id.hs Common/Result.hs Common/OrderedMap.hs \ - Common/Lib/Graph.hs Common/IRI.hs + Common/Lib/Graph.hs Common/IRI.hs Logic/SemConstr.hs Logic/HDef.hs # files generated by genRules as input for DriFT atc_der_files = $(foreach file, $(atc_files), \ @@ -263,11 +265,17 @@ ATC/DefaultMorphism.der.hs: Common/DefaultMorphism.hs $(GENRULES) ATC/AS_Structured.der.hs: Syntax/AS_Structured.der.hs $(GENRULES) $(GENRULECALL2) -o $@ $< +ATC/SemConstr.der.hs: Logic/SemConstr.hs $(GENRULES) + $(GENRULECALL) -o $@ $< + +ATC/HDef.der.hs: Logic/HDef.hs $(GENRULES) + $(GENRULECALL) -i ATC.Id -i ATC.SemConstr -o $@ $< + ATC/AS_Architecture.der.hs: Syntax/AS_Architecture.der.hs $(GENRULES) $(GENRULECALL2) -i ATC.AS_Structured -o $@ $< ATC/AS_Library.der.hs: Syntax/AS_Library.der.hs $(GENRULES) - $(GENRULECALL2) -i ATC.AS_Architecture -i ATC.LibName -o $@ $< + $(GENRULECALL2) -i ATC.AS_Architecture -i ATC.LibName -i ATC.SemConstr -i ATC.HDef -o $@ $< ATC/GlobalAnnotations.der.hs: Common/GlobalAnnotations.hs $(GENRULES) $(GENRULECALL) -i ATC.AS_Annotation -i ATC.Result -o $@ $< @@ -308,6 +316,8 @@ RS_files = RelationalScheme/AS.hs RelationalScheme/Sign.hs Modal_files = Modal/AS_Modal.hs Modal/ModalSign.hs Hybrid_files = Hybrid/AS_Hybrid.hs Hybrid/HybridSign.hs +Rigid_files = RigidCASL/AS_Rigid.hs RigidCASL/Sign.hs +HPAR_files = HPAR/AS_Basic_HPAR.hs HPAR/Sign.hs HPAR/Morphism.hs HPAR/Symbol.hs TopHybrid_files = TopHybrid/AS_TopHybrid.hs TopHybrid/TopHybridSign.hs Temporal_files = Temporal/AS_BASIC_Temporal.hs Temporal/Sign.hs \ @@ -328,6 +338,7 @@ OMDoc_files = OMDoc/OMDocInterface.hs DFOL_files = DFOL/AS_DFOL.hs DFOL/Sign.hs DFOL/Morphism.hs DFOL/Symbol.hs LF_files = LF/Sign.hs LF/Morphism.hs LF/AS.hs Framework_files = Framework/AS.hs +Hyb_files = GenHyb/Logic_Hyb.hs Maude_files = Maude/Sign.hs Maude/Morphism.hs Maude/Sentence.hs \ Maude/Symbol.hs Maude/AS_Maude.hs @@ -394,6 +405,12 @@ Modal/ATC_Modal.der.hs: $(Modal_files) $(GENRULES) Hybrid/ATC_Hybrid.der.hs: $(Hybrid_files) $(GENRULES) $(GENRULECALL) -i CASL.ATC_CASL -o $@ $(Hybrid_files) +RigidCASL/ATC_RigidCASL.der.hs: $(Rigid_files) $(GENRULES) + $(GENRULECALL) -i CASL.ATC_CASL -o $@ $(Rigid_files) + +HPAR/ATC_HPAR.der.hs: $(HPAR_files) $(GENRULES) + $(GENRULECALL) -i RigidCASL.ATC_RigidCASL -i CASL.ATC_CASL -o $@ $(HPAR_files) + TopHybrid/ATC_TopHybrid.der.hs: $(TopHybrid_files) $(GENRULES) $(GENRULECALL) -i ATC.AS_Annotation -o $@ $(TopHybrid_files) @@ -433,6 +450,9 @@ LF/ATC_LF.der.hs: $(LF_files) $(GENRULES) Framework/ATC_Framework.der.hs: $(Framework_files) $(GENRULES) $(GENRULECALL) -i ATC.AS_Annotation -o $@ $(Framework_files) +GenHyb/ATC_Logic_Hyb.der.hs: $(Hyb_files) $(GENRULES) + $(GENRULECALL) -i ATC.AS_Annotation -i ATC.HDef -o $@ $(Hyb_files) + Maude/ATC_Maude.der.hs: $(Maude_files) $(GENRULES) $(GENRULECALL) -i ATC.AS_Annotation -o $@ $(Maude_files) diff --git a/OWL2/ParseMS.hs b/OWL2/ParseMS.hs index 7c29154d76..efdf028779 100644 --- a/OWL2/ParseMS.hs +++ b/OWL2/ParseMS.hs @@ -18,7 +18,7 @@ import OWL2.AS import OWL2.Keywords hiding (comment) import OWL2.ColonKeywords -import Common.Keywords +import Common.Keywords hiding (reflexiveS, transitiveS, symmetricS) import Common.IRI import Common.Id (stringToId) import Common.Lexer diff --git a/OWL2/PrintMS.hs b/OWL2/PrintMS.hs index cbc7ed4076..7141015c05 100644 --- a/OWL2/PrintMS.hs +++ b/OWL2/PrintMS.hs @@ -5,7 +5,7 @@ import qualified Data.Set as S import Common.Doc import Common.DocUtils -import Common.Keywords +import Common.Keywords hiding (reflexiveS, transitiveS, symmetricS) import Common.IRI import Common.GlobalAnnotations as GA (PrefixMap) diff --git a/Propositional/Analysis.hs b/Propositional/Analysis.hs index 7fdc606f97..f0f2ae8433 100644 --- a/Propositional/Analysis.hs +++ b/Propositional/Analysis.hs @@ -22,6 +22,8 @@ module Propositional.Analysis , inducedFromToMorphism , signatureColimit , pROPsen_analysis + , pSymsOfSen + , constrToSens ) where @@ -42,6 +44,16 @@ import qualified Propositional.AS_BASIC_Propositional as AS_BASIC import qualified Propositional.Morphism as Morphism import qualified Propositional.Symbol as Symbol +import Logic.SemConstr +import qualified CASL.AS_Basic_CASL as CBasic + +constrToSens :: Sign.Sign -> String -> SemanticConstraint -> Result.Result ([AS_Anno.Named CBasic.CASLFORMULA]) +constrToSens _ _ sc = + case sc of + SameInterpretation "prop" -> error $ "Same interpretation of propositions implies identical local models" + SameInterpretation k -> error $ "invalid kind for logic Propositional:" ++ k + _ -> error $ "invalid constraint for logic Propositional:" ++ show sc + -- | Datatype for formulas with diagnosis data data DIAG_FORM = DiagForm { @@ -336,10 +348,23 @@ signatureColimit graph = do pROPsen_analysis :: (AS_BASIC.BASIC_SPEC, Sign.Sign, AS_BASIC.FORMULA) - -> Result.Result AS_BASIC.FORMULA + -> Result.Result (AS_BASIC.FORMULA, AS_BASIC.FORMULA) pROPsen_analysis (_, s, f) = let x = addFormula [] (NumForm annoF 0) s h = return . diagnosis . head - g = Just . AS_Anno.sentence . formula . head + g = AS_Anno.sentence . formula . head annoF = AS_Anno.Annoted f Id.nullRange [] [] - in Result.Result (h x) (g x) + gx = g x + in Result.Result (h x) $ Just (gx, gx) + +pSymsOfSen :: Sign.Sign -> AS_BASIC.FORMULA -> [Symbol.Symbol] +pSymsOfSen sig sen = + case sen of + AS_BASIC.False_atom _ -> [] + AS_BASIC.True_atom _ -> [] + AS_BASIC.Predication tok -> [Symbol.Symbol $ Id.simpleIdToId tok] + AS_BASIC.Negation f _ -> pSymsOfSen sig f + AS_BASIC.Conjunction fs _ -> concatMap (pSymsOfSen sig) fs + AS_BASIC.Disjunction fs _ -> concatMap (pSymsOfSen sig) fs + AS_BASIC.Implication f1 f2 _ -> (pSymsOfSen sig f1) ++ (pSymsOfSen sig f2) + AS_BASIC.Equivalence f1 f2 _ -> (pSymsOfSen sig f1) ++ (pSymsOfSen sig f2) diff --git a/Propositional/Logic_Propositional.hs b/Propositional/Logic_Propositional.hs index 2755fcce05..f72dd96ce1 100644 --- a/Propositional/Logic_Propositional.hs +++ b/Propositional/Logic_Propositional.hs @@ -50,6 +50,7 @@ import Common.ProofTree import Common.Id import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Monoid () -- | Lid for propositional logic @@ -90,6 +91,15 @@ instance Sentences Propositional FORMULA map_sen Propositional = mapSentence -- there is nothing to leave out simplify_sen Propositional _ = simplify + -- symbols of a sentence + symsOfSen Propositional = pSymsOfSen + -- test nominals + is_nominal_sen Propositional noms aSen = + case aSen of + Predication p -> + let pId = simpleIdToId p + in if Set.member pId noms then (True, Just pId) else (False, Nothing) + _ -> (False, Nothing) instance Semigroup BASIC_SPEC where (Basic_spec l1) <> (Basic_spec l2) = Basic_spec $ l1 ++ l2 @@ -120,6 +130,8 @@ instance Logic Propositional where -- hybridization parse_basic_sen Propositional = Just $ const impFormula + parse_formula Propositional = Just $ impFormula + parse_prim_formula Propositional = Just $ const primFormula stability Propositional = Stable top_sublogic Propositional = Sublogic.top all_sublogics Propositional = sublogics_all @@ -134,6 +146,18 @@ instance Logic Propositional [ ConservativityChecker "sKizzo" (checkBinary "sKizzo") conserCheck , ConservativityChecker "Truth Tables" (return Nothing) ttConservativityChecker] + -- helpers for generic hyridization + sublogicsTypeName Propositional = ("PropSL","Propositional.Sublogic") + basicSpecTypeName Propositional = ("BASIC_SPEC","Propositional.AS_BASIC_Propositional") + sentenceTypeName Propositional = ("FORMULA","Propositional.AS_BASIC_Propositional") + symbItemsTypeName Propositional = ("SYMB_ITEMS","Propositional.AS_BASIC_Propositional") + symbMapItemsTypeName Propositional = ("SYMB_MAP_ITEMS","Propositional.AS_BASIC_Propositional") + signTypeName Propositional = ("Sign","Propositional.Sign") + morphismTypeName Propositional = ("Morphism","Propositional.Morphism") + symbolTypeName Propositional = ("Symbol","Propositional.Symbol") + rawSymbolTypeName Propositional = ("Symbol","Propositional.Symbol") + proofTreeTypeName Propositional = ("ProofTree","Common.ProofTree") + constr_to_sens Propositional = constrToSens -- | Static Analysis for propositional logic instance StaticAnalysis Propositional @@ -149,11 +173,13 @@ instance StaticAnalysis Propositional basic_analysis Propositional = Just basicPropositionalAnalysis sen_analysis Propositional = Just pROPsen_analysis + add_symb_to_sign Propositional = addSymbToSign empty_signature Propositional = emptySig is_subsig Propositional = isSubSigOf subsig_inclusion Propositional s = return . inclusionMap s signature_union Propositional = sigUnion symbol_to_raw Propositional = symbolToRaw + raw_to_symbol Propositional = rawToSymbol id_to_raw Propositional = idToRaw matches Propositional = Symbol.matches stat_symb_items Propositional _ = mkStatSymbItems @@ -162,6 +188,7 @@ instance StaticAnalysis Propositional induced_from_morphism Propositional = inducedFromMorphism induced_from_to_morphism Propositional = inducedFromToMorphism signature_colimit Propositional = signatureColimit + -- | Sublogics instance SemiLatticeWithTop PropSL where diff --git a/Propositional/Parse_AS_Basic.hs b/Propositional/Parse_AS_Basic.hs index b14915d65a..3894794497 100644 --- a/Propositional/Parse_AS_Basic.hs +++ b/Propositional/Parse_AS_Basic.hs @@ -19,6 +19,7 @@ module Propositional.Parse_AS_Basic , symbItems , symbMapItems , impFormula + , primFormula ) where import Common.AnnoState diff --git a/Propositional/Symbol.hs b/Propositional/Symbol.hs index 29243e4121..8a5038334c 100644 --- a/Propositional/Symbol.hs +++ b/Propositional/Symbol.hs @@ -22,13 +22,16 @@ module Propositional.Symbol , getSymbolName -- Determines the name of a symbol , idToRaw -- Creates a raw symbol , symbolToRaw -- Convert symbol to raw symbol + , rawToSymbol -- convert a raw symbol to a symbol , matches -- does a symbol match a raw symbol? , applySymMap -- application function for symbol maps + , addSymbToSign -- add a symbol to the signature ) where import qualified Common.Id as Id import Common.Doc import Common.DocUtils +import Common.Result import Data.Data import qualified Data.Set as Set @@ -55,6 +58,12 @@ symOf :: Sign.Sign -> Set.Set Symbol symOf x = Set.fold (\ y -> Set.insert Symbol {symName = y}) Set.empty $ Sign.items x +-- | Add a symbol to a signature + +addSymbToSign :: Sign.Sign -> Symbol -> Result Sign.Sign +addSymbToSign sign (Symbol i) = + return $ Sign.addToSig sign i + -- | Determines the symbol map of a morhpism getSymbolMap :: Morphism.Morphism -> Map.Map Symbol Symbol getSymbolMap f = @@ -73,6 +82,10 @@ idToRaw mid = Symbol {symName = mid} symbolToRaw :: Symbol -> Symbol symbolToRaw = id +-- | convert a symbol to raw +rawToSymbol :: Symbol -> Maybe Symbol +rawToSymbol = Just + -- | does a smybol match a raw symbol? matches :: Symbol -> Symbol -> Bool matches s1 s2 = s1 == s2 diff --git a/README.md b/README.md index 08c6b841d7..b29d0f6c69 100644 --- a/README.md +++ b/README.md @@ -25,6 +25,7 @@ Hets is a parsing, static analysis and proof management tool incorporating vario The structuring constructs of the heterogeneous specification language are those of the [OMG](http://www.omg.org)-standardised [Distributed Ontology, Model and Specification Language (DOL)](http://dol-omg.org), extending those of [CASL](http://www.informatik.uni-bremen.de/cofi/index.php/CASL). However, Hets can also read other structuring constructs, like those of Haskell, Maude or OWL. All these are mapped to so-called development graphs and processed with a proof calculus for heterogeneous development graphs that allows to decompose global proof obligations into local ones (during this, Hets also needs to compute [colimits](http://en.wikipedia.org/wiki/Limit_%28category_theory%29#Colimits_2) of theories over the involved logics). Hets is based on a graph of logics and logic translations. The overall architecture is depicted below. Adding new logics and logic translations to Hets can be done with moderate effort by adding some Haskell code to the Hets source. With the [Latin](https://link.springer.com/chapter/10.1007/978-3-642-22673-1_24) project, this becomes much easier: logics (and in the near future also logic translations) can be declaratively specified in LF. +Hets also provides an implementation of the [H](http://imar.ro/~diacon/forver/forver.html) specification and verification language, allowing to develop Kripke semantics over an arbitrary logic. ![Architecture of the heterogeneous tool set Hets](https://github.com/spechub/attachment/raw/a0f26aadac374988f7bee3e191e95ca30e7be511/hets2010.png) diff --git a/RigidCASL/AS.der.hs b/RigidCASL/AS.der.hs new file mode 100644 index 0000000000..e69de29bb2 diff --git a/RigidCASL/AS_Rigid.der.hs b/RigidCASL/AS_Rigid.der.hs new file mode 100644 index 0000000000..9601f55d11 --- /dev/null +++ b/RigidCASL/AS_Rigid.der.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./RigidCASL/AS_Rigid.der.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +Abstract syntax for rigid extension of CASL +-} + +module RigidCASL.AS_Rigid where + +import Common.Id +import Common.AS_Annotation + +import CASL.AS_Basic_CASL +import CASL.Sign + +import Data.Data + +-- DrIFT command +{-! global: GetRange !-} + +type R_BASIC_SPEC = BASIC_SPEC () R_SIG_ITEM () + +data R_SIG_ITEM = + Rigid_sorts [Annoted (SORT_ITEM ())] Range + | Rigid_op_items [Annoted (OP_ITEM ())] Range + | Rigid_pred_items [Annoted (PRED_ITEM ())] Range + deriving (Show, Typeable, Data) + +data RigidSymbol = CSym Symbol | RSym Symbol + deriving (Show, Eq, Ord, Typeable, Data) diff --git a/RigidCASL/Logic_RigidCASL.hs b/RigidCASL/Logic_RigidCASL.hs new file mode 100644 index 0000000000..cc3031deb4 --- /dev/null +++ b/RigidCASL/Logic_RigidCASL.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{- | +Module : ./RigidCASL/Logic_RigidCASL.hs +Description : Instance of class Logic for rigid CASL +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + + +Instance of class Logic for rigid logic. +-} + +module RigidCASL.Logic_RigidCASL where + +import Logic.Logic +import RigidCASL.AS_Rigid +import RigidCASL.Sign +import RigidCASL.Morphism +import RigidCASL.ATC_RigidCASL () +import RigidCASL.Parse_AS () +import RigidCASL.Print_AS +import RigidCASL.StaticAna + +import CASL.Sign +import CASL.Formula(primFormula) +import CASL.StaticAna(convertCASLTheory, isNominalSen) +import CASL.Morphism +import CASL.AS_Basic_CASL +import CASL.Parse_AS_Basic +import CASL.SimplifySen +import CASL.ToDoc +import CASL.Logic_CASL () +import CASL.MapSentence +import CASL.SymbolMapAnalysis +import Common.Keywords (rigidS) + +import CASL.SymbolParser + +data RigidCASL = RigidCASL deriving Show + +instance Language RigidCASL where + description _ = "RigidCASL\n" ++ + "Extends CASL with rigid symbols." + +instance Syntax RigidCASL R_BASIC_SPEC RigidSymbol SYMB_ITEMS SYMB_MAP_ITEMS where + parse_basic_spec RigidCASL = Just $ basicSpec [rigidS] + parse_symb_items RigidCASL = Just . const $ symbItems [rigidS] -- this could be wrong! + parse_symb_map_items RigidCASL = Just . const $ symbMapItems [rigidS] + +-- Important convention: we use CASL syntax for quantifiers but variables are rigid! +-- This must be taken into account when writing translations. + +instance Sentences RigidCASL CASLFORMULA RSign RigidMor RigidSymbol where + map_sen RigidCASL m = return . mapSen (const id) (caslMor m) -- return . mapSen map_H_FORMULA h + sym_of RigidCASL = symOfRigid-- symOf -- this loses rigid symbols for now + symmap_of RigidCASL = undefined --morphismToSymbMap + sym_name RigidCASL = rigidSymName -- symName + extSymKind RigidCASL = rigidExtSymKind + simplify_sen RigidCASL = simplifyCASLSen + print_sign RigidCASL sig = printSign printRigidExt $ removeRigidDupl sig + print_named RigidCASL = printTheoryFormula + is_nominal_sen RigidCASL = isNominalSen + +instance StaticAnalysis RigidCASL R_BASIC_SPEC CASLFORMULA + SYMB_ITEMS SYMB_MAP_ITEMS + RSign + RigidMor + RigidSymbol RawSymbol where + basic_analysis RigidCASL = Just basicRigidAnalysis' -- was without ' + sen_analysis RigidCASL = Just rigidCASLsen_analysis + convertTheory RigidCASL = Just convertCASLTheory + add_noms_to_sign RigidCASL = addNomsToSign + stat_symb_map_items RigidCASL = statSymbMapItems + stat_symb_items RigidCASL = statSymbItems + signature_colimit RigidCASL = sigColim + signatureDiff RigidCASL s1 s2 = return $ diffSig diffRigidExt s1 s2 + symbol_to_raw RigidCASL = rigidSymToRaw -- symbolToRaw + raw_to_symbol RigidCASL = rigidRawToSymbol + raw_to_var RigidCASL = rawToVar + id_to_raw RigidCASL = idToRaw + matches RigidCASL = rigidMatches -- CASL.Morphism.matches + empty_signature RigidCASL = emptySign emptyRigidExt + add_symb_to_sign RigidCASL = rigidAddSymbToSign + signature_union RigidCASL s = return . addSig addRigidExt s + intersection RigidCASL s = return . interSig interRigidExt s + morphism_union RigidCASL = undefined --plainMorphismUnion (addSig addRigidExt) + final_union RigidCASL = undefined --finalUnion (addSig addRigidExt) + is_subsig RigidCASL = isSubSig isSubRigidExt + subsig_inclusion RigidCASL = sigInclusion emptyMorExt + cogenerated_sign RigidCASL = undefined --cogeneratedSign emptyMorExt + generated_sign RigidCASL = undefined -- generatedSign emptyMorExt + induced_from_morphism RigidCASL = inducedFromMorphism emptyMorExt + induced_from_to_morphism RigidCASL = undefined --inducedFromToMorphism + -- emptyMorExt isSubRigidExt diffRigidExt + theory_to_taxonomy RigidCASL = undefined --convTaxo + -- TODO: signature difference is missing! + +instance Logic RigidCASL () + R_BASIC_SPEC CASLFORMULA SYMB_ITEMS SYMB_MAP_ITEMS + RSign + RigidMor + RigidSymbol RawSymbol () where + stability _ = Experimental + empty_proof_tree _ = () + -- helpers for hybridization + constr_to_sens RigidCASL = rigidConstrToSens + parse_prim_formula RigidCASL = Just $ const (primFormula []) + -- for each type, its name and the file where it is defined + sublogicsTypeName RigidCASL = ("","") + basicSpecTypeName RigidCASL = ("R_BASIC_SPEC","RigidCASL.AS_Rigid") + sentenceTypeName RigidCASL = ("CASLFORMULA","CASL.AS_Basic_CASL") + symbItemsTypeName RigidCASL = ("SYMB_ITEMS","CASL.AS_Basic_CASL") + symbMapItemsTypeName RigidCASL = ("SYMB_MAP_ITEMS","CASL.AS_Basic_CASL") + signTypeName RigidCASL = ("RSign","RigidCASL.Sign") + morphismTypeName RigidCASL = ("RigidMor","RigidCASL.Morphism") + symbolTypeName RigidCASL = ("RigidSymbol","RigidCASL.AS_Rigid") + rawSymbolTypeName RigidCASL = ("RawSymbol","CASL.Morphism") + proofTreeTypeName RigidCASL = ("","") diff --git a/RigidCASL/Morphism.hs b/RigidCASL/Morphism.hs new file mode 100644 index 0000000000..95776852d3 --- /dev/null +++ b/RigidCASL/Morphism.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./RigidCASL/Morphism.hs +Description : Morphisms in RigidCASL +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.cm +Stability : experimental +Portability : portable + + Definition of morphisms for RigidCASL + +-} + +module RigidCASL.Morphism where + +import qualified CASL.Morphism as CMor +import RigidCASL.Sign + +type RigidMor = CMor.Morphism () RigidExt (CMor.DefMorExt RigidExt) + +caslMor :: RigidMor -> CMor.CASLMor +caslMor m = CMor.Morphism + (caslSign $ CMor.msource m) + (caslSign $ CMor.mtarget m) + (CMor.sort_map m) + (CMor.op_map m) + (CMor.pred_map m) + () + +toRigidMor :: CMor.CASLMor -> RigidExt -> RigidExt -> RigidMor +toRigidMor m extS extT = CMor.Morphism + (toRSign (CMor.msource m) extS) + (toRSign (CMor.mtarget m) extT) + (CMor.sort_map m) + (CMor.op_map m) + (CMor.pred_map m) + (CMor.DefMorExt emptyRigidExt) diff --git a/RigidCASL/Parse_AS.hs b/RigidCASL/Parse_AS.hs new file mode 100644 index 0000000000..250b0e8380 --- /dev/null +++ b/RigidCASL/Parse_AS.hs @@ -0,0 +1,34 @@ +{- | +Module : ./RigidCASL/Parse_AS.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +Parser for rigid extension of CASL +-} + +module RigidCASL.Parse_AS where + +import CASL.OpItem +import CASL.SortItem + +import Common.AnnoState +import Common.Keywords +import RigidCASL.AS_Rigid +import Text.ParserCombinators.Parsec + +parseRigid :: AParser st () +parseRigid = (asKey rigidS >> return ()) + +rigidSigItems :: AParser st R_SIG_ITEM +rigidSigItems = + do _r <- parseRigid + itemList hybrid_keywords sortS sortItem Rigid_sorts + <|> itemList hybrid_keywords opS opItem Rigid_op_items + <|> itemList hybrid_keywords predS predItem Rigid_pred_items + +instance AParsable R_SIG_ITEM where + aparser = rigidSigItems diff --git a/RigidCASL/Print_AS.hs b/RigidCASL/Print_AS.hs new file mode 100644 index 0000000000..c7e563adc8 --- /dev/null +++ b/RigidCASL/Print_AS.hs @@ -0,0 +1,64 @@ + +{- | +Module : ./RigidCASL/Print_AS.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +printing rigid declarations +-} + +module RigidCASL.Print_AS where + +import CASL.ToDoc +import qualified CASL.AS_Basic_CASL as CBasic + +import Common.Doc +import Common.DocUtils +import Common.Keywords +import qualified Common.Lib.MapSet as MapSet + +import RigidCASL.AS_Rigid +import RigidCASL.Sign +import qualified Data.Set as Set + +instance Pretty R_SIG_ITEM where + pretty (Rigid_sorts ls _) = + cat [keyword (rigidS ++ sortS ++ pluralS ls)] + pretty (Rigid_op_items ls _) = + cat [keyword (rigidS ++ opS ++ pluralS ls), + space <> semiAnnos pretty ls] + pretty (Rigid_pred_items ls _) = + cat [keyword (rigidS ++ predS ++ pluralS ls), + space <> semiAnnos pretty ls] + + +instance Pretty RigidSymbol where + pretty (CSym s) = pretty s + pretty (RSym s) = pretty s + +instance Pretty RigidExt where + pretty = printRigidExt + +printRigidSorts :: [CBasic.SORT] -> Doc +printRigidSorts xs = case xs of + [] -> empty + _ -> + keyword rigidS <+> + keyword (sortS ++ case xs of + [_] -> "" + _ -> "s") <+> + ppWithCommas xs + +printRigidExt :: RigidExt -> Doc +printRigidExt s = let + xs = Set.toList $ rigidSorts s + in printRigidSorts xs + $+$ + printSetMap (keyword rigidS <+> keyword opS) empty + (MapSet.toMap $ rigidOps s) + $+$ printSetMap (keyword rigidS <+> keyword predS) space + (MapSet.toMap $ rigidPreds s) diff --git a/RigidCASL/Sign.hs b/RigidCASL/Sign.hs new file mode 100644 index 0000000000..a2a6bd64af --- /dev/null +++ b/RigidCASL/Sign.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : ./RigidCASL/Sign.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +Signatures for hybrid logic, as extension of CASL signatures. +-} + +module RigidCASL.Sign where + +import CASL.Sign +import CASL.Morphism +import qualified CASL.AS_Basic_CASL as CBasic + +import qualified Common.Lib.MapSet as MapSet +import Common.Id +import Common.Result + +import Data.Data +import qualified Data.Set as Set +import qualified Common.Lib.Rel as Rel + +import RigidCASL.AS_Rigid + +data RigidExt = RigidExt + { rigidSorts :: Set.Set CBasic.SORT + , rigidOps :: OpMap + , rigidPreds :: PredMap + } deriving (Show, Eq, Ord, Typeable, Data) + +type RSign = Sign () RigidExt + +emptyRigidExt :: RigidExt +emptyRigidExt = RigidExt Set.empty MapSet.empty MapSet.empty + +addRigidExt :: RigidExt -> RigidExt -> RigidExt +addRigidExt a b = a + { rigidSorts = Set.union (rigidSorts a) $ rigidSorts b + , rigidOps = addOpMapSet (rigidOps a) $ rigidOps b + , rigidPreds = addMapSet (rigidPreds a) $ rigidPreds b + } + +interRigidExt :: RigidExt -> RigidExt -> RigidExt +interRigidExt a b = a + { rigidSorts = Set.intersection (rigidSorts a) $ rigidSorts b + , rigidOps = interOpMapSet (rigidOps a) $ rigidOps b + , rigidPreds = interMapSet (rigidPreds a) $ rigidPreds b + } + +diffRigidExt :: RigidExt -> RigidExt -> RigidExt +diffRigidExt a b = a + { rigidSorts = Set.difference (rigidSorts a) $ rigidSorts b + , rigidOps = diffOpMapSet (rigidOps a) $ rigidOps b + , rigidPreds = diffMapSet (rigidPreds a) $ rigidPreds b + } + +isSubRigidExt :: RigidExt -> RigidExt -> Bool +isSubRigidExt a b = + Set.isSubsetOf (rigidSorts a) (rigidSorts b) + && isSubOpMap (rigidOps a) (rigidOps b) + && isSubMap (rigidPreds a) (rigidPreds b) + +instance SignExtension RigidExt where + isSubSignExtension = isSubRigidExt + +caslSign :: RSign -> CASLSign +caslSign sig = Sign + { sortRel = sortRel sig + , revSortRel = revSortRel sig + , emptySortSet = emptySortSet sig + , opMap = opMap sig + , assocOps = assocOps sig + , predMap = predMap sig + , varMap = varMap sig + , sentences = sentences sig + , declaredSymbols = declaredSymbols sig + , envDiags = envDiags sig + , annoMap = annoMap sig + , globAnnos = globAnnos sig + , extendedInfo = () + } + +toRSign :: CASLSign -> RigidExt -> RSign +toRSign sig anExt = Sign + { sortRel = sortRel sig + , revSortRel = revSortRel sig + , emptySortSet = emptySortSet sig + , opMap = opMap sig + , assocOps = assocOps sig + , predMap = predMap sig + , varMap = varMap sig + , sentences = sentences sig + , declaredSymbols = declaredSymbols sig + , envDiags = envDiags sig + , annoMap = annoMap sig + , globAnnos = globAnnos sig + , extendedInfo = anExt + } + +removeRigidDupl :: RSign -> RSign +removeRigidDupl sig = + sig {sortRel = Rel.difference (Rel.transReduce $ sortRel sig) + . Rel.transReduce $ Rel.fromSet $ + Set.map (\x->(x,x)) $ rigidSorts $ extendedInfo sig, + opMap = diffOpMapSet (opMap sig) $ rigidOps $ extendedInfo sig, + predMap = diffMapSet (predMap sig) $ rigidPreds $ extendedInfo sig} + +symOfRigid :: RSign -> [Set.Set RigidSymbol] +symOfRigid rsig = + let + allSyms = symOf rsig + cSyms = Set.unions $ symOf $ removeRigidDupl rsig + in map (\sSet -> Set.map (\s -> if Set.member s cSyms then CSym s else RSym s) sSet ) allSyms + +rigidSymName :: RigidSymbol -> Id +rigidSymName (CSym s) = symName s +rigidSymName (RSym s) = symName s + +rigidExtSymKind :: RigidSymbol -> String +rigidExtSymKind (CSym s) = (extSymbolKind . symbType) s +rigidExtSymKind (RSym s) = "rigid " ++ (extSymbolKind . symbType) s + + +rigidSymToRaw :: RigidSymbol -> RawSymbol +rigidSymToRaw (CSym s) = symbolToRaw s +rigidSymToRaw (RSym s) = symbolToRaw s + +rigidRawToSymbol :: RawSymbol -> Maybe RigidSymbol +rigidRawToSymbol (ASymbol s) = Just $ CSym s -- TODO: this is a hack! +rigidRawToSymbol _ = Nothing + +rigidMatches :: RigidSymbol -> RawSymbol -> Bool +rigidMatches (CSym s) = matches s +rigidMatches (RSym s) = matches s + +rigidAddSymbToSign :: RSign -> RigidSymbol -> Result RSign +rigidAddSymbToSign rsig rsym = + case rsym of + CSym s -> do + bsig' <- addSymbToSign (caslSign rsig) s + return $ toRSign bsig' $ extendedInfo rsig + RSym _ -> error "nyi" + diff --git a/RigidCASL/StaticAna.hs b/RigidCASL/StaticAna.hs new file mode 100644 index 0000000000..b065156e0d --- /dev/null +++ b/RigidCASL/StaticAna.hs @@ -0,0 +1,315 @@ +{- | +Module : ./RigidCASL/StaticAna.hs +Copyright : (c) R. Diaconescu, IMAR, 2018 +License : GPLv2 or higher, see LICENSE.txt + +Maintainer : mscodescu@gmail.com +Stability : provisional +Portability : portable + +static analysis of rigid parts +-} + +module RigidCASL.StaticAna where + +import RigidCASL.AS_Rigid +import RigidCASL.Print_AS () +import RigidCASL.Sign +import RigidCASL.Morphism + +import CASL.Sign +import CASL.Morphism +import CASL.MixfixParser +import CASL.StaticAna +import CASL.AS_Basic_CASL +import CASL.Overload +import CASL.ColimSign +import CASL.Logic_CASL () + +import Common.AS_Annotation +import Common.GlobalAnnotations +import Common.Id +import Common.Result +import Common.ExtSign +import qualified Common.Lib.MapSet as MapSet +import Common.Lib.State +import qualified Common.Lib.Graph as Gr +import Data.Graph.Inductive.Graph + +import qualified Data.Set as Set +import Logic.SemConstr +import Data.List +import qualified Data.Map as Map + +basicRigidAnalysis + :: (R_BASIC_SPEC, RSign, GlobalAnnos) + -> Result (R_BASIC_SPEC, + ExtSign RSign Symbol, + [Named CASLFORMULA]) +basicRigidAnalysis = basicAnalysis typeAnaF anaRBasicItem anaRSigItem anaMix + +basicRigidAnalysis' + :: (R_BASIC_SPEC, RSign, GlobalAnnos) + -> Result (R_BASIC_SPEC, + ExtSign RSign RigidSymbol, + [Named CASLFORMULA]) +basicRigidAnalysis' (rbs, rsig, ga) = do + (rbs', ExtSign sig syms, nsens) <- basicAnalysis typeAnaF anaRBasicItem anaRSigItem anaMix (rbs, rsig, ga) + return (rbs', ExtSign sig (Set.map CSym syms), nsens) -- TODO: this is wrong but may do for now. Need to make rigid symbols rigid in ExtSign also + +typeAnaF :: Min () RigidExt +typeAnaF = const return + +anaRBasicItem :: Ana () () R_SIG_ITEM () RigidExt +anaRBasicItem = const return + +anaRSigItem :: Ana R_SIG_ITEM () R_SIG_ITEM () RigidExt +anaRSigItem mix ritem = do + sig <- get + case ritem of + Rigid_sorts al ps -> + do ul <- mapM (ana_SORT_ITEM typeAnaF mix NonEmptySorts) al + mapM_ (\aoi -> case item aoi of + Sort_decl sdecls _ -> + mapM_ (updateExtInfo . addRigidSort sig) sdecls + _ -> error "no subsorts or isos should be rigid") + ul + return $ Rigid_sorts ul ps + Rigid_op_items al ps -> + do ul <- mapM (ana_OP_ITEM typeAnaF mix) al + mapM_ (\ aoi -> case item aoi of + Op_decl ops ty _ _ -> + mapM_ (updateExtInfo . addRigidOp sig (toOpType ty)) ops + Op_defn i par _ _ -> maybe (return ()) + (\ ty -> updateExtInfo $ addRigidOp sig (toOpType ty) i) + $ headToType par) ul + return $ Rigid_op_items ul ps + Rigid_pred_items al ps -> + do ul <- mapM (ana_PRED_ITEM typeAnaF mix) al + mapM_ (\ aoi -> case item aoi of + Pred_decl ops ty _ -> + mapM_ (updateExtInfo . addRigidPred sig (toPredType ty)) ops + Pred_defn i (Pred_head args _) _ _ -> + updateExtInfo $ addRigidPred sig + (PredType $ sortsOfArgs args) i ) ul + return $ Rigid_pred_items ul ps + +addRigidSort :: Sign () RigidExt -> Id -> RigidExt -> Result RigidExt +addRigidSort sig i ext = + let rsorts = rigidSorts ext + ssorts = sortSet sig + extI = ext {rigidSorts = Set.insert i $ rigidSorts ext} + in + if Set.member i ssorts then Result [mkDiag Warning "redeclaring sort as rigid" i] $ Just extI + else + if Set.member i rsorts then Result [mkDiag Hint "repeated rigid sort" i] $ Just ext + else return extI + +addRigidOp :: Sign () RigidExt -> OpType -> Id -> RigidExt -> Result RigidExt +addRigidOp sig ty i ext = let + rops = rigidOps ext + ops = opMap sig + extI = ext {rigidOps = MapSet.insert i ty $ rigidOps ext} + in + if MapSet.member i ty ops then Result [mkDiag Warning "redeclaring op as rigid" i] $ Just extI + else + if MapSet.member i ty rops then Result [mkDiag Hint "repeated rigid op" i] $ Just ext + else return extI + + +addRigidPred :: Sign () RigidExt -> PredType -> Id -> RigidExt -> Result RigidExt +addRigidPred sig ty i ext = let + rpreds = rigidPreds ext + preds = predMap sig + extI = ext {rigidPreds = MapSet.insert i ty $ rigidPreds ext} + in + if MapSet.member i ty preds then Result [mkDiag Warning "redeclaring pred as rigid" i] $ Just extI + else if MapSet.member i ty rpreds then Result [mkDiag Hint "repeated rigid pred" i] $ Just ext + else return extI + +anaMix :: Mix () R_SIG_ITEM () RigidExt +anaMix = emptyMix + + + + {- Min f e -- ^ type analysis of f + -> Ana b b s f e -- ^ static analysis of basic item b + -> Ana s b s f e -- ^ static analysis of signature item s + -> Mix b s f e -- ^ for mixfix analysis + -> (BASIC_SPEC b s f, Sign f e, GlobalAnnos) + BASIC_SPEC () R_SIG_ITEM () + + b is () + s is R_SIG_ITEM + f is () + e is RigidExt + +type Ana a b s f e = Mix b s f e -> a -> State (Sign f e) a + + +-} + +-- | extra +rigidCASLsen_analysis :: + (R_BASIC_SPEC, RSign, FORMULA()) -> Result (FORMULA (), FORMULA ()) +rigidCASLsen_analysis (bs, s, f) = let + mix = emptyMix + allIds = getAllIds bs mix s + mix' = mix { mixRules = makeRules emptyGlobalAnnos + allIds } + in anaForm (const return) mix' (caslSign s) f + +sigColim :: Gr.Gr RSign (Int, RigidMor) + -> Result + (RSign, Map.Map Int RigidMor) +sigColim gr = do + let cgr = emap (\(i,m) -> (i, caslMor m)) $ nmap caslSign gr + (csig, cmors) = signColimit cgr extCASLColimit + sortExt = foldl (\aSet (i,iSig) -> Set.union + aSet $ + Set.map (\x -> let iMor = Map.findWithDefault (error "morphism not found") i cmors + in Map.findWithDefault x x $ sort_map iMor) + $ rigidSorts $ extendedInfo iSig ) Set.empty $ labNodes gr + opsExt = foldl (\aMap (i, iSig) -> let iMor = Map.findWithDefault (error "morphism not found") i cmors + sMap = sort_map iMor + oMap = op_map iMor + in + foldl (\f (sn,ot) -> MapSet.insert sn ot f) aMap $ + map (mapOpSym sMap oMap) $ + MapSet.toPairList $ rigidOps $ extendedInfo iSig + ) + MapSet.empty $ labNodes gr + predExt = foldl (\aMap (i, iSig) -> let iMor = Map.findWithDefault (error "morphism not found") i cmors + sMap = sort_map iMor + pMap = pred_map iMor + in foldl (\f (sn,ot) -> MapSet.insert sn ot f) aMap $ + map (mapPredSym sMap pMap) $ + MapSet.toPairList $ rigidPreds $ extendedInfo iSig + ) + MapSet.empty $ labNodes gr + rext = RigidExt sortExt opsExt predExt + rsign = toRSign csig rext + -- TODO: rigid ops, rigid preds, morphisms + return (rsign, Map.fromList $ + map (\(i, rsig) -> let iMor = Map.findWithDefault (error "morphism not found") i cmors + in (i, toRigidMor iMor (extendedInfo rsig) rext) + ) $ labNodes gr) + + +-- | CASL hybridization: constraints to CASL sentences + +rigidConstrToSens :: Sign () RigidExt -> String -> SemanticConstraint -> Result [Named (FORMULA ())] +rigidConstrToSens sig str sc = -- TODO: add a String argument so the error message is different for RigidCASL and CASL + let + st = genName $ "ST_" ++ str + domain = genName $ "domain_" ++ str + defined = genName "defined" + (totals, partials) = partition (\(_, ot) -> opKind ot == Total) $ MapSet.toPairList $ rigidOps $ extendedInfo sig + in + case sc of + {-SameInterpretation "sort" -> + return $ + map (\s -> makeNamed ("ga_sem_constr_"++show s) + $ mkForall [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st, + mkVarDecl (genToken "x") s] + $ mkEqv + (mkPredication (mkQualPred domain $ Pred_type [st, s] nullRange) + [Qual_var (genToken "w1") st nullRange, + Qual_var (genToken "x") s nullRange]) + (mkPredication (mkQualPred domain $ Pred_type [st, s] nullRange) + [Qual_var (genToken "w2") st nullRange, + Qual_var (genToken "x") s nullRange]) + ) + $ Set.toList $ sortSet sig-} + SameInterpretation "rigid sort" -> + return $ + map (\s -> makeNamed ("ga_sem_constr_"++show s) + $ mkForall [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st, + mkVarDecl (genToken "x") s] + $ mkEqv + (mkPredication (mkQualPred domain $ Pred_type [st, s] nullRange) + [Qual_var (genToken "w1") st nullRange, + Qual_var (genToken "x") s nullRange]) + (mkPredication (mkQualPred domain $ Pred_type [st, s] nullRange) + [Qual_var (genToken "w2") st nullRange, + Qual_var (genToken "x") s nullRange]) + ) + $ Set.toList $ rigidSorts $ extendedInfo sig + SameInterpretation "rigid const" -> error "nyi for rigid const" + SameInterpretation "rigid op" -> + let + xs ot = zip (opArgs ot) [1::Int ..] + extOt i ot = Qual_op_name i (Op_type Total (st:opArgs ot) (opRes ot) nullRange) nullRange + in return $ + map (\(i,ot) -> makeNamed ("ga_sem_constr_" ++ show i) + $ mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> mkVarDecl (genToken $ "x" ++ show ii) si) $ xs ot) + ) + $ mkStEq + (mkAppl (extOt i ot) $ map (\(a,b) -> mkVarTerm a b) $ (genToken "w1", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot)) + (mkAppl (extOt i ot) $ map (\(a,b) -> mkVarTerm a b) $ (genToken "w2", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot)) + ) totals + {-SameInterpretation "pred" -> + let + xs pt = zip (predArgs pt) [1::Int ..] + extPt (Pred_type ss r) = Pred_type (st:ss) r + in return $ + map (\(i, pt) -> makeNamed ("ga_sem_constr_" ++ show i) $ + mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> mkVarDecl (genToken $ "x" ++ show ii) si) $ xs pt) + ) + $ mkEqv (mkPredication (mkQualPred i $ extPt $ toPRED_TYPE pt) $ + map (\(a,b) -> mkVarTerm a b) $ (genToken "w1", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs pt)) + (mkPredication (mkQualPred i $ extPt $ toPRED_TYPE pt) $ + map (\(a,b) -> mkVarTerm a b) $ (genToken "w2", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs pt)) + ) $ MapSet.toPairList $ predMap sig -} + SameInterpretation "rigid pred" -> + let + xs pt = zip (predArgs pt) [1::Int ..] + extPt (Pred_type ss r) = Pred_type (st:ss) r + in return $ + map (\(i, pt) -> makeNamed ("ga_sem_constr_" ++ show i) $ + mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> mkVarDecl (genToken $ "x" ++ show ii) si) $ xs pt) + ) + $ mkEqv (mkPredication (mkQualPred i $ extPt $ toPRED_TYPE pt) $ + map (\(a,b) -> mkVarTerm a b) $ (genToken "w1", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs pt)) + (mkPredication (mkQualPred i $ extPt $ toPRED_TYPE pt) $ + map (\(a,b) -> mkVarTerm a b) $ (genToken "w2", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs pt)) + ) $ MapSet.toPairList $ rigidPreds $ extendedInfo sig + SameDomain True -> let + xs ot = zip (opArgs ot) [1::Int ..] + extOt i ot = Qual_op_name i (Op_type Total (st:opArgs ot) (opRes ot) nullRange) nullRange + in return $ + map (\(i,ot) -> makeNamed ("ga_sem_constr_" ++ show i) + $ mkForall + ( [mkVarDecl (genToken "w1") st, + mkVarDecl (genToken "w2") st] + ++ + (map (\(si, ii) -> mkVarDecl (genToken $ "x" ++ show ii) si) $ xs ot) + ) + $ mkEqv + (mkPredication (mkQualPred defined $ Pred_type [st, opRes ot] nullRange) $ + [mkVarTerm (genToken "w1") st, + mkAppl (extOt i ot) $ map (\(a,b) -> mkVarTerm a b) $ (genToken "w1", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot) + ] + ) + (mkPredication (mkQualPred defined $ Pred_type [st, opRes ot] nullRange) $ + [mkVarTerm (genToken "w2") st, + mkAppl (extOt i ot) $ map (\(a,b) -> mkVarTerm a b) $ (genToken "w2", st):(map (\(si, ii) -> (genToken $ "x" ++ show ii, si)) $ xs ot) + ] + ) + ) + partials + _ -> constrToSens (caslSign sig) str sc -- error $ "Constraint not supported for CASL logic:" ++ show sc diff --git a/Static/AnalysisLibrary.hs b/Static/AnalysisLibrary.hs index 51da37d35e..1dd95b6031 100644 --- a/Static/AnalysisLibrary.hs +++ b/Static/AnalysisLibrary.hs @@ -76,6 +76,8 @@ import System.FilePath import LF.Twelf2DG import Framework.Analysis +import GenHyb.WriteFile + import MMT.Hets2mmt (mmtRes) import Proofs.ComputeColimit @@ -569,9 +571,16 @@ anaLibItem lg opts topLns currLn libenv dg eo itm = Newlogic_defn ld _ -> ResultT $ do dg' <- anaLogicDef ld dg return $ Result [] $ Just (itm, dg', libenv, lg, eo) + Hlogic_defn hld _ -> ResultT $ do + (dg', lg') <- anaHLogicDef hld dg lg + --let lg' = lg {knownHybLogics = Map.insert (newHybridLogicName hld) (hld{isExtension = False}) $ knownHybLogics lg} + return $ Result [] $ Just (itm, dg', libenv, lg', eo) Newcomorphism_defn com _ -> ResultT $ do dg' <- anaComorphismDef com dg return $ Result [] $ Just (itm, dg', libenv, lg, eo) + Hcom_defn hcd _ -> ResultT $ do + dg' <- anaHComDef hcd dg lg + return $ Result [] $ Just (itm, dg', libenv, lg, eo) _ -> return (itm, dg, libenv, lg, eo) symbolsOf :: LogicGraph -> G_sign -> G_sign -> [CORRESPONDENCE] diff --git a/Static/AnalysisStructured.hs b/Static/AnalysisStructured.hs index a2c99ccfb1..e696d93946 100644 --- a/Static/AnalysisStructured.hs +++ b/Static/AnalysisStructured.hs @@ -622,6 +622,15 @@ anaSpecAux conser addSyms optNodes lg (replaceAnnoted sp1' asp1) (replaceAnnoted sp2' asp2) pos, nsig3, udg3) + HSpec hln bs hs pos -> adjustPos pos $ do + hl@(Logic hlid) <- lookupLogic "anaSpec" (show hln) lg + case data_logic hlid of + Nothing -> error $ "expected a hybrid logic, but got " ++ show hlid + Just dl -> do + let dSpec = emptyAnno $ (Spec_inst bs [] Nothing nullRange) + hAsDataSpec = Data dl hl dSpec hs nullRange + anaSpecAux conser addSyms optNodes (setCurLogic (show hln) lg) + libEnv ln dg nsig name opts eo hAsDataSpec rg Combination (Network cItems eItems _) pos -> adjustPos pos $ do let (cNodes', cEdges') = networkDiagram dg cItems eItems (ns, dg') <- insertColimitInGraph libEnv ln dg cNodes' cEdges' name diff --git a/Static/DevGraph.hs b/Static/DevGraph.hs index ea9bffc1e5..1462d39963 100644 --- a/Static/DevGraph.hs +++ b/Static/DevGraph.hs @@ -1374,12 +1374,11 @@ compareLinks l1 l2 = if eqDGLinkLabContent l1 { dgl_id = defaultEdgeId } l2 {- | tries to insert a labeled edge into a given DG, but if this edge already exists, then does nothing. -} insLEdgeNubDG :: LEdge DGLinkLab -> DGraph -> DGraph -insLEdgeNubDG (v, w, l) g = +insLEdgeNubDG (v, w, l) g = let oldEdgeId = getNewEdgeId g (ng, change) = Tree.insLEdge False compareLinks (v, w, l { dgl_id = oldEdgeId }) $ dgBody g - in - g { getNewEdgeId = if change then incEdgeId oldEdgeId else oldEdgeId + in g { getNewEdgeId = if change then incEdgeId oldEdgeId else oldEdgeId , dgBody = ng } {- | inserts a new edge into the DGraph using it's own edgeId. diff --git a/Syntax/AS_Library.der.hs b/Syntax/AS_Library.der.hs index 5a8d050886..0429bac644 100644 --- a/Syntax/AS_Library.der.hs +++ b/Syntax/AS_Library.der.hs @@ -29,6 +29,7 @@ import Data.Typeable import Logic.Grothendieck import Logic.Logic +import Logic.HDef import Syntax.AS_Architecture import Syntax.AS_Structured @@ -82,6 +83,10 @@ data LIB_ITEM = Spec_defn SPEC_NAME GENERICITY (Annoted SPEC) Range -- pos: "newlogic", Logic_name, "=", opt "end" | Newcomorphism_defn ComorphismDef Range -- pos: "newcomorphism", Comorphism_name, "=", opt "end" + | Hlogic_defn HLogicDef Range + -- pos: "newhlogic", Logic_name, "=", opt "end" + | Hcom_defn HComDef Range + -- pos: "newhcomorphism", Comorphism_name, "=", opt "end" deriving (Show, Typeable) data AlignSem = SingleDomain | GlobalDomain | ContextualizedDomain diff --git a/Syntax/AS_Structured.der.hs b/Syntax/AS_Structured.der.hs index f8b2cc376f..183fac6fa2 100644 --- a/Syntax/AS_Structured.der.hs +++ b/Syntax/AS_Structured.der.hs @@ -75,6 +75,8 @@ data SPEC = Basic_spec G_basic_spec Range -- pos: "combine" | Apply IRI G_basic_spec Range -- pos: "apply", use a basic spec parser to parse a sentence + | HSpec Id SPEC_NAME (Annoted SPEC) Range + -- logic name, name of the spec in data part, spec in hybrid part deriving (Show, Typeable) data Network = Network [LABELED_ONTO_OR_INTPR_REF] [IRI] Range diff --git a/Syntax/Parse_AS_Library.hs b/Syntax/Parse_AS_Library.hs index de14abf5fd..01a4a4a9d1 100644 --- a/Syntax/Parse_AS_Library.hs +++ b/Syntax/Parse_AS_Library.hs @@ -16,6 +16,8 @@ Parser for DOL documents module Syntax.Parse_AS_Library (library) where import Logic.Grothendieck +import Logic.SemConstr +import Logic.HDef import Syntax.AS_Structured import Syntax.AS_Library import Syntax.Parse_AS_Structured @@ -42,6 +44,8 @@ import qualified Control.Monad.Fail as Fail import Framework.AS +import Debug.Trace + lGAnnos :: LogicGraph -> AParser st (LogicGraph, [Annotation]) lGAnnos lG = do as <- annos @@ -296,6 +300,35 @@ libItem l = specDefn l q <- optEnd return (Newlogic_defn (LogicDef n ml s m f p pa) (catRange ([s1, s2, s3, s4, s5, s6, s7, s8] ++ maybeToList q))) + <|> -- newhlogic + do (n, s1) <- newhlogicP + s2 <- equalT + (Logic_name ln msubln _, b, s3) <- baselogicP l <|> hlogicP l + let msubln' = case msubln of + Nothing -> Nothing + Just tok -> Just $ tokStr tok + _ <- dotT + (semcs, _) <- do + asKey constrS + _ <- colonT + constrs <- constrP `separatedBy` commaT + _ <- dotT + return constrs + <|> + return ([], []) + (lvars,_) <- do + asKey quantS + _ <- colonT + --_ <- oParenT + vars <- varP `separatedBy` commaT + _ <- dotT -- cParenT + return vars + <|> + return ([],[]) + q <- optEnd + let newHL = (Hlogic_defn (HLogicDef (show n) (ln, msubln') b (concat semcs) lvars) + (catRange $ [s1, s2, s3] ++ maybeToList q)) + trace ("newHL:" ++ show newHL) $ return newHL <|> -- newcomorphism do (n, s1) <- newcomorphismP s2 <- equalT @@ -308,6 +341,14 @@ libItem l = specDefn l q <- optEnd return (Newcomorphism_defn (ComorphismDef n ml s t sv pv mv) (catRange ([s1, s2, s3, s4, s5, s6, s7, s8] ++ maybeToList q))) + <|> --newhcomorphism + do (n, s1) <- newhcomorphismP + s2 <- equalT + (baseCom, _) <- basecomP + (sourceH, _) <- sourceHLogicP + q <- optEnd + let newHCom = Hcom_defn (HComDef n baseCom sourceH) $ catRange $ [s1, s2] ++ maybeToList q + trace ("newHCom:" ++ show newHCom) $ return newHCom <|> -- just a spec (turned into "spec spec = sp") do p1 <- getPos a <- aSpec l @@ -430,12 +471,121 @@ imports l = do (sps, ps) <- separatedBy (annoParser $ groupSpec l) anComma return (sps, catRange (s : ps)) +newhlogicP :: AParser st (IRI, Token) +newhlogicP = do + s <- asKey newhlogicS + n <- simpleId + return (simpleIdToIRI n, s) + +baselogicP :: LogicGraph -> AParser st (Logic_name, Bool, Token) +baselogicP lg = do + s <- asKey baselogicS + _ <- colonT + ln <- logicName lg + return (ln, False, s) + +newhcomorphismP :: AParser st (String, Token) +newhcomorphismP = do + s <- asKey hcomS + n <- simpleId + return (show n, s) + +basecomP :: AParser st (String, Token) +basecomP = do + s <- asKey basecomS + _ <- colonT + n <- simpleId + return (show n, s) + +sourceHLogicP :: AParser st (String, Token) +sourceHLogicP = do + s <- asKey sourceHLogicS + _ <- colonT + n <- simpleId + return (show n, s) + +hlogicP :: LogicGraph -> AParser st (Logic_name, Bool, Token) +hlogicP lg = do + s <- asKey hlogicS + _ <- colonT + ln <- logicName lg + return (ln, True, s) + newlogicP :: AParser st (IRI, Token) newlogicP = do s <- asKey newlogicS n <- simpleId return (simpleIdToIRI n, s) +constrP :: AParser st [SemanticConstraint] +constrP = do + _ <- asKey reflexiveS + return [ReflexiveMod] + <|> do + _ <- asKey transitiveS + return [TransitiveMod] + <|> do + _ <- asKey symmetricS + return [SymmetricMod] + <|> do + _ <- asKey serialS + return [SerialMod] + <|> do + _ <- asKey euclideanS + return [EuclideanMod] + <|> do + _ <- asKey functionalConstrS + return [FunctionalMod] + <|> do + _ <- asKey linearS + return [LinearMod] + <|> do + _ <- asKey totalS + return [TotalMod] + <|> do + _ <- asKey sameInterpretationS + _ <- oParenT + (s, _) <- (scanAnyWords `separatedBy` skip) `separatedBy` commaT + _ <- cParenT + return $ map (\x -> SameInterpretation $ concat $ intersperse " " $ fst x ) s + <|> do + _ <- asKey sameDomainS + _ <- oParenT + s <- do + i1 <- simpleId + s2 <- do + _ <- skip + i2 <- simpleId + return $ show i2 + <|> do + return "" + return $ if null s2 then show i1 else show i1 ++ " " ++ s2 + _ <- cParenT + case s of + "partial" -> return $ [SameDomain False] + "rigid partial" -> return $ [SameDomain True] + _ -> error $ "unknown same domain contraint:" ++ show s + +varP :: AParser st (String, Maybe Token) +varP = {- do + (s, _) <- simpleId `separatedBy` skip + return (concat $ map show s, Nothing) + <|> -} do + s1 <- simpleId + (tailStr, mt) <- do + _s <- doubleColonT + s2 <- simpleId + return $ ("", Just s2) + <|> do + _ <- skip + (s, _) <- simpleId `separatedBy` skip + let strs = intersperse " " $ map show s + return (concat strs, Nothing) + <|> do + return ("", Nothing) + if show s1 == "rigid" then return (tailStr, mt) + else return (show s1 ++ (if null tailStr then "" else " " ++ tailStr), mt) + metaP :: AParser st (FRAM, Token) metaP = do s <- asKey metaS diff --git a/Syntax/Parse_AS_Structured.hs b/Syntax/Parse_AS_Structured.hs index 7039cab34c..564413bbcf 100644 --- a/Syntax/Parse_AS_Structured.hs +++ b/Syntax/Parse_AS_Structured.hs @@ -30,6 +30,7 @@ module Syntax.Parse_AS_Structured , restriction , hetIRI , parseNetwork + , logicName ) where import Logic.Logic @@ -445,6 +446,17 @@ specD l = do specE :: LogicGraph -> AParser st SPEC specE l = logicSpec l <|> combineSpec l + <|> do + _ <- asKey "hlogic" + _ <- colonT + ln <- simpleId + _ <- asKey "data" + _ <- colonT + bs <- hetIRI l + _ <- asKey "configuration" + _ <- colonT + sp <- annoParser $ specD $ setCurLogic (show ln) l + return $ HSpec (simpleIdToId ln) bs sp nullRange <|> (lookAhead (groupSpecLookhead l) >> groupSpec l) <|> (lookupCurrentSyntax "basic spec" l >>= basicSpec l) diff --git a/Syntax/Print_AS_Library.hs b/Syntax/Print_AS_Library.hs index 43f8481177..844a67c771 100644 --- a/Syntax/Print_AS_Library.hs +++ b/Syntax/Print_AS_Library.hs @@ -160,7 +160,9 @@ instance PrettyLG LIB_ITEM where fsep ((pretty l <+> keyword getS) : prettyDownloadItems ab) Logic_decl aa _ -> pretty aa Newlogic_defn nl _ -> pretty nl + Hlogic_defn nl _ -> pretty nl Newcomorphism_defn nc _ -> pretty nc + Hcom_defn nc _ -> pretty nc instance PrettyLG OmsOrNetwork where prettyLG lg s = case s of diff --git a/Syntax/Print_AS_Structured.hs b/Syntax/Print_AS_Structured.hs index f85f7ec772..aab7f8c05c 100644 --- a/Syntax/Print_AS_Structured.hs +++ b/Syntax/Print_AS_Structured.hs @@ -120,6 +120,7 @@ printSPEC lg spec = case spec of sep [keyword "apply" <+> pretty i, prettyLG lg $ Basic_spec bs nullRange] Bridge s1 rs s2 _ -> fsep $ [condBraces lg s1, keyword "bridge"] ++ map pretty rs ++ [condBraces lg s2] + HSpec _ _ _ _ -> empty instance Pretty Network where pretty (Network cs es _) = fsep $ ppWithCommas cs diff --git a/TopHybrid/Logic_TopHybrid.hs b/TopHybrid/Logic_TopHybrid.hs index 8a116b7b3e..eb838519b0 100644 --- a/TopHybrid/Logic_TopHybrid.hs +++ b/TopHybrid/Logic_TopHybrid.hs @@ -26,6 +26,8 @@ import CASL.Morphism import CASL.AS_Basic_CASL import CASL.Sign +import Common.Result + -- Import of logics import CASL.Logic_CASL import Propositional.Logic_Propositional @@ -68,7 +70,10 @@ instance StaticAnalysis Hybridize Spc_Wrap Frm_Wrap SYMB_ITEMS SYMB_MAP_ITEMS Sgn_Wrap Mor Symbol RawSymbol where basic_analysis Hybridize = Just thAna empty_signature Hybridize = emptyHybridSign - sen_analysis Hybridize = Just anaForm' + sen_analysis Hybridize = Just $ \(bsp, sig, sen) -> let Result d s = anaForm' (bsp, sig, sen) + in case s of + Nothing -> Result d Nothing + Just x -> Result d $ Just (x, x) stat_symb_map_items Hybridize = error "stat_symb_map_items !" stat_symb_items Hybridize = error "stat_symb_items !" signature_colimit Hybridize = error "signature_colimit !" diff --git a/TopHybrid/StatAna.hs b/TopHybrid/StatAna.hs index 0210bf1a15..f40600932b 100644 --- a/TopHybrid/StatAna.hs +++ b/TopHybrid/StatAna.hs @@ -191,7 +191,10 @@ unsafeToSig _ = unsafeCoerce type associated with l. -} undFormAna :: (StaticAnalysis l bs sen si smi sign mor symb raw) => l -> a -> b -> bs -> Result sen -undFormAna l a b c = (maybeE 4 $ sen_analysis l) (c, a', b') +undFormAna l a b c = let Result df mx = (maybeE 4 $ sen_analysis l) (c, a', b') + in case mx of + Nothing -> Result df Nothing + Just (s, _) -> Result df $ Just s where a' = unsafeToSig l a b' = unsafeToForm l b diff --git a/doc/UserGuide.tex b/doc/UserGuide.tex index ab2e061e7d..a0af70b529 100644 --- a/doc/UserGuide.tex +++ b/doc/UserGuide.tex @@ -456,6 +456,16 @@ \section{Logics supported by Hets} logic need to be declared at source code level. Currently, the hybridised versions of the following logics may be used in a fully automatic way: Propositional, CASL, CoCASL, and any other logic already hybridised. + +\item[RigidCASL] is an extension of \CASL with markers for rigidity of symbols. +This is needed in hybridisation. + +\item[HPAR] is the hybridisation of RigidCASL used in the main example of \cite{DBLP:journals/mscs/DiaconescuM16}. Unlike HybridCASL, it features quantification on nominals. + +\item[GenHyb] is the Hets implementation of the H method\footnote{See \url{http://imar.ro/~diacon/forver/forver.html}} +of hybridisation of arbitrary institutions and of institution comorphisms \cite{DBLP:journals/lu/Diaconescu20}. It is a more recent implementation than Hybrid and it allows to specify the parameters of the hybridisation method. Hets analyses these parameters and generates source code. +The new logic or logic translation is made available after a recompilation of the Hets sources. Details about the Hets implementation can be found in +\cite{DBLP:conf/calco/Codescu19}. \end{description} Various logics are supported with proof tools. Proof support for the diff --git a/doc/hets.bib b/doc/hets.bib index 88a42a9eac..2d8e0f0a68 100644 --- a/doc/hets.bib +++ b/doc/hets.bib @@ -18,6 +18,57 @@ @book{Sannella12 bibsource = {DBLP, http://dblp.uni-trier.de} } +@inproceedings{DBLP:conf/calco/Codescu19, + author = {Mihai Codescu}, + editor = {Markus Roggenbach and + Ana Sokolova}, + title = {Hybridisation of Institutions in {HETS} (Tool Paper)}, + booktitle = {8th Conference on Algebra and Coalgebra in Computer Science, {CALCO} + 2019, June 3-6, 2019, London, United Kingdom}, + series = {LIPIcs}, + volume = {139}, + pages = {17:1--17:10}, + publisher = {Schloss Dagstuhl - Leibniz-Zentrum f{\"{u}}r Informatik}, + year = {2019}, + url = {https://doi.org/10.4230/LIPIcs.CALCO.2019.17}, + doi = {10.4230/LIPIcs.CALCO.2019.17}, + timestamp = {Thu, 19 Dec 2019 09:27:29 +0100}, + biburl = {https://dblp.org/rec/conf/calco/Codescu19.bib}, + bibsource = {dblp computer science bibliography, https://dblp.org} +} + +@article{DBLP:journals/lu/Diaconescu20, + author = {Razvan Diaconescu}, + title = {Introducing \emph{H}, an Institution-Based Formal Specification and + Verification Language}, + journal = {Logica Universalis}, + volume = {14}, + number = {2}, + pages = {259--277}, + year = {2020}, + url = {https://doi.org/10.1007/s11787-020-00249-y}, + doi = {10.1007/s11787-020-00249-y}, + timestamp = {Fri, 10 Jul 2020 17:23:18 +0200}, + biburl = {https://dblp.org/rec/journals/lu/Diaconescu20.bib}, + bibsource = {dblp computer science bibliography, https://dblp.org} +} + +@article{DBLP:journals/mscs/DiaconescuM16, + author = {Razvan Diaconescu and + Alexandre Madeira}, + title = {Encoding hybridized institutions into first-order logic}, + journal = {Math. Struct. Comput. Sci.}, + volume = {26}, + number = {5}, + pages = {745--788}, + year = {2016}, + url = {https://doi.org/10.1017/S0960129514000383}, + doi = {10.1017/S0960129514000383}, + timestamp = {Wed, 01 Apr 2020 08:48:40 +0200}, + biburl = {https://dblp.org/rec/journals/mscs/DiaconescuM16.bib}, + bibsource = {dblp computer science bibliography, https://dblp.org} +} + @unpublished{HasCASL/Summary, author = {L. Schr\"oder and T. Mossakowski and C. Maeder}, title = {{\HasCASL} -- {I}ntegrated functional specification and programming. {L}anguage Summary},