From 973a0cacb7c2f68dfed29ff0dc355fdcebfef3ae Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Thu, 18 Mar 2010 20:21:57 +0000
Subject: pattern @ should be propagated to PGF

---
 src/runtime/haskell/PGF/Binary.hs | 18 ++++++++++--------
 src/runtime/haskell/PGF/Expr.hs   |  4 ++++
 2 files changed, 14 insertions(+), 8 deletions(-)

(limited to 'src/runtime/haskell/PGF')

diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 424eabe71..d03349fc7 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -125,18 +125,20 @@ instance Binary Expr where
 instance Binary Patt where
   put (PApp f ps)  = putWord8 0 >> put (f,ps)
   put (PVar   x)   = putWord8 1 >> put x
-  put PWild        = putWord8 2
-  put (PLit l)     = putWord8 3 >> put l
-  put (PImplArg p) = putWord8 4 >> put p
-  put (PTilde p)   = putWord8 5 >> put p
+  put (PAs x p)    = putWord8 2 >> put (x,p)
+  put PWild        = putWord8 3
+  put (PLit l)     = putWord8 4 >> put l
+  put (PImplArg p) = putWord8 5 >> put p
+  put (PTilde p)   = putWord8 6 >> put p
   get = do tag <- getWord8
            case tag of
              0 -> liftM2 PApp get get
              1 -> liftM  PVar get
-             2 -> return PWild
-             3 -> liftM  PLit get
-             4 -> liftM  PImplArg get
-             5 -> liftM  PTilde get
+             2 -> liftM2 PAs get get
+             3 -> return PWild
+             4 -> liftM  PLit get
+             5 -> liftM  PImplArg get
+             6 -> liftM  PTilde get
              _ -> decodingError
 
 instance Binary Equation where
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index e23f4d672..25d04a621 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -66,6 +66,7 @@ data Patt =
    PApp CId [Patt]                  -- ^ application. The identifier should be constructor i.e. defined with 'data'
  | PLit Literal                     -- ^ literal
  | PVar CId                         -- ^ variable
+ | PAs  CId Patt                    -- ^ variable@pattern
  | PWild                            -- ^ wildcard
  | PImplArg Patt                    -- ^ implicit argument in pattern
  | PTilde Expr
@@ -229,6 +230,7 @@ ppPatt d scope (PApp f ps)  = let ds = List.map (ppPatt 2 scope) ps
                               in ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)
 ppPatt d scope (PLit l)     = ppLit l
 ppPatt d scope (PVar f)     = ppCId f
+ppPatt d scope (PAs x p)    = ppCId x PP.<> PP.char '@' PP.<> ppPatt 3 scope p
 ppPatt d scope PWild        = PP.char '_'
 ppPatt d scope (PImplArg p) = PP.braces (ppPatt 0 scope p)
 ppPatt d scope (PTilde e)   = PP.char '~' PP.<> ppExpr 6 scope e
@@ -237,6 +239,7 @@ pattScope :: [CId] -> Patt -> [CId]
 pattScope scope (PApp f ps)  = foldl pattScope scope ps
 pattScope scope (PLit l)     = scope
 pattScope scope (PVar f)     = f:scope
+pattScope scope (PAs x p)    = pattScope (x:scope) p
 pattScope scope PWild        = scope
 pattScope scope (PImplArg p) = pattScope scope p                               
 pattScope scope (PTilde e)   = scope
@@ -363,6 +366,7 @@ match sig f eqs as0 =
     tryMatches eqs (p:ps) (a:as) res env = tryMatch p a env
       where
         tryMatch (PVar x     ) (v                ) env            = tryMatches eqs  ps        as  res (v:env)
+        tryMatch (PAs  x p   ) (v                ) env            = tryMatch p v (v:env)
         tryMatch (PWild      ) (_                ) env            = tryMatches eqs  ps        as  res env
         tryMatch (p          ) (VMeta i envi vs  ) env            = VSusp i envi vs (\v -> tryMatch p v env)
         tryMatch (p          ) (VGen  i vs       ) env            = VConst f as0
-- 
cgit v1.2.3