regex patterns for tokens

5 files changed, 65 insertions, 6 deletions

diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index 26409ce27..a25f6f98f 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/src/GF/Grammar/Compute.hs
@@ -304,6 +304,13 @@ computeTermOpt rec gr = comp where
        PP _ _ ps -> concatMap contP ps
        PT _ p -> contP p
        PR rs -> concatMap (contP . snd) rs
+
+       PAs x p -> (x,Vr x) : contP p
+
+       PSeq p q -> concatMap contP [p,q]
+       PAlt p q -> concatMap contP [p,q]
+       PRep p   -> contP p
+
        _ -> []
 
      prawitz g i f cs e = do
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index 4a983abcc..7be13a0d9 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -171,6 +171,14 @@ data Patt =
  | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
  | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
  | PT Type Patt           -- ^ type-annotated pattern
+
+ | PAs Ident Patt         -- ^ as-pattern: x@p
+
+ -- regular expression patterns
+ | PAlt Patt Patt         -- ^ disjunctive pattern: p1 | p2
+ | PSeq Patt Patt         -- ^ sequence of token parts
+ | PRep Patt              -- ^ repetition of token part
+
   deriving (Read, Show, Eq, Ord)
 
 -- | to guide computation and type checking of tables
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index dc4f790fd..bc394b143 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -504,6 +504,24 @@ term2patt trm = case termForm trm of
   Ok ([],EInt i,[]) -> return $ PInt i
   Ok ([],EFloat i,[]) -> return $ PFloat i
   Ok ([],K s,   []) -> return $ PString s
+
+--- encodings due to excessive use of term-patt convs. AR 7/1/2005
+  Ok ([], Cn (IC "@"), [Vr a,b]) -> do
+    b' <- term2patt b
+    return (PAs a b')
+  Ok ([], Cn (IC "*"), [a]) -> do
+    a' <- term2patt a
+    return (PRep a')
+  Ok ([], Cn (IC "+"), [a,b]) -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PSeq a' b')
+  Ok ([], Cn (IC "|"), [a,b]) -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PAlt a' b')
+
+
   _ -> prtBad "no pattern corresponds to term" trm
 
 patt2term :: Patt -> Term
@@ -513,11 +531,17 @@ patt2term pt = case pt of
   PC c pp   -> mkApp (Con c) (map patt2term pp)
   PP p c pp -> mkApp (QC p c) (map patt2term pp)
   PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
-  PT _ p    ->  patt2term p
+  PT _ p    -> patt2term p
   PInt i    -> EInt i
   PFloat i  -> EFloat i
   PString s -> K s 
 
+  PAs x p   -> appc "@" [Vr x, patt2term p]            --- an encoding
+  PSeq a b  -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
+  PAlt a b  -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
+  PRep a    -> appc "*" [(patt2term a)]                --- an encoding
+
+
 redirectTerm :: Ident -> Term -> Term
 redirectTerm n t = case t of
   QC _ f -> QC n f
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index b996efa0a..4e3feb5dc 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -67,11 +67,6 @@ tryMatch (p,t) = do
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
 
-      (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
-         let cuts = [splitAt n s | n <- [0 .. length s]] 
-         matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
-         return (concat matches)
-
       (PP q p pp, ([], QC r f, tt)) | 
             -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
             p `eqStrIdent` f && length pp == length tt ->
@@ -91,6 +86,24 @@ tryMatch (p,t) = do
             return (concat matches)
       (PT _ p',_) -> trym p' t'
       (_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
+
+--      (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
+
+      (PAs x p',_) -> do
+         subst <- trym p' t'
+         return $ (x,t) : subst
+
+      (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
+
+      (PSeq p1 p2, ([],K s, [])) -> do
+         let cuts = [splitAt n s | n <- [0 .. length s]] 
+         matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
+         return (concat matches)
+
+      (PRep p1, ([],K s, [])) -> checks [
+        trym (foldr (const (PSeq p1)) (PString "") [0..n]) t' | n <- [1 .. length s]
+        ]
+
       _ -> prtBad "no match in case expr for" t
   
 isInConstantForm :: Term -> Bool
diff --git a/src/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs
index a9bccbb1d..045fccfc0 100644
--- a/src/GF/Grammar/Refresh.hs
+++ b/src/GF/Grammar/Refresh.hs
@@ -71,6 +71,13 @@ refreshPatt p = case p of
   PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
   PR r    -> liftM PR     (mapPairsM refreshPatt r)
   PT t p' -> liftM2 PT    (refresh t) (refreshPatt p')
+
+  PAs x p'   -> liftM2 PAs     (refVar x) (refreshPatt p')
+
+  PSeq p' q' -> liftM2 PSeq    (refreshPatt p') (refreshPatt q')
+  PAlt p' q' -> liftM2 PAlt    (refreshPatt p') (refreshPatt q')
+  PRep p'    -> liftM  PRep    (refreshPatt p')
+
   _ -> return p
 
 refreshRecord r = case r of