Support @ patterns as in Haskell

compiler/Gen/Cases.hs

@@ -59,13 +59,16 @@ matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
 matchVar (v:vs) cs def = match vs (map subVar cs) def
   where
     subVar (p:ps, ce@(L t s e)) =
-        let loc = L t s in
-        (ps, case p of
-               PVar x     -> L t s $ subst x (Var v) e
-               PAnything  -> ce
-               PRecord fs ->
-                   loc $ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
-        )
+        let
+          loc = L t s
+          subOnePattern (PVar x)      = subst x (Var v) e
+          subOnePattern (PAtVar x p)  = 
+            subst x (Var v) e
+          subOnePattern PAnything     = e
+          subOnePattern (PRecord fs)  =
+            foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
+        in
+         (ps, L t s $ subOnePattern p)
 
 matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
 matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

compiler/Model/Ast.hs

@@ -8,7 +8,7 @@ import Types.Types
 import qualified Text.Pandoc as Pandoc
 import Data.Data
 
-data Module = Module [String] Exports Imports [Statement]
+data Module = Module [String] Exports Imports [Statement] deriving (Show)
 
 type Exports = [String]
 
@@ -19,6 +19,7 @@ data ImportMethod = As String | Importing [String] | Hiding [String]
 
 data Pattern = PData String [Pattern]
              | PRecord [String]
+             | PAtVar String Pattern
              | PVar String
              | PAnything
                deriving (Eq, Data, Typeable)
@@ -82,6 +83,7 @@ instance Show Pattern where
    case p of
      PRecord fs -> brkt (intercalate ", " fs)
      PVar x -> x
+     PAtVar x p -> x ++ "@(" ++ show p ++ ")"
      PAnything -> "_"
      PData "Cons" [hd@(PData "Cons" _),tl] ->
         parens (show hd) ++ " :: " ++ show tl

compiler/Parse/Parser.hs

@@ -13,7 +13,6 @@ import Parse.Types
 import Parse.Modules
 import Parse.Foreign
 
-
 statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
     where defs = map ((:[]) <$>) [ foreignDef, datatype ]
 

compiler/Parse/Patterns.hs

@@ -19,6 +19,13 @@ patternBasic =
                 return $ if isUpper c then PData x [] else PVar x
            ]
 
+patternMaybeAtVar :: Pattern -> IParser Pattern
+patternMaybeAtVar (PVar x) =
+  (char '@' >>
+   PAtVar x <$> patternExpr) <|>
+  ({- empty -} return $ PVar x)
+patternMaybeAtVar x = return x
+
 patternRecord :: IParser Pattern
 patternRecord = PRecord <$> brackets (commaSep1 lowVar)
 
@@ -30,7 +37,8 @@ patternList :: IParser Pattern
 patternList = plist <$> braces (commaSep patternExpr)
 
 patternTerm :: IParser Pattern
-patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]
+patternTerm = choice [ patternRecord, patternTuple, patternList,
+                       patternMaybeAtVar =<< patternBasic ]
            <?> "pattern"
 
 patternConstructor :: IParser Pattern
@@ -53,6 +61,10 @@ extract pattern body@(L t s _) =
   case pattern of
     PAnything -> return $ fn "_" body
     PVar x -> return $ fn x body
+    PAtVar x PAnything -> return $ fn x body
+    PAtVar x p -> do
+      (x', body') <- extract p body
+      return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
     PData name ps -> do
         x <- guid
         let a = '_' : show x
@@ -97,6 +109,10 @@ matchSingle pat exp@(L t s _) p =
     PVar x ->
         return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
 
+    PAtVar x p' -> do
+        subPat <- matchSingle p' (loc $ Var x) p'
+        return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
+      
     PRecord fs -> do
         a <- (\x -> '_' : show x) `liftM` guid
         let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

compiler/Transform/Rename.hs

@@ -130,6 +130,10 @@ patternExtend pattern env =
     case pattern of
       PAnything -> return (PAnything, env)
       PVar x -> first PVar `liftM` extend env x
+      PAtVar x p -> do
+        (x', env') <- extend env x
+        (p', env'') <- patternExtend p env'
+        return (PAtVar x' p', env'')
       PData name ps ->
           first (PData name . reverse) `liftM` foldM f ([], env) ps
                  where f (rps,env') p = do (rp,env'') <- patternExtend p env'

compiler/Transform/Replace.hs

@@ -33,6 +33,7 @@ patternVars pattern =
     case pattern of
       PData _ ps -> unions (map patternVars ps)
       PVar x -> singleton x
+      PAtVar _ p -> patternVars p
       PAnything -> empty
 
 depth :: Expr -> Integer

compiler/Types/Constrain.hs

@@ -259,6 +259,15 @@ patternGen loc tipe as pattern =
       b <- beta
       let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
       return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )
+    PAtVar v p -> do
+      b <- beta
+      let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
+      (as', cs', tipe') <- patternGen loc b as p
+      return (Map.delete v as',
+              cs' `Set.union`
+              (Set.fromList $ (loc (b :=: tipe)):(loc (b :=: tipe')):cs),
+              b)
+      
     PData name ps -> do
       constr <- guid
       output <- beta

compiler/Types/Substitutions.hs

@@ -39,7 +39,10 @@ instance Subst Scheme where
 instance Subst Constraint where
   subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2
   subst ss (t :<: super) = subst ss t :<: super
-  subst ss (x :<<: poly) = x :<<: subst ss poly
+  subst ss (x :<<: poly) = (case lookup x ss of
+                               Just (VarT y) -> y
+                               _ -> x
+                           ) :<<: subst ss poly
 
 instance Subst a => Subst (Located a) where
   subst ss (L str span c) = L str span (subst ss c)