egison 3.0.1 → 3.0.2

raw patch · 7 files changed

+177/−189 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +2/−2
• hs-src/Language/Egison/Core.hs +36/−68
• hs-src/Language/Egison/Desugar.hs +41/−38
• hs-src/Language/Egison/Parser.hs +77/−57
• hs-src/Language/Egison/Types.hs +19/−22
• lib/core/base.egi +1/−1
• lib/core/collection.egi +1/−1

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.0.1+Version:             3.0.2 Synopsis:            An Interpreter for the Programming Language Egison Description:         An interpreter for the programming language Egison.                      A feature of Egison is the strong pattern match facility.@@ -10,7 +10,7 @@ Homepage:            http://egison.pira.jp License:             MIT License-file:        LICENSE-Author:              Satoshi Egi, Ryo Tanaka, Takahisa Watanabe+Author:              Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda Maintainer:          egisatoshi@gmail.com Category:            Compilers/Interpreters Build-type:          Simple

@@ -115,6 +115,7 @@   refArray val _ = throwError $ TypeMismatch "array" val  evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr +evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern  evalExpr env (IfExpr test expr expr') = do   test <- evalExpr env test >>= liftError . fromBoolValue@@ -141,10 +142,8 @@         target = VarExpr var         matcher = TupleExpr $ replicate k SomethingExpr         nth n =-          let pattern = TupleExpr $ flip map [1..k] $ \i ->-                if i == n-                  then PatternExpr $ PatVar "#_"-                  else PatternExpr WildCard+          let pattern = TuplePat $ flip map [1..k] $ \i ->+                if i == n then PatVar "#_" else WildCard           in MatchExpr target matcher [(pattern, VarExpr "#_")]     return ((var, expr) : map (second nth) (zip names [1..])) @@ -183,9 +182,6 @@           MNil -> cont   foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses -evalExpr env (FunctionExpr matcher clauses) =-  return . Value $ Func env ["#_"] (MatchExpr (VarExpr "#_") matcher clauses)- evalExpr env (ApplyExpr func arg) = do   func <- evalExpr env func   arg <- evalExpr env arg@@ -207,8 +203,6 @@     arraySize (Value (Array vals))         = return . Value . Integer . toInteger $ IntMap.size vals     arraySize val                          = throwError $ TypeMismatch "array" val -evalExpr _ (PatternExpr pattern) = return $ Value $ Pattern pattern- evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr)@@ -333,7 +327,7 @@ -- Pattern Match -- -patternMatch :: Env -> EgisonExpr -> ObjectRef -> WHNFData ->+patternMatch :: Env -> EgisonPattern -> ObjectRef -> WHNFData ->                 EgisonM (MList EgisonM [Binding])  patternMatch env pattern target matcher =   processMState (MState env [] [MAtom pattern target matcher]) >>= processMStates . (:[])@@ -354,23 +348,16 @@ processMState state@(MState env bindings []) = throwError $ strMsg "should not reach here" processMState (MState env bindings ((MAtom pattern target matcher):trees)) = do   let env' = extendEnv env bindings-  pattern <- evalPattern env' pattern   case pattern of-    VarExpr _ -> throwError $ strMsg "cannot use variable in pattern"-    ApplyExpr func arg -> do+    VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function"+    ApplyPat func args -> do       func <- evalExpr env' func       case func of-        Value (Func env [name] expr) -> do-          penv <- (:[]) . (,) name <$> evalPattern env' arg-          return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees)-        Value (Func env names expr) -> do-          let args = case arg of-                       TupleExpr exprs -> exprs-                       expr -> [expr]-          penv <- zip names <$> mapM (evalPattern env') args-          return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees)+        Value (PatternFunc env names expr) ->+          let penv = zip names args+          in return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees)         _ -> throwError $ TypeMismatch "pattern constructor" func-    IndexedExpr (PatternExpr (PatVar name)) indices -> do+    IndexedPat (PatVar name) indices -> do       indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices       let (index:_) = indices        case lookup name bindings of@@ -393,36 +380,36 @@         subst k nv ((k', v'):xs) | k == k'   = (k', nv):(subst k nv xs)                                  | otherwise = (k', v'):(subst k nv xs)         subst _ _ [] = []-    IndexedExpr expr index -> throwError $ strMsg ("invalid indexed-pattern: " ++ show expr) -    TupleExpr patterns -> do+    IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) +    TuplePat patterns -> do       matchers <- fromTuple matcher >>= mapM evalRef       targets <- evalRef target >>= fromTuple       let trees' = zipWith3 MAtom patterns targets matchers ++ trees       return $ msingleton $ MState env bindings trees'-    PatternExpr WildCard -> return $ msingleton $ MState env bindings trees -    PatternExpr (AndPat patterns) ->+    WildCard -> return $ msingleton $ MState env bindings trees +    AndPat patterns ->       let trees' = map (\pattern -> MAtom pattern target matcher) patterns ++ trees       in return $ msingleton $ MState env bindings trees'-    PatternExpr (OrPat patterns) ->+    OrPat patterns ->       return $ fromList $ flip map patterns $ \pattern ->         MState env bindings (MAtom pattern target matcher : trees)-    PatternExpr (NotPat pattern) -> do +    NotPat pattern -> do        results <- processMState (MState env bindings [MAtom pattern target matcher])       case results of         MNil -> return $ msingleton $ MState env bindings trees         _    -> return $ MNil-    PatternExpr (CutPat pattern) -> -- TEMPORARY ignoring cut patterns+    CutPat pattern -> -- TEMPORARY ignoring cut patterns       return $ msingleton (MState env bindings ((MAtom pattern target matcher):trees))-    PatternExpr (PredPat pred) -> do+    PredPat pred -> do       func <- evalExpr env' pred       arg <- evalRef target       result <- applyFunc func arg >>= liftError . fromBoolValue       if result then return $ msingleton $ (MState env bindings trees)                 else return MNil-    PatternExpr pattern' ->+    _ ->       case matcher of         Value Something -> -          case pattern' of+          case pattern of             PatVar name -> do               return $ msingleton $ MState env ((name, target):bindings) trees             _ -> throwError $ strMsg "something can only match with a pattern variable"@@ -433,44 +420,30 @@             let trees' = zipWith3 MAtom patterns targets matchers ++ trees             return $ MState env bindings trees'         _ -> throwError $ TypeMismatch "matcher" matcher-    _ -> throwError $ strMsg "should not reach here" processMState (MState env bindings ((MNode penv (MState _ _ [])):trees)) =   return $ msingleton $ MState env bindings trees processMState (MState env bindings ((MNode penv state@(MState env' bindings' (tree:trees')):trees))) = do-  let env'' = extendEnv env' bindings   case tree of     MAtom pattern target matcher -> do-      pattern <- evalPattern env'' pattern       case pattern of-        VarExpr name ->+        VarPat name ->           case lookup name penv of             Just pattern ->               return $ msingleton $ MState env bindings (MAtom pattern target matcher:MNode penv (MState env' bindings' trees'):trees)             Nothing -> throwError $ UnboundVariable name-        IndexedExpr (VarExpr name) (index:_) ->+        IndexedPat (VarPat name) (index:_) -> -- cannot use multiple indices           case lookup name penv of             Just pattern -> do+              let env'' = extendEnv env' bindings               index <- evalExpr env'' index >>= liftError . fromIntegerValue-              let pattern' = IndexedExpr pattern [IntegerExpr index]+              let pattern' = IndexedPat pattern [IntegerExpr index]               return $ msingleton $ MState env bindings (MAtom pattern' target matcher:MNode penv (MState env' bindings' trees'):trees)             Nothing -> throwError $ UnboundVariable name         _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv)     _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv) -evalPattern :: Env -> EgisonExpr -> EgisonM EgisonExpr-evalPattern _ (TupleExpr [expr]) = return expr-evalPattern _ expr@(TupleExpr _) = return expr-evalPattern _ expr@(PatternExpr _) = return expr-evalPattern _ expr@(VarExpr _) = return expr-evalPattern _ expr@(IndexedExpr _ _) = return expr-evalPattern _ expr@(ApplyExpr _ _) = return expr-evalPattern env (IfExpr test expr expr') = do-  test <- evalExpr env test >>= liftError . fromBoolValue-  evalPattern env $ if test then expr else expr'  -evalPattern _ _ = throwError $ strMsg "pattern expression required"--inductiveMatch :: Env -> EgisonExpr -> ObjectRef -> Matcher ->-                  EgisonM ([EgisonExpr], MList EgisonM ObjectRef, [WHNFData])+inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher ->+                  EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [WHNFData]) inductiveMatch env pattern target (matcherEnv, clauses) = do   foldr tryPPMatchClause failPPPatternMatch clauses  where@@ -493,23 +466,18 @@   failPPPatternMatch = throwError $ strMsg "failed primitive pattern pattern match"   failPDPatternMatch = throwError $ strMsg "failed primitive data pattern match" -primitivePatPatternMatch :: Env -> PrimitivePatPattern -> EgisonExpr ->-                            MatchM ([EgisonExpr], [Binding])+primitivePatPatternMatch :: Env -> PrimitivePatPattern -> EgisonPattern ->+                            MatchM ([EgisonPattern], [Binding]) primitivePatPatternMatch _ PPWildCard _ = return ([], []) primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], [])-primitivePatPatternMatch env (PPValuePat name) pattern = do-  pattern <- lift $ evalPattern env pattern-  case pattern of-    PatternExpr (ValuePat expr) -> do-      ref <- lift $ newThunk env expr-      return ([], [(name, ref)])-    _ -> matchFail-primitivePatPatternMatch env (PPInductivePat name patterns) pattern = do-  pattern <- lift $ evalPattern env pattern-  case pattern of-    PatternExpr (InductivePattern name' exprs) | name == name' ->-      (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs-    _ -> matchFail+primitivePatPatternMatch env (PPValuePat name) (ValuePat expr) = do+  ref <- lift $ newThunk env expr+  return ([], [(name, ref)])+primitivePatPatternMatch env (PPInductivePat name patterns) (InductivePat name' exprs)+  | name == name' =+    (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs+  | otherwise = matchFail+primitivePatPatternMatch _ _ _ = matchFail  primitiveDataPatternMatch :: PrimitiveDataPattern -> ObjectRef -> MatchM [Binding] primitiveDataPatternMatch PDWildCard _ = return []

