putting pattern macros in place (not properly tested yet)

3 files changed, 30 insertions, 5 deletions

diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index 45b3da84b..95fdce611 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -158,6 +158,9 @@ data Term =
  | C Term Term    -- ^ concatenation: @s ++ t@
  | Glue Term Term -- ^ agglutination: @s + t@
 
+ | EPatt Patt     -- ^ pattern (in macro definition): # p
+ | EPattType Term -- ^ pattern type: pattern T
+
  | FV [Term]      -- ^ alternatives in free variation: @variants { s ; ... }@
 
  | Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
@@ -190,8 +193,10 @@ data Patt =
  | PAlt Patt Patt         -- ^ disjunctive pattern: p1 | p2
  | PSeq Patt Patt         -- ^ sequence of token parts: p + q
  | PRep Patt              -- ^ repetition of token part: p*
- | PChar                  -- ^ string of length one
- | PChars [Char]          -- ^ character list
+ | PChar                  -- ^ string of length one: ?
+ | PChars [Char]          -- ^ character list: ["aeiou"]
+ | PMacro Ident           -- #p
+ | PM Ident Ident         -- #m.p
 
   deriving (Read, Show, Eq, Ord)
 
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 8e3332b12..7a48e7c3a 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -503,6 +503,10 @@ term2patt trm = case termForm trm of
   Ok ([], QC p c, aa) -> do
     aa' <- mapM term2patt aa
     return (PP p c aa')
+
+  Ok ([], Q p c, []) -> do
+    return (PM p c)
+
   Ok ([], R r, []) -> do
     let (ll,aa) = unzipR r
     aa' <- mapM term2patt aa
@@ -523,6 +527,8 @@ term2patt trm = case termForm trm of
     return (PRep a')
   Ok ([], Cn (IC "?"), []) -> do
     return PChar
+  Ok ([], Cn (IC "[]"),[K s]) -> do
+    return $ PChars s
   Ok ([], Cn (IC "+"), [a,b]) -> do
     a' <- term2patt a
     b' <- term2patt b
@@ -532,6 +538,8 @@ term2patt trm = case termForm trm of
     b' <- term2patt b
     return (PAlt a' b')
 
+  Ok ([], Cn c, []) -> do
+    return (PMacro c)
 
   _ -> prtBad "no pattern corresponds to term" trm
 
@@ -540,8 +548,12 @@ patt2term pt = case pt of
   PV x      -> Vr x
   PW        -> Vr wildIdent             --- not parsable, should not occur
   PVal t i  -> Val t i
+  PMacro c  -> Cn c
+  PM p c    -> Q p c
+
   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
   PInt i    -> EInt i
@@ -550,6 +562,7 @@ patt2term pt = case pt of
 
   PAs x p   -> appc "@" [Vr x, patt2term p]            --- an encoding
   PChar     -> appc "?" []                             --- an encoding
+  PChars s  -> appc "[]" [K s]                         --- 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
@@ -731,7 +744,12 @@ composOp co trm =
         return (Alts (t',aa'))
    FV ts -> mapM co ts >>= return . FV
    Strs tt -> mapM co tt >>= return . Strs
-   _ -> return trm -- covers K, Vr, Cn, Sort
+
+   EPattType ty -> 
+     do ty' <- co ty
+        return (EPattType ty')
+
+   _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
 
 getTableType :: TInfo -> Err Type
 getTableType i = case i of
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 4b69c3ffd..b96d35b93 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -111,13 +111,15 @@ tryMatch (p,t) = do
          matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
          return (concat matches)
 
-      (PChar, ([],K [_],[])) -> return []
-
       (PRep p1, ([],K s, [])) -> checks [
          trym (foldr (const (PSeq p1)) (PString "") 
            [1..n]) t' | n <- [0 .. length s]
         ] >>
         return []
+
+      (PChar,  ([],K [_], [])) -> return []
+      (PChars cs, ([],K [c], [])) | elem c cs -> return []
+
       _ -> prtBad "no match in case expr for" t
   
 isInConstantForm :: Term -> Bool