From 38376083b271a31ef2b169b91b395000a9c7ede6 Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 16 Mar 2006 21:26:22 +0000 Subject: [PATCH] MatchTerm: testing conditions on terms, e.g. nodup --- src/GF/Shell/HelpFile.hs | 14 ++++++---- src/GF/UseGrammar/Custom.hs | 3 ++ src/GF/UseGrammar/MatchTerm.hs | 50 ++++++++++++++++++++++++++++++++++ src/HelpFile | 14 ++++++---- 4 files changed, 69 insertions(+), 12 deletions(-) create mode 100644 src/GF/UseGrammar/MatchTerm.hs diff --git a/src/GF/Shell/HelpFile.hs b/src/GF/Shell/HelpFile.hs index 7c9133417..702bba5e9 100644 --- a/src/GF/Shell/HelpFile.hs +++ b/src/GF/Shell/HelpFile.hs @@ -655,12 +655,14 @@ txtHelpFile = "\n-startcat, like -cat, but used in grammars (to avoid clash with keyword cat)" ++ "\n" ++ "\n-transform, transformation performed on a syntax tree. The default is identity." ++ - "\n -transform=identity no change" ++ - "\n -transform=compute compute by using definitions in the grammar" ++ - "\n -transform=typecheck return the term only if it is type-correct" ++ - "\n -transform=solve solve metavariables as derived refinements" ++ - "\n -transform=context solve metavariables by unique refinements as variables" ++ - "\n -transform=delete replace the term by metavariable" ++ + "\n -transform=identity no change" ++ + "\n -transform=compute compute by using definitions in the grammar" ++ + "\n -transform=nodup return the term only if it has no constants duplicated" ++ + "\n -transform=nodupatom return the term only if it has no atomic constants duplicated" ++ + "\n -transform=typecheck return the term only if it is type-correct" ++ + "\n -transform=solve solve metavariables as derived refinements" ++ + "\n -transform=context solve metavariables by unique refinements as variables" ++ + "\n -transform=delete replace the term by metavariable" ++ "\n" ++ "\n-unlexer, untokenization transforming linearization output into a string." ++ "\n The default is unwords." ++ diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 4400c2585..efaa1abeb 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -39,6 +39,7 @@ import qualified GF.Grammar.MMacros as MM import GF.Grammar.AbsCompute import GF.Grammar.TypeCheck import GF.UseGrammar.Generate +import GF.UseGrammar.MatchTerm import GF.UseGrammar.Linear (unoptimizeCanon) ------import Compile import GF.Compile.ShellState @@ -373,6 +374,8 @@ customTermCommand = ,(strCI "compute", \g t -> let gr = grammar g in err (const [t]) return (exp2termCommand gr (computeAbsTerm gr) t)) + ,(strCI "nodup", \_ t -> if (hasDupIdent $ tree2exp t) then [] else [t]) + ,(strCI "nodupatom", \_ t -> if (hasDupAtom $ tree2exp t) then [] else [t]) ,(strCI "paraphrase", \g t -> let gr = grammar g in exp2termlistCommand gr (mkParaphrases gr) t) diff --git a/src/GF/UseGrammar/MatchTerm.hs b/src/GF/UseGrammar/MatchTerm.hs new file mode 100644 index 000000000..9acffd44c --- /dev/null +++ b/src/GF/UseGrammar/MatchTerm.hs @@ -0,0 +1,50 @@ +---------------------------------------------------------------------- +-- | +-- Module : MatchTerm +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- +-- functions for matching with terms. AR 16/3/2006 +----------------------------------------------------------------------------- + +module GF.UseGrammar.MatchTerm where + +import GF.Data.Operations +import GF.Data.Zipper + +import GF.Grammar.Grammar +import GF.Grammar.PrGrammar +import GF.Infra.Ident +import GF.Grammar.Values +import GF.Grammar.Macros +import GF.Grammar.MMacros + +import Control.Monad +import Data.List + +-- test if a term has duplicated idents, either any or just atoms + +hasDupIdent, hasDupAtom :: Exp -> Bool +hasDupIdent = (>1) . maximum . map length . group . sort . allConstants True +hasDupAtom = (>1) . maximum . map length . group . sort . allConstants False + +-- test if a certain ident occurs in term + +grepIdent :: Ident -> Exp -> Bool +grepIdent c = elem c . allConstants True + +-- form the list of all constants, optionally ignoring all but atoms + +allConstants :: Bool -> Exp -> [Ident] +allConstants alsoApp = err (const []) snd . flip appSTM [] . collect where + collect e = case e of + Q _ c -> add c e + QC _ c -> add c e + Cn c -> add c e + App f a | not alsoApp -> case f of + App g b -> collect b >> collect a + _ -> collect a + _ -> composOp collect e + add c e = updateSTM (c:) >> return e diff --git a/src/HelpFile b/src/HelpFile index 58c4c1262..38b4fdcb2 100644 --- a/src/HelpFile +++ b/src/HelpFile @@ -626,12 +626,14 @@ q, quit: q -startcat, like -cat, but used in grammars (to avoid clash with keyword cat) -transform, transformation performed on a syntax tree. The default is identity. - -transform=identity no change - -transform=compute compute by using definitions in the grammar - -transform=typecheck return the term only if it is type-correct - -transform=solve solve metavariables as derived refinements - -transform=context solve metavariables by unique refinements as variables - -transform=delete replace the term by metavariable + -transform=identity no change + -transform=compute compute by using definitions in the grammar + -transform=nodup return the term only if it has no constants duplicated + -transform=nodupatom return the term only if it has no atomic constants duplicated + -transform=typecheck return the term only if it is type-correct + -transform=solve solve metavariables as derived refinements + -transform=context solve metavariables by unique refinements as variables + -transform=delete replace the term by metavariable -unlexer, untokenization transforming linearization output into a string. The default is unwords.