@@ -37,7 +37,7 @@   matcher <- genMatcherClauses patterns matcherRef   return $ LetRecExpr [([matcherName], matcher)] matcherRef     where-      genMatcherClauses :: [EgisonExpr] ->  EgisonExpr -> DesugarM EgisonExpr+      genMatcherClauses :: [(String, [EgisonExpr])] ->  EgisonExpr -> DesugarM EgisonExpr       genMatcherClauses patterns matcher = do         main <- genMainClause patterns matcher         body <- mapM genMatcherClause patterns@@ -45,47 +45,45 @@         clauses <- return $ [main] ++ body ++ [footer]         return $ MatcherExpr clauses         -      genMainClause :: [EgisonExpr] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMainClause patterns matcher = do         clauses <- genClauses patterns-        return (PPValuePat "val", TupleExpr [],-                 [(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr "val"), (VarExpr "tgt")]) -                                              (TupleExpr [matcher, matcher]) -                                              clauses))])+        return (PPValuePat "val", TupleExpr []+               ,[(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr "val"), (VarExpr "tgt")]) +                                             (TupleExpr [matcher, matcher]) +                                             clauses))])         where-          genClauses :: [EgisonExpr] -> DesugarM [MatchClause]+          genClauses :: [(String, [EgisonExpr])] -> DesugarM [MatchClause]           genClauses patterns = (++) <$> mapM genClause patterns-                                     <*> pure [(PatternExpr WildCard, matchingFailure)]+                                     <*> pure [(WildCard, matchingFailure)]           -          genClause :: EgisonExpr -> DesugarM MatchClause+          genClause :: (String, [EgisonExpr]) -> DesugarM MatchClause           genClause pattern = do             (pat0, pat1) <- genMatchingPattern pattern-            return (TupleExpr [pat0, pat1], matchingSuccess)+            return (TuplePat [pat0, pat1], matchingSuccess)         -          genMatchingPattern :: EgisonExpr -> DesugarM (EgisonExpr, EgisonExpr)-          genMatchingPattern (PatternExpr (InductivePattern name patterns)) = do+          genMatchingPattern :: (String, [EgisonExpr]) -> DesugarM (EgisonPattern, EgisonPattern)+          genMatchingPattern (name, patterns) = do             names <- mapM (const fresh) patterns-            return $ ((PatternExpr $ InductivePattern name (map (PatternExpr . PatVar) names))  -                     ,(PatternExpr $ InductivePattern name (map (PatternExpr . ValuePat . VarExpr) names)))+            return $ ((InductivePat name (map PatVar names))  +                     ,(InductivePat name (map (ValuePat . VarExpr) names)))           -      genMatcherClause :: EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genMatcherClause :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMatcherClause pattern = do         (ppat, matchers) <- genPrimitivePatPat pattern         (dpat, body)     <- genPrimitiveDataPat pattern         return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)])                  where-          genPrimitivePatPat :: EgisonExpr -> DesugarM (PrimitivePatPattern, [EgisonExpr])-          genPrimitivePatPat (PatternExpr (InductivePattern name matchers)) = do+          genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr])+          genPrimitivePatPat (name, matchers) = do             patterns' <- mapM (const $ return PPPatVar) matchers             return (PPInductivePat name patterns', matchers)-          genPrimitivePatPat _ = throwError $ Desugar "invalid algebraic-data-matcher"           -          genPrimitiveDataPat :: EgisonExpr -> DesugarM (PrimitiveDataPattern, [EgisonExpr])-          genPrimitiveDataPat (PatternExpr (InductivePattern name patterns)) = do+          genPrimitiveDataPat :: (String, [EgisonExpr]) -> DesugarM (PrimitiveDataPattern, [EgisonExpr])+          genPrimitiveDataPat (name, patterns) = do             patterns' <- mapM (const fresh) patterns              return (PDInductivePat (capitalize name) $ map PDPatVar patterns', map VarExpr patterns')-          genPrimitiveDataPatr _ = throwError $ Desugar "invalid algebraic-data-matcher"            capitalize :: String -> String           capitalize (x:xs) = toUpper x : xs@@ -101,7 +99,7 @@       matchingFailure :: EgisonExpr       matchingFailure = CollectionExpr [] -desugar (FunctionExpr matcher clauses) = do+desugar (MatchLambdaExpr matcher clauses) = do   name <- fresh   matcher' <- desugar matcher   clauses' <- desugarMatchClauses clauses@@ -140,6 +138,10 @@   expr' <- desugar expr   return $ LambdaExpr names expr' +desugar (PatternFunctionExpr names pattern) = do+  pattern' <- desugarPattern pattern+  return $ PatternFunctionExpr names pattern'+ desugar (IfExpr expr0 expr1 expr2) = do   expr0' <- desugar expr0   expr1' <- desugar expr1@@ -156,6 +158,7 @@   expr' <- desugar expr   return $ LetRecExpr binds' expr'   +{- temporarily commented desugar (IndexLoopExpr n0 n1 n2 expr0 expr1 expr2 expr3) = do   name <- fresh   helper <- genHelper name@@ -174,7 +177,7 @@    matcher :: EgisonExpr   matcher = ApplyExpr (VarExpr "list") SomethingExpr-     +-}    desugar (MatchExpr expr0 expr1 clauses) = do     expr0' <- desugar expr0@@ -188,9 +191,6 @@   clause' <- desugarMatchClause clause   return $ MatchAllExpr expr0' expr1' clause'   -desugar (PatternExpr pattern) =-  PatternExpr <$> desugarPattern pattern-   desugar (DoExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr@@ -209,14 +209,17 @@ desugarPattern :: EgisonPattern -> DesugarM EgisonPattern desugarPattern (ValuePat expr) = ValuePat <$> desugar expr desugarPattern (PredPat expr) = PredPat <$> desugar expr-desugarPattern (CutPat expr) = CutPat <$> desugar expr-desugarPattern (NotPat expr) = NotPat <$> desugar expr-desugarPattern (AndPat exprs) = AndPat <$> mapM desugar exprs-desugarPattern (OrPat exprs)  = OrPat <$> mapM desugar exprs-desugarPattern (IndexedPattern pat expr) = -  IndexedPattern <$> desugarPattern pat <*> desugar expr-desugarPattern (InductivePattern name exprs) =-  InductivePattern name <$> mapM desugar exprs+desugarPattern (CutPat pattern) = CutPat <$> desugarPattern pattern+desugarPattern (NotPat pattern) = NotPat <$> desugarPattern pattern+desugarPattern (AndPat patterns) = AndPat <$> mapM desugarPattern patterns+desugarPattern (OrPat patterns)  = OrPat <$> mapM desugarPattern patterns+desugarPattern (TuplePat patterns)  = TuplePat <$> mapM desugarPattern patterns+desugarPattern (InductivePat name patterns) =+  InductivePat name <$> mapM desugarPattern patterns+desugarPattern (IndexedPat pattern exprs) =+  IndexedPat <$> desugarPattern pattern <*> mapM desugar exprs+desugarPattern (ApplyPat expr patterns) =+  ApplyPat <$> desugar expr <*> mapM desugarPattern patterns  desugarPattern pattern = return pattern  desugarBinding :: BindingExpr -> DesugarM BindingExpr@@ -233,10 +236,10 @@ desugarBindings [] = return []  desugarMatchClause :: MatchClause -> DesugarM MatchClause-desugarMatchClause (expr0, expr1) = do-  expr0' <- desugar expr0-  expr1' <- desugar expr1-  return $ (expr0', expr1')+desugarMatchClause (pattern, expr) = do+  pattern' <- desugarPattern pattern+  expr'    <- desugar expr+  return $ (pattern', expr')  desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause] desugarMatchClauses (clause:rest) = do

@@ -40,7 +40,9 @@ readExpr :: String -> Fresh (Either EgisonError EgisonExpr) readExpr input = runDesugarM $ either throwError desugar $ doParse (whiteSpace >> parseExpr) input +-- -- Expressions+--  parseTopExprs :: Parser [EgisonTopExpr] parseTopExprs = endBy parseTopExpr whiteSpace@@ -78,26 +80,13 @@ parseExpr' :: Parser EgisonExpr parseExpr' = (try parseConstantExpr              <|> try parseVarExpr---           <|> parseOmitExpr-             <|> try parsePatVarExpr---           <|> parsePatVarOmitExpr-                       -             <|> parseWildCardExpr-             <|> parseCutPatExpr-             <|> parseNotPatExpr-             <|> parseValuePatExpr-             <|> parsePredPatExpr -                        -             <|> try parseInductiveDataExpr-             <|> parseInductivePatternExpr+             <|> parseInductiveDataExpr              <|> try parseArrayExpr              <|> parseTupleExpr              <|> parseCollectionExpr-             <|> parens (parseAndPatExpr -                         <|> parseOrPatExpr-                         <|> parseIfExpr+             <|> parens (parseIfExpr                          <|> parseLambdaExpr-                         <|> parseFunctionExpr+                         <|> parsePatternFunctionExpr                          <|> parseLetRecExpr                          <|> parseLetExpr                          <|> parseIndexLoopExpr@@ -105,6 +94,7 @@                          <|> parseMatchAllExpr                          <|> parseMatchExpr                          <|> parseMatcherExpr+                         <|> parseMatchLambdaExpr                          <|> parseApplyExpr                          <|> parseAlgebraicDataMatcherExpr                          <|> parseGenerateArrayExpr@@ -118,9 +108,6 @@ parseInductiveDataExpr :: Parser EgisonExpr parseInductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy parseExpr whiteSpace -parseInductivePatternExpr :: Parser EgisonExpr-parseInductivePatternExpr = angles $ (PatternExpr .) . InductivePattern <$> lowerName <*> sepEndBy parseExpr whiteSpace- parseTupleExpr :: Parser EgisonExpr parseTupleExpr = brackets $ TupleExpr <$> sepEndBy parseExpr whiteSpace @@ -143,14 +130,14 @@ parseMatchExpr :: Parser EgisonExpr parseMatchExpr = keywordMatch >> MatchExpr <$> parseExpr <*> parseExpr <*> parseMatchClauses -parseFunctionExpr :: Parser EgisonExpr-parseFunctionExpr = keywordFunction >> FunctionExpr <$> parseExpr <*> parseMatchClauses+parseMatchLambdaExpr :: Parser EgisonExpr+parseMatchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> parseExpr <*> parseMatchClauses  parseMatchClauses :: Parser [MatchClause] parseMatchClauses = braces $ sepEndBy parseMatchClause whiteSpace  parseMatchClause :: Parser MatchClause-parseMatchClause = brackets $ (,) <$> parseExpr <*> parseExpr+parseMatchClause = brackets $ (,) <$> parsePattern <*> parseExpr  parseMatcherExpr :: Parser EgisonExpr parseMatcherExpr = keywordMatcher >> MatcherExpr <$> parsePPMatchClauses@@ -200,8 +187,11 @@ parseIfExpr = keywordIf >> IfExpr <$> parseExpr <*> parseExpr <*> parseExpr  parseLambdaExpr :: Parser EgisonExpr-parseLambdaExpr = (keywordLambda <|> keywordPatternConstructor) >> LambdaExpr <$> parseVarNames <*> parseExpr+parseLambdaExpr = keywordLambda >> LambdaExpr <$> parseVarNames <*> parseExpr +parsePatternFunctionExpr :: Parser EgisonExpr+parsePatternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> parseVarNames <*> parsePattern+ parseLetRecExpr :: Parser EgisonExpr parseLetRecExpr =  keywordLetRec >> LetRecExpr <$> parseBindings <*> parseExpr @@ -259,36 +249,12 @@   parseIndex = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit   annonVars n = take n $ map (('#':) . show) [1..] -parseCutPatExpr :: Parser EgisonExpr-parseCutPatExpr = reservedOp "!" >> PatternExpr . CutPat <$> parseExpr--parseNotPatExpr :: Parser EgisonExpr-parseNotPatExpr = reservedOp "^" >> PatternExpr . NotPat <$> parseExpr--parseWildCardExpr :: Parser EgisonExpr-parseWildCardExpr = reservedOp "_" >> pure (PatternExpr WildCard)--parseValuePatExpr :: Parser EgisonExpr-parseValuePatExpr = reservedOp "," >> PatternExpr . ValuePat <$> parseExpr--parsePatVarExpr :: Parser EgisonExpr-parsePatVarExpr = P.lexeme lexer $ PatternExpr . PatVar <$> parseVarName--parsePredPatExpr :: Parser EgisonExpr-parsePredPatExpr = reservedOp "?" >> PatternExpr . PredPat <$> parseExpr--parseAndPatExpr :: Parser EgisonExpr-parseAndPatExpr = reservedOp "&" >> PatternExpr . AndPat <$> sepEndBy parseExpr whiteSpace--parseOrPatExpr :: Parser EgisonExpr-parseOrPatExpr = reservedOp "|" >> PatternExpr . OrPat <$> sepEndBy parseExpr whiteSpace- parseAlgebraicDataMatcherExpr :: Parser EgisonExpr-parseAlgebraicDataMatcherExpr = keywordAlgebraicDataMatcher -                                >> (parens $ AlgebraicDataMatcherExpr <$> parseAlgebraicDataMatcherBody)+parseAlgebraicDataMatcherExpr = keywordAlgebraicDataMatcher+                                >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 parseInductivePat' whiteSpace)   where-    parseAlgebraicDataMatcherBody :: Parser [EgisonExpr]-    parseAlgebraicDataMatcherBody = reservedOp "|" >> sepEndBy1 parseInductivePatternExpr whiteSpace+    parseInductivePat' :: Parser (String, [EgisonExpr]) +    parseInductivePat' = angles $ (,) <$> lowerName <*> sepEndBy parseExpr whiteSpace  parseGenerateArrayExpr :: Parser EgisonExpr parseGenerateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> parseVarNames <*> parseExpr <*> parseExpr@@ -299,12 +265,64 @@ parseArrayRefExpr :: Parser EgisonExpr parseArrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> parseExpr <*> parseExpr ---parseOmitExpr :: Parser EgisonExpr---parseOmitExpr = prefixChar '`' >> OmitExpr <$> ident <*> parseIndexNums+-- Patterns ---parsePatVarOmitExpr :: Parser EgisonExpr---parsePatVarOmitExpr = prefixString "$`" >> PatVarOmitExpr <$> ident <*> parseIndexNums+parsePattern :: Parser EgisonPattern+parsePattern = do pattern <- parsePattern'+                  option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> parseExpr') +parsePattern' :: Parser EgisonPattern+parsePattern' = parseWildCard+            <|> parsePatVar+            <|> parseVarPat+            <|> parseValuePat+            <|> parsePredPat+            <|> parseCutPat+            <|> parseNotPat+            <|> parseTuplePat+            <|> parseInductivePat+            <|> parens (parseAndPat+                    <|> parseOrPat+                    <|> parseApplyPat)++parseWildCard :: Parser EgisonPattern+parseWildCard = reservedOp "_" >> pure WildCard++parsePatVar :: Parser EgisonPattern+parsePatVar = P.lexeme lexer $ PatVar <$> parseVarName++parseVarPat :: Parser EgisonPattern+parseVarPat = VarPat <$> ident++parseValuePat :: Parser EgisonPattern+parseValuePat = reservedOp "," >> ValuePat <$> parseExpr++parsePredPat :: Parser EgisonPattern+parsePredPat = reservedOp "?" >> PredPat <$> parseExpr++parseCutPat :: Parser EgisonPattern+parseCutPat = reservedOp "!" >> CutPat <$> parsePattern++parseNotPat :: Parser EgisonPattern+parseNotPat = reservedOp "^" >> NotPat <$> parsePattern++parseTuplePat :: Parser EgisonPattern+parseTuplePat = brackets $ TuplePat <$> sepEndBy parsePattern whiteSpace++parseInductivePat :: Parser EgisonPattern+parseInductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy parsePattern whiteSpace++parseAndPat :: Parser EgisonPattern+parseAndPat = reservedOp "&" >> AndPat <$> sepEndBy parsePattern whiteSpace++parseOrPat :: Parser EgisonPattern+parseOrPat = reservedOp "|" >> OrPat <$> sepEndBy parsePattern whiteSpace++parseApplyPat :: Parser EgisonPattern+parseApplyPat = ApplyPat <$> parseExpr <*> sepEndBy parsePattern whiteSpace ++-- Constants+ parseConstantExpr :: Parser EgisonExpr parseConstantExpr =  parseCharExpr                  <|> parseStringExpr@@ -330,7 +348,9 @@ parseFloatExpr :: Parser EgisonExpr parseFloatExpr = FloatExpr <$> floatLiteral +-- -- Tokens+--  egisonDef :: P.GenLanguageDef ByteString () Identity egisonDef = @@ -405,15 +425,15 @@ keywordElse                 = reserved "else" keywordApply                = reserved "apply" keywordLambda               = reserved "lambda"-keywordPatternConstructor   = reserved "pattern-constructor"+keywordPatternFunction      = reserved "pattern-function" keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let" keywordIndexLoop            = reserved "index-loop" keywordMatchAll             = reserved "match-all" keywordMatch                = reserved "match"+keywordMatchLambda          = reserved "match-lambda" keywordMatcher              = reserved "matcher" keywordDo                   = reserved "do"-keywordFunction             = reserved "function" keywordSomething            = reserved "something" keywordUndefined            = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher"

@@ -44,9 +44,8 @@   | CollectionExpr [InnerExpr]   | ArrayExpr [EgisonExpr] -  | PatternExpr EgisonPattern-   | LambdaExpr [String] EgisonExpr+  | PatternFunctionExpr [String] EgisonPattern      | IfExpr EgisonExpr EgisonExpr EgisonExpr   | LetExpr [BindingExpr] EgisonExpr@@ -56,8 +55,7 @@        | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause--  | FunctionExpr EgisonExpr [MatchClause]+  | MatchLambdaExpr EgisonExpr [MatchClause]    | MatcherExpr MatcherInfo   @@ -65,7 +63,7 @@        | ApplyExpr EgisonExpr EgisonExpr -  | AlgebraicDataMatcherExpr [EgisonExpr]+  | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]   | GenerateArrayExpr [String] EgisonExpr EgisonExpr   | ArraySizeExpr EgisonExpr   | ArrayRefExpr EgisonExpr EgisonExpr@@ -75,20 +73,23 @@  deriving (Show)  type BindingExpr = ([String], EgisonExpr)-type MatchClause = (EgisonExpr, EgisonExpr)+type MatchClause = (EgisonPattern, EgisonExpr) type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])]  data EgisonPattern =     WildCard   | PatVar String+  | VarPat String   | ValuePat EgisonExpr   | PredPat EgisonExpr-  | CutPat EgisonExpr-  | NotPat EgisonExpr-  | AndPat [EgisonExpr]-  | OrPat [EgisonExpr]-  | IndexedPattern EgisonPattern EgisonExpr-  | InductivePattern String [EgisonExpr]+  | IndexedPat EgisonPattern [EgisonExpr]+  | CutPat EgisonPattern+  | NotPat EgisonPattern+  | AndPat [EgisonPattern]+  | OrPat [EgisonPattern]+  | TuplePat [EgisonPattern]+  | InductivePat String [EgisonPattern]+  | ApplyPat EgisonExpr [EgisonPattern]  deriving (Show)  data PrimitivePatPattern =@@ -128,9 +129,9 @@   | Tuple [EgisonValue]   | Collection [EgisonValue]   | Array (IntMap EgisonValue)-  | Pattern EgisonPattern   | Matcher Matcher   | Func Env [String] EgisonExpr+  | PatternFunc Env [String] EgisonPattern   | PrimitiveFunc PrimitiveFunc   | IOFunc (EgisonM WHNFData)   | Port Handle@@ -153,11 +154,11 @@   show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]"   show (Collection vals) = "{" ++ unwords (map show vals) ++ "}"   show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]"-  show (Pattern _) = "#<pattern>"   show (Matcher _) = "#<matcher>"   show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)"-  show (PrimitiveFunc _) = "#<primitive>"-  show (IOFunc _) = "#<io>"+  show (PatternFunc _ _ _) = "#<pattern-function>"+  show (PrimitiveFunc _) = "#<primitive-function>"+  show (IOFunc _) = "#<io-function>"   show (Port _) = "#<port>"   show Something = "something"   show Undefined = "undefined"@@ -231,10 +232,6 @@ fromPortValue (Value (Port handle)) = return handle fromPortValue val = throwError $ TypeMismatch "port" val -fromPatternValue :: WHNFData -> Either EgisonError EgisonPattern-fromPatternValue (Value (Pattern pattern)) = return pattern-fromPatternValue val = throwError $ TypeMismatch "pattern" val- fromMatcherValue :: WHNFData -> Either EgisonError Matcher fromMatcherValue (Value (Matcher matcher)) = return matcher fromMatcherValue val = throwError $ TypeMismatch "matcher" val@@ -272,10 +269,10 @@ data MatchingState = MState Env [Binding] [MatchingTree]  data MatchingTree =-    MAtom EgisonExpr ObjectRef WHNFData+    MAtom EgisonPattern ObjectRef WHNFData   | MNode [PatternBinding] MatchingState -type PatternBinding = (Var, EgisonExpr)+type PatternBinding = (Var, EgisonPattern)  -- -- Errors

@@ -52,7 +52,7 @@  (define $ordering   (algebraic-data-matcher -    (| <less> <equal> <greater>)))+    {<less> <equal> <greater>}))  (define $match?   (lambda [$a]

@@ -250,7 +250,7 @@        [<cons $x $rs> {@x @(concat rs)}]})))  (define $empty?-  (function (list something)+  (match-lambda (list something)    {[<nil>      #t]     [<cons _ _> #f]}))