enable to use match-all including multi clause

Author: kotapiku

hs-src/Interpreter/egison.hs

@@ -221,7 +221,7 @@ printHelp = do
   putStrLn ""
   putStrLn "Options to change input or output format:"
   putStrLn "  --tsv, -T                  Input and output in tsv format"
-  putStrLn "  --field, -F int            Specify a field type of input tsv"
+  putStrLn "  --field, -F field          Specify a field type of input tsv"
   putStrLn "  --math, -M (asciimath|latex|mathematica)"
   putStrLn "                             Output in AsciiMath, LaTeX, or Mathematica format (only for interpreter)"
   exitWith ExitSuccess

hs-src/Language/Egison/Core.hs

@@ -545,11 +545,10 @@ evalExpr env (IoExpr expr) = do
         Tuple [_, val'] -> return $ Value val'
     _ -> throwError $ TypeMismatch "io" io
 
-evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do
+evalExpr env (MatchAllExpr target matcher clauses) = do
   target <- evalExpr env target
   matcher <- evalExpr env matcher >>= evalMatcherWHNF
-  result <- patternMatch env pattern target matcher
-  mmap (flip evalExpr expr . extendEnv env) result >>= fromMList
+  f matcher target >>= fromMList
  where
   fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData
   fromMList MNil = return . Value $ Collection Sq.empty
@@ -558,6 +557,11 @@ evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do
     tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)
     seqRef <- liftIO . newIORef $ Sq.fromList [head, tail]
     return . Intermediate $ ICollection $ seqRef
+  f matcher target = do
+      let tryMatchClause (pattern, expr) results = do
+            result <- patternMatch env pattern target matcher
+            mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results
+      mfoldr tryMatchClause (return MNil) (fromList clauses)
 
 evalExpr env (MatchExpr target matcher clauses) = do
   target <- evalExpr env target

hs-src/Language/Egison/Desugar.hs

@@ -128,9 +128,9 @@ desugar (AlgebraicDataMatcherExpr patterns) = do
       matchingFailure :: EgisonExpr
       matchingFailure = CollectionExpr []
 
-desugar (MatchAllLambdaExpr matcher clause) = do
+desugar (MatchAllLambdaExpr matcher clauses) = do
   name <- fresh
-  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr $ stringToVar name) matcher clause)
+  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr $ stringToVar name) matcher clauses)
 
 desugar (MatchLambdaExpr matcher clauses) = do
   name <- fresh
@@ -304,11 +304,11 @@ desugar (MatchExpr expr0 expr1 clauses) = do
   clauses' <- desugarMatchClauses clauses
   return (MatchExpr expr0' expr1' clauses')
 
-desugar (MatchAllExpr expr0 expr1 clause) = do
+desugar (MatchAllExpr expr0 expr1 clauses) = do
   expr0' <- desugar expr0
   expr1' <- desugar expr1
-  clause' <- desugarMatchClause clause
-  return $ MatchAllExpr expr0' expr1' clause'
+  clauses' <- desugarMatchClauses clauses
+  return $ MatchAllExpr expr0' expr1' clauses'
 
 desugar (DoExpr binds expr) = do
   binds' <- desugarBindings binds

hs-src/Language/Egison/Parser.hs

@@ -318,13 +318,13 @@ quoteSymbolExpr :: Parser EgisonExpr
 quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr
 
 matchAllExpr :: Parser EgisonExpr
-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> matchClause
+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses)
 
 matchExpr :: Parser EgisonExpr
 matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses
 
 matchAllLambdaExpr :: Parser EgisonExpr
-matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> matchClause
+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses)
 
 matchLambdaExpr :: Parser EgisonExpr
 matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses

hs-src/Language/Egison/ParserNonS.hs

@@ -318,7 +318,7 @@ quoteSymbolExpr :: Parser EgisonExpr
 quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr
 
 matchAllExpr :: Parser EgisonExpr
-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* (inSpaces $ string "as") <*> expr <*> matchClause
+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* (inSpaces $ string "as") <*> expr <*> matchClauses
 
 matchExpr :: Parser EgisonExpr
 matchExpr = keywordMatch >> MatchExpr <$> expr <* (inSpaces $ string "as") <*> expr <*> matchClauses

hs-src/Language/Egison/Types.hs

@@ -251,9 +251,9 @@ data EgisonExpr =
   | WithSymbolsExpr [String] EgisonExpr
 
   | MatchExpr EgisonExpr EgisonExpr [MatchClause]
-  | MatchAllExpr EgisonExpr EgisonExpr MatchClause
+  | MatchAllExpr EgisonExpr EgisonExpr [MatchClause]
   | MatchLambdaExpr EgisonExpr [MatchClause]
-  | MatchAllLambdaExpr EgisonExpr MatchClause
+  | MatchAllLambdaExpr EgisonExpr [MatchClause]
 
   | NextMatchExpr EgisonExpr EgisonExpr [MatchClause]
   | NextMatchAllExpr EgisonExpr EgisonExpr MatchClause

test/syntax.egi

@@ -110,6 +110,12 @@
     [<cons $x $xs> [x xs]])
   {[1 {2 3}]})
 
+(assert-equal "match-all-multi"
+  (match-all {1 2 3} (multiset integer)
+    {[<cons $x <cons ,(+ x 1) _>> [x (+ x 1)]]
+     [<cons $x <cons ,(+ x 2) _>> [x (+ x 2)]]})
+  {[1 2] [2 3] [1 3]})
+
 (assert-equal "match-lambda"
   (letrec {[$count (match-lambda (list something)
                      {[<nil> 0]
@@ -121,6 +127,12 @@
   ((match-all-lambda (list something) [<join _ <cons $x _>> x]) {1 2 3})
   {1 2 3})
 
+(assert-equal "match-all-lambda-multi"
+  ((match-all-lambda (multiset something)
+     {[<cons $x <cons ,(+ x 1) _>> [x (+ x 1)]]
+      [<cons $x <cons ,(+ x 2) _>> [x (+ x 2)]]}) {1 2 3})
+  {[1 2] [2 3] [1 3]})
+
 (assert-equal "pattern variable"
   (match 1 something
     {[$x x]})