diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -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 diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -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 [] diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -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 diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -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" diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -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 _) = "#" show (Matcher _) = "#" show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)" - show (PrimitiveFunc _) = "#" - show (IOFunc _) = "#" + show (PatternFunc _ _ _) = "#" + show (PrimitiveFunc _) = "#" + show (IOFunc _) = "#" show (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 diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -52,7 +52,7 @@ (define $ordering (algebraic-data-matcher - (| ))) + { })) (define $match? (lambda [$a] diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -250,7 +250,7 @@ [ {@x @(concat rs)}]}))) (define $empty? - (function (list something) + (match-lambda (list something) {[ #t] [ #f]}))