From 48895581378353743e51bae6cbbe60bf31b7b8e3 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Fri, 1 Feb 2008 22:01:10 +0000
Subject: [PATCH] added some new pattern forms, incl. pattern macros, to
 testgf3

---
 src/GF/Devel/Compile/CheckGrammar.hs | 17 ++++++++++++++---
 src/GF/Devel/Compile/GF.cf           |  9 ++++++++-
 src/GF/Devel/Compile/GFtoGFCC.hs     |  3 ++-
 src/GF/Devel/Compile/Rename.hs       | 10 ++++++++++
 src/GF/Devel/Compile/SourceToGF.hs   | 11 +++++++++--
 src/GF/Devel/Grammar/GFtoSource.hs   |  6 ++++++
 src/GF/Devel/Grammar/Grammar.hs      |  8 ++++++++
 src/GF/Devel/Grammar/Lookup.hs       |  1 +
 src/GF/Devel/Grammar/Macros.hs       |  4 ++++
 src/GF/Devel/Grammar/PatternMatch.hs |  4 ++++
 10 files changed, 66 insertions(+), 7 deletions(-)

diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs
index 55f499d38..5038c5168 100644
--- a/src/GF/Devel/Compile/CheckGrammar.hs
+++ b/src/GF/Devel/Compile/CheckGrammar.hs
@@ -577,6 +577,12 @@ inferLType gr trm = case trm of
 ---     checkIfComplexVariantType trm ty
      check trm ty
 
+   EPattType ty -> do
+     ty' <- justCheck ty typeType
+     return (ty',typeType)
+   EPatt p -> do
+     ty <- inferPatt p
+     return (trm, EPattType ty)
    _ -> prtFail "cannot infer lintype of" trm
 
  where
@@ -612,20 +618,25 @@ inferLType gr trm = case trm of
      PString _ -> True
      PInt _ -> True
      PFloat _ -> True
-     PSeq p q -> isConstPatt p && isConstPatt q
-     PAlt p q -> isConstPatt p && isConstPatt q
+     PSeq p q -> isConstPatt p || isConstPatt q
+     PAlt p q -> isConstPatt p || isConstPatt q
      PRep p -> isConstPatt p
      PNeg p -> isConstPatt p
      PAs _ p -> isConstPatt p
+     PChar -> True
+     PChars _ -> True
      _ -> False
 
    inferPatt p = case p of
-     PP q c ps | q /= cPredef -> checkErr $ lookupOperType gr q c >>= return . snd . prodForm
+     PP q c ps | q /= cPredef -> 
+       checkErr $ lookupOperType gr q c >>= return . snd . prodForm
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
      PSeq _ _ -> return $ typeStr
      PRep _   -> return $ typeStr
+     PChar    -> return $ typeStr
+     PChars _ -> return $ typeStr
      _ -> infer (patt2term p) >>= return . snd
 
 
diff --git a/src/GF/Devel/Compile/GF.cf b/src/GF/Devel/Compile/GF.cf
index 2de298ace..a0ce1ebb7 100644
--- a/src/GF/Devel/Compile/GF.cf
+++ b/src/GF/Devel/Compile/GF.cf
@@ -164,7 +164,10 @@ EVTable.   Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
 ECase.     Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
 EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
 EPre.      Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
-EStrs.     Exp4 ::= "strs" "{" [Exp] "}" ;
+EStrs.     Exp4 ::= "strs" "{" [Exp] "}" ; --%
+
+EPatt.     Exp4 ::= "pattern" Patt2 ;
+EPattType. Exp4 ::= "pattern" "type" Exp5 ;
 
 ESelect.   Exp3 ::= Exp3 "!" Exp4 ;
 ETupTyp.   Exp3 ::= Exp3 "*" Exp4 ;
@@ -195,6 +198,10 @@ ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
 
 -- patterns
 
+PChar.  Patt2  ::= "?" ;
+PChars. Patt2  ::= "[" String "]" ;
+PMacro. Patt2  ::= "#" PIdent ;
+PM.     Patt2  ::= "#" PIdent "." PIdent ;
 PW.     Patt2  ::= "_" ;
 PV.     Patt2  ::= PIdent ;
 PCon.   Patt2  ::= "{" PIdent "}" ; --%
diff --git a/src/GF/Devel/Compile/GFtoGFCC.hs b/src/GF/Devel/Compile/GFtoGFCC.hs
index 2d11e960f..81f33e11a 100644
--- a/src/GF/Devel/Compile/GFtoGFCC.hs
+++ b/src/GF/Devel/Compile/GFtoGFCC.hs
@@ -78,7 +78,7 @@ canon2gfcc opts pars cgr =
   -- concretes
   cncs  = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
   mkConcr lang0 lang mo = 
-      (lang,D.Concr flags lins opers lincats lindefs printnames params)
+      (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
     where
       js = listJudgements mo
       flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)]
@@ -96,6 +96,7 @@ canon2gfcc opts pars cgr =
                      (c,ju) <- js, elem (jform ju) [JLincat,JLin]]
       params = Map.fromAscList 
         [(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ??
+      fcfg = Nothing
 
 i2i :: Ident -> CId
 i2i = CId . prIdent
diff --git a/src/GF/Devel/Compile/Rename.hs b/src/GF/Devel/Compile/Rename.hs
index b6d44c7ed..9ba704c19 100644
--- a/src/GF/Devel/Compile/Rename.hs
+++ b/src/GF/Devel/Compile/Rename.hs
@@ -132,6 +132,10 @@ renameTerm env vars = ren vars where
             Ok t -> return t                              -- const proj last
             _ -> prtBad "unknown qualified constant" trm
 
+    EPatt p -> do
+      (p',_) <- renpatt p
+      return $ EPatt p'
+
     _ -> composOp (ren vs) trm
 
   renid = renameIdentTerm env
@@ -145,6 +149,12 @@ renameTerm env vars = ren vars where
 renamePattern :: RenameEnv -> Patt -> Err (Patt,[Ident])
 renamePattern env patt = case patt of
 
+  PMacro c -> do
+    c' <- renid $ Vr c
+    case c' of
+      Q p d -> renp $ PM p d
+      _ -> prtBad "unresolved pattern" patt
+
   PC c ps -> do
     c' <- renid $ Vr c
     case c' of
diff --git a/src/GF/Devel/Compile/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs
index 5e7d8dc9e..f501fd609 100644
--- a/src/GF/Devel/Compile/SourceToGF.hs
+++ b/src/GF/Devel/Compile/SourceToGF.hs
@@ -393,10 +393,10 @@ transExp x = case x of
           ETupTyp x y -> tups x ++ [y] -- right-associative parsing
           _ -> [t]
     es <- mapM transExp $ tups x
-    return $ G.RecType $ [] ---- M.tuple2recordType es
+    return $ G.RecType $ M.tuple2recordType es
   ETuple tuplecomps  -> do
     es <- mapM transExp [e | TComp e <- tuplecomps]
-    return $ G.R $  [] ---- M.tuple2record es
+    return $ G.R $ M.tuple2record es
   EProj exp id  -> liftM2 G.P (transExp exp) (trLabel id)
   EApp exp0 exp  -> liftM2 G.App (transExp exp0) (transExp exp)
   ETable cases  -> liftM (G.T G.TRaw) (transCases cases)
@@ -437,6 +437,9 @@ transExp x = case x of
   ELetb defs exp -> transExp $ ELet defs exp
   EWhere exp defs -> transExp $ ELet defs exp
 
+  EPattType typ -> liftM G.EPattType (transExp typ)
+  EPatt patt -> liftM G.EPatt (transPatt patt)
+
   ELString (LString str) -> return $ G.K str 
 ----  ELin id -> liftM G.LiT $ transIdent id
 
@@ -503,6 +506,10 @@ transSort x = case x of
 
 transPatt :: Patt -> Err G.Patt
 transPatt x = case x of
+  PChar -> return G.PChar
+  PChars s -> return $ G.PChars s
+  PMacro c -> liftM G.PMacro $ transIdent c
+  PM m c   -> liftM2 G.PM (transIdent m) (transIdent c)
   PW  -> return wildPatt
   PV (PIdent (_,"_"))  -> return wildPatt
   PV id  -> liftM G.PV $ transIdent id
diff --git a/src/GF/Devel/Grammar/GFtoSource.hs b/src/GF/Devel/Grammar/GFtoSource.hs
index 6618eaa20..9cd491e3d 100644
--- a/src/GF/Devel/Grammar/GFtoSource.hs
+++ b/src/GF/Devel/Grammar/GFtoSource.hs
@@ -162,6 +162,9 @@ trt trm = case trm of
     EInt i -> P.EInt i
     EFloat i -> P.EFloat i
 
+    EPatt p -> P.EPatt (trp p)
+    EPattType t -> P.EPattType (trt t)
+
     Glue a b -> P.EGlue (trt a) (trt b)
     Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
     FV ts -> P.EVariants $ map trt ts
@@ -170,6 +173,9 @@ trt trm = case trm of
 
 trp :: Patt -> P.Patt
 trp p = case p of
+    PChar -> P.PChar
+    PChars s -> P.PChars s
+    PM m c -> P.PM (tri m) (tri c)
     PW -> P.PW
     PV s | isWildIdent s -> P.PW
     PV s -> P.PV $ tri s
diff --git a/src/GF/Devel/Grammar/Grammar.hs b/src/GF/Devel/Grammar/Grammar.hs
index eb6d2218a..09bcfb2ae 100644
--- a/src/GF/Devel/Grammar/Grammar.hs
+++ b/src/GF/Devel/Grammar/Grammar.hs
@@ -105,6 +105,9 @@ data Term =
  | C Term Term          -- ^ concatenation: @s ++ t@
  | Glue Term Term       -- ^ agglutination: @s + t@
 
+ | EPatt Patt
+ | EPattType Term
+
  | FV [Term]            -- ^ free variation: @variants { s ; ... }@
 
  | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@
@@ -130,6 +133,11 @@ 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 String          -- ^ list of characters
+
+ | PMacro Ident           -- 
+ | PM Ident Ident
 
   deriving (Read, Show, Eq, Ord)
 
diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs
index 94021cb7d..876d60d26 100644
--- a/src/GF/Devel/Grammar/Lookup.hs
+++ b/src/GF/Devel/Grammar/Lookup.hs
@@ -91,6 +91,7 @@ allParamValues cnc ptyp = case ptyp of
        return [EInt i | i <- [0..n]]
      QC p c -> lookupParamValues cnc p c
      Q  p c -> lookupParamValues cnc p c ----
+
      RecType r -> do
        let (ls,tys) = unzip $ sortByFst r
        tss <- mapM allPV tys
diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs
index 71e7fdde5..e28859416 100644
--- a/src/GF/Devel/Grammar/Macros.hs
+++ b/src/GF/Devel/Grammar/Macros.hs
@@ -287,6 +287,10 @@ composOp co trm = case trm of
      tts' <- mapM (pairM co) tts
      return $ Overload tts'
 
+   EPattType ty -> 
+     do ty' <- co ty
+        return (EPattType ty')
+
    _ -> return trm -- covers K, Vr, Cn, Sort
 
 
diff --git a/src/GF/Devel/Grammar/PatternMatch.hs b/src/GF/Devel/Grammar/PatternMatch.hs
index 076aaa25a..ec64d7802 100644
--- a/src/GF/Devel/Grammar/PatternMatch.hs
+++ b/src/GF/Devel/Grammar/PatternMatch.hs
@@ -114,6 +114,10 @@ tryMatch (p,t) = do
            [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
 
 eqStrIdent = (==) ----