added some new pattern forms, incl. pattern macros, to testgf3

5 files changed, 43 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