diff options
| author | krasimir <krasimir@chalmers.se> | 2010-03-18 20:21:57 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2010-03-18 20:21:57 +0000 |
| commit | 973a0cacb7c2f68dfed29ff0dc355fdcebfef3ae (patch) | |
| tree | 58dea973e689443e4ede77e5390add85eeaf2c13 /src/runtime | |
| parent | 985bb550c0b0c02b5e9c29b53e4f19d859b58dc2 (diff) | |
pattern @ should be propagated to PGF
Diffstat (limited to 'src/runtime')
| -rw-r--r-- | src/runtime/haskell/PGF/Binary.hs | 18 | ||||
| -rw-r--r-- | src/runtime/haskell/PGF/Expr.hs | 4 |
2 files changed, 14 insertions, 8 deletions
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
|