From 7508fa578551672711fcec8c4b37d79c3a3de5ef Mon Sep 17 00:00:00 2001
From: aarne <aarne@chalmers.se>
Date: Mon, 18 May 2009 15:01:18 +0000
Subject: [PATCH] pattern macros: oper f : pattern T = # p ; used as #f in
 patterns

---
 Makefile                       |  2 +-
 src/GF/Compile/CheckGrammar.hs |  4 ++--
 src/GF/Compile/Compute.hs      | 27 ++++++++++++++++++++++-----
 src/GF/Grammar/Parser.y        |  2 ++
 4 files changed, 27 insertions(+), 8 deletions(-)

diff --git a/Makefile b/Makefile
index 418c2e61d..fc71558d7 100644
--- a/Makefile
+++ b/Makefile
@@ -24,4 +24,4 @@ sdist:
 gf:
 	runghc Setup.hs build rgl-none
 	strip dist/build/gf/gf
-	mv dist/build/gf/gf bin
+
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 8ecba39f8..3aa200a35 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -563,7 +563,7 @@ inferLType gr trm = case trm of
      t'  <- justCheck t typeStr
      aa' <- flip mapM aa (\ (c,v) -> do
         c' <- justCheck c typeStr 
-        v' <- justCheck v typeStrs
+        v' <- checks $ map (justCheck v) [typeStrs, EPattType typeStr]
         return (c',v'))
      return (Alts (t',aa'), typeStr)
 
@@ -607,7 +607,7 @@ inferLType gr trm = case trm of
 
    EPattType ty -> do
      ty' <- justCheck ty typeType
-     return (ty',typeType)
+     return (EPattType ty',typeType)
    EPatt p -> do
      ty <- inferPatt p
      return (trm, EPattType ty)
diff --git a/src/GF/Compile/Compute.hs b/src/GF/Compile/Compute.hs
index d9fb8c12b..dc7b51071 100644
--- a/src/GF/Compile/Compute.hs
+++ b/src/GF/Compile/Compute.hs
@@ -33,7 +33,7 @@ import GF.Grammar.AppPredefined
 import Data.List (nub,intersperse)
 import Control.Monad (liftM2, liftM)
 
-----import Debug.Trace ----
+---- import Debug.Trace ----
 
 -- | computation of concrete syntax terms into normal form
 -- used mainly for partial evaluation
@@ -186,9 +186,10 @@ computeTermOpt rec gr = comput True where
            r <- composOp (comp g) t
            returnC r
 
-     Alts _ -> do
-       r <- composOp (comp g) t
-       returnC r
+     Alts (d,aa) -> do
+       d' <- comp g d
+       aa' <- mapM (compInAlts g) aa
+       returnC (Alts (d',aa'))
 
      -- remove empty
      C a b    -> do
@@ -363,7 +364,10 @@ computeTermOpt rec gr = comput True where
 ----               return $ V ptyp ts -- to save space, just course of values
                return $ T (TComp ptyp) (zip ps' ts)
              _ -> do
-               cs' <- mapM (compBranch g) cs
+               ps0  <- mapM (compPatternMacro . fst) cs
+               cs'  <- mapM (compBranch g) (zip ps0 (map snd cs))
+
+----               cs' <- mapM (compBranch g) cs
                return $ T i cs'  -- happens with variable types
          _ -> comp g t
 
@@ -399,6 +403,19 @@ computeTermOpt rec gr = comput True where
        cs' <- mapM (comp g) [(f v) | v <- cs]
        return $ S (V i cs') e
 
+     compInAlts g (v,c) = do
+       v' <- comp g v
+       c' <- comp g c
+       c2 <- case c' of
+         EPatt p -> liftM Strs $ getPatts p
+         _ -> return c'
+       return (v',c2)
+      where
+       getPatts p = case p of
+         PAlt a b  -> liftM2 (++) (getPatts a) (getPatts b)
+         PString s -> return [K s]
+         _ -> fail $ "not valid pattern in pre expression" +++ prt p
+
 {- ----
      uncurrySelect g fs t v = do
        ts <- mapM (allParamValues gr . snd) fs
diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y
index 136480799..fbdb541b4 100644
--- a/src/GF/Grammar/Parser.y
+++ b/src/GF/Grammar/Parser.y
@@ -736,6 +736,8 @@ mkAlts cs = case cs of
        return $ Strs $ as ++ bs
      PString s -> return $ Strs [K s]
      PV x -> return (Vr x) --- for macros; not yet complete
+     PMacro x -> return (Vr x) --- for macros; not yet complete
+     PM m c -> return (Q m c) --- for macros; not yet complete
      _ -> fail "no strs from pattern"
 
 }