diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.0.4 +Version: 3.0.5 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. diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -24,7 +24,7 @@ "\\" "\\" "\\" - "\\" + "\\" "\\" "\\" "\\" @@ -33,7 +33,7 @@ "\\" "\\" - "\\\." + "\\\.\\\.\\\." "\\\," "\\\!" "`" @@ -116,7 +116,7 @@ (defun keyword-indent-point (name) (cond ((equal "define" name) 2) ((equal "lambda" name) 2) - ((equal "function" name) 2) + ((equal "match-lambda" name) 2) ((equal "macro" name) 2) ((equal "let" name) 2) ((equal "letrec" name) 2) diff --git a/hs-src/Interpreter/egisoni.hs b/hs-src/Interpreter/egisoni.hs --- a/hs-src/Interpreter/egisoni.hs +++ b/hs-src/Interpreter/egisoni.hs @@ -110,7 +110,7 @@ Just "" -> loop env prompt "" Just input' -> do let newInput = rest ++ input' - result <- liftIO $ runEgisonTopExpr env newInput + result <- liftIO $ runEgisonTopExprs env newInput case result of Left err | show err =~ "unexpected end of input" -> do loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n" diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -3,13 +3,15 @@ ( module Language.Egison.Types , module Language.Egison.Parser , module Language.Egison.Primitives - , counter --danger , version + , counter --danger , loadLibraries , loadPrimitives - , runEgisonTopExpr + , evalEgisonExpr , evalEgisonTopExpr , evalEgisonTopExprs + , runEgisonTopExpr + , runEgisonTopExprs ) where import Control.Applicative ((<$>), (<*>)) @@ -26,18 +28,30 @@ import qualified Paths_egison as P import Language.Egison.Types -import Language.Egison.Core import Language.Egison.Parser import Language.Egison.Primitives +import Language.Egison.Core +version :: Version +version = P.version + -- Unsafe counter :: IORef Int counter = unsafePerformIO (newIORef 0) +readCounter :: IO Int +readCounter = readIORef counter -version :: Version -version = P.version +updateCounter :: Int -> IO () +updateCounter = writeIORef counter +modifyCounter :: FreshT IO a -> IO a +modifyCounter m = do + seed <- readCounter + (result, seed) <- runFreshT seed m + updateCounter seed + return result + loadLibraries :: Env -> IO Env loadLibraries env = do seed <- readIORef counter @@ -58,26 +72,21 @@ loadPrimitives :: Env -> IO Env loadPrimitives env = (++) <$> return env <*> primitiveEnv - -runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env) -runEgisonTopExpr env input = do - seed <- readIORef counter - (result, seed') <- runFreshT seed $ runEgisonM $ do - expr <- liftEgisonM $ readTopExpr input - evalTopExpr env expr - writeIORef counter seed' - return result + +evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue) +evalEgisonExpr env expr = modifyCounter $ runEgisonM $ evalExpr' env expr evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env) -evalEgisonTopExpr env expr = do - seed <- readIORef counter - (result, seed') <- runFreshT seed $ runEgisonM $ evalTopExpr env expr - writeIORef counter seed' - return result +evalEgisonTopExpr env exprs = modifyCounter $ runEgisonM $ evalTopExpr env exprs evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env) -evalEgisonTopExprs env exprs = do - seed <- readIORef counter - (result, seed') <- runFreshT seed $ runEgisonM $ foldM evalTopExpr env exprs - writeIORef counter seed' - return result +evalEgisonTopExprs env exprs = modifyCounter $ runEgisonM $ evalTopExprs env exprs + +runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env) +runEgisonTopExpr env input = modifyCounter $ runEgisonM $ liftEgisonM (readTopExpr input) >>= evalTopExpr env + +runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env) +runEgisonTopExprs env input = modifyCounter $ runEgisonM $ liftEgisonM (readTopExprs input) >>= evalTopExprs env + + + 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 @@ -36,13 +36,22 @@ evalTopExprs :: Env -> [EgisonTopExpr] -> EgisonM Env evalTopExprs env exprs = do - let (bindings, rest) = foldr collectDefs ([], []) exprs + (bindings, rest) <- collectDefs exprs [] [] env <- recursiveBind env bindings forM_ rest $ evalTopExpr env return env where - collectDefs (Define name expr) (bindings, rest) = ((name, expr) : bindings, rest) - collectDefs expr (bindings, rest) = (bindings, expr : rest) + collectDefs (expr:exprs) bindings rest = + case expr of + Define name expr -> collectDefs exprs ((name, expr) : bindings) rest + Load file -> do + exprs' <- loadLibraryFile file + collectDefs (exprs' ++ exprs) bindings rest + LoadFile file -> do + exprs' <- loadFile file + collectDefs (exprs' ++ exprs) bindings rest + _ -> collectDefs exprs bindings (expr : rest) + collectDefs [] bindings rest = return (bindings, rest) evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env evalTopExpr env (Define name expr) = recursiveBind env [(name, expr)] @@ -55,7 +64,7 @@ io <- applyFunc main $ Value $ Collection $ Sq.fromList $ map String argv case io of Value (IOFunc m) -> m >> return env - _ -> throwError $ TypeMismatch "io" main + _ -> throwError $ TypeMismatch "io" io evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env @@ -353,8 +362,31 @@ processMStates' (MCons state states) = (Nothing, [processMState state, states]) processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) -processMState state@(MState _ _ _ []) = throwError $ strMsg "should not reach here" -processMState (MState env loops bindings ((MAtom pattern target matcher):trees)) = do +processMState state = + if isNotPat state + then do + let (state1, state2) = splitMState state + result <- processMStates [msingleton state1] + case result of + MNil -> return $ msingleton state2 + _ -> return MNil + else processMState' state + where + isNotPat :: MatchingState -> Bool + isNotPat (MState _ _ _ ((MAtom (NotPat _) _ _) : _)) = True + isNotPat (MState _ _ _ ((MNode _ state) : _)) = isNotPat state + isNotPat _ = False + + splitMState :: MatchingState -> (MatchingState, MatchingState) + splitMState (MState env loops bindings ((MAtom (NotPat pattern) target matcher) : trees)) = + (MState env loops bindings [MAtom pattern target matcher], MState env loops bindings trees) + splitMState (MState env loops bindings ((MNode penv state) : trees)) = + let (state1, state2) = splitMState state + in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees)) + +processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState) +processMState' state@(MState _ _ _ []) = throwError $ strMsg "should not reach here" +processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)) = do let env' = extendEnv env (bindings ++ map (\(LoopContext binding _ _ _) -> binding) loops) case pattern of WildCard -> return $ msingleton $ MState env loops bindings trees @@ -363,9 +395,9 @@ ApplyPat func args -> do func <- evalExpr env' func case func of - Value (PatternFunc env names expr) -> + Value (PatternFunc env'' names expr) -> let penv = zip names args - in return $ msingleton $ MState env loops bindings (MNode penv (MState env [] [] [MAtom expr target matcher]) : trees) + in return $ msingleton $ MState env loops bindings (MNode penv (MState env'' [] [] [MAtom expr target matcher]) : trees) _ -> throwError $ TypeMismatch "pattern constructor" func LoopPat name range pat pat' -> do @@ -397,11 +429,7 @@ OrPat patterns -> return $ fromList $ flip map patterns $ \pattern -> MState env loops bindings (MAtom pattern target matcher : trees) - NotPat pattern -> do -- TEMPORARY do not run in the pattern function - results <- processMState (MState env loops bindings [MAtom pattern target matcher]) - case results of - MNil -> return $ msingleton $ MState env loops bindings trees - _ -> return $ MNil + NotPat pattern -> throwError $ strMsg "should not reach here (cut pattern)" CutPat pattern -> -- TEMPORARY ignoring cut patterns return $ msingleton (MState env loops bindings ((MAtom pattern target matcher):trees)) PredPat pred -> do @@ -410,13 +438,20 @@ result <- applyFunc func arg >>= liftError . fromBoolValue if result then return $ msingleton $ (MState env loops bindings trees) else return MNil + LetPat bindings' pattern -> + let extractBindings ([name], expr) = + makeBindings [name] . (:[]) <$> newThunk env' expr + extractBindings (names, expr) = + makeBindings names <$> (evalExpr env' expr >>= fromTuple) + in + liftM concat (mapM extractBindings bindings') + >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern target matcher):trees)) _ -> case matcher of Value Something -> case pattern of PatVar name -> do return $ msingleton $ MState env loops ((name, target):bindings) trees - IndexedPat (PatVar name) indices -> do indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices case lookup name bindings of @@ -459,9 +494,9 @@ let trees' = zipWith3 MAtom patterns targets matchers ++ trees return $ MState env loops bindings trees' _ -> throwError $ TypeMismatch "matcher" matcher -processMState (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) = +processMState' (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) = return $ msingleton $ MState env loops bindings trees -processMState (MState env loops bindings ((MNode penv state@(MState env' loops' bindings' (tree:trees')):trees))) = do +processMState' (MState env loops bindings ((MNode penv state@(MState env' loops' bindings' (tree:trees')):trees))) = do case tree of MAtom pattern target matcher -> do case pattern of @@ -470,7 +505,7 @@ Just pattern -> return $ msingleton $ MState env loops bindings (MAtom pattern target matcher:MNode penv (MState env' loops' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name - IndexedPat (VarPat name) indices -> -- TEMPORARY cannot use multiple indices + IndexedPat (VarPat name) indices -> case lookup name penv of Just pattern -> do let env'' = extendEnv env' (bindings' ++ map (\(LoopContext binding _ _ _) -> binding) loops') @@ -478,8 +513,8 @@ let pattern' = IndexedPat pattern $ map IntegerExpr indices return $ msingleton $ MState env loops bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name - _ -> processMState state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv) - _ -> processMState state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv) + _ -> processMState' state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv) + _ -> processMState' state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv) inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [WHNFData]) 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 @@ -160,27 +160,6 @@ expr' <- desugar expr return $ LetRecExpr binds' expr' -{- temporarily commented -desugar (IndexLoopExpr n0 n1 n2 expr0 expr1 expr2 expr3) = do - name <- fresh - helper <- genHelper name - return $ ApplyExpr (LetRecExpr [([name], helper)] (ApplyExpr (VarExpr name) expr1)) expr0 - where - genHelper :: String -> DesugarM EgisonExpr - genHelper name = do - indicesName <- fresh - patName <- fresh - let subst = [(n0, ApplyExpr (ApplyExpr (VarExpr name) (VarExpr indicesName)) (VarExpr patName)), (n1, VarExpr patName)] - bodyExpr <- local (subst ++) $ desugar expr2 - initExpr <- desugar expr3 - let matchClauses = [ (PatternExpr $ InductivePattern "nil" [], LambdaExpr [patName] $ initExpr) - , (PatternExpr $ InductivePattern "cons" [PatternExpr (PatVar n2), PatternExpr (PatVar indicesName)], LambdaExpr [patName] $ bodyExpr)] - return $ LambdaExpr [indicesName] $ MatchExpr (VarExpr indicesName) matcher matchClauses - - matcher :: EgisonExpr - matcher = ApplyExpr (VarExpr "list") SomethingExpr --} - desugar (MatchExpr expr0 expr1 clauses) = do expr0' <- desugar expr0 expr1' <- desugar expr1 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 @@ -2,7 +2,11 @@ ( readTopExprs , readTopExpr , readExprs - , readExpr ) where + , readExpr + , parseTopExprs + , parseTopExpr + , parseExprs + , parseExpr ) where import Control.Monad.Identity import Control.Monad.Error @@ -30,198 +34,207 @@ doParse p input = either (throwError . Parser) return $ parse p "egison" $ B.pack input readTopExprs :: String -> Fresh (Either EgisonError [EgisonTopExpr]) -readTopExprs input = runDesugarM $ either throwError (mapM desugarTopExpr) $ doParse (whiteSpace >> parseTopExprs) input +readTopExprs = runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs readTopExpr :: String -> Fresh (Either EgisonError EgisonTopExpr) -readTopExpr input = runDesugarM $ either throwError desugarTopExpr $ doParse (whiteSpace >> parseTopExpr) input +readTopExpr = runDesugarM . either throwError desugarTopExpr . parseTopExpr readExprs :: String -> Fresh (Either EgisonError [EgisonExpr]) -readExprs input = runDesugarM $ either throwError (mapM desugar) $ doParse (whiteSpace >> parseExprs) input +readExprs = runDesugarM . either throwError (mapM desugar) . parseExprs readExpr :: String -> Fresh (Either EgisonError EgisonExpr) -readExpr input = runDesugarM $ either throwError desugar $ doParse (whiteSpace >> parseExpr) input +readExpr = runDesugarM . either throwError desugar . parseExpr +parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] +parseTopExprs = doParse $ whiteSpace >> endBy topExpr whiteSpace + +parseTopExpr :: String -> Either EgisonError EgisonTopExpr +parseTopExpr = doParse $ whiteSpace >> topExpr + +parseExprs :: String -> Either EgisonError [EgisonExpr] +parseExprs = doParse $ whiteSpace >> endBy expr whiteSpace + +parseExpr :: String -> Either EgisonError EgisonExpr +parseExpr = doParse $ whiteSpace >> expr + -- -- Expressions -- -parseTopExprs :: Parser [EgisonTopExpr] -parseTopExprs = endBy parseTopExpr whiteSpace - -parseTopExpr :: Parser EgisonTopExpr -parseTopExpr = parens (parseDefineExpr - <|> parseTestExpr - <|> parseExecuteExpr - <|> parseLoadFileExpr - <|> parseLoadExpr - "top-level expression") +topExpr :: Parser EgisonTopExpr +topExpr = parens (defineExpr + <|> testExpr + <|> executeExpr + <|> loadFileExpr + <|> loadExpr + "top-level expression") -parseDefineExpr :: Parser EgisonTopExpr -parseDefineExpr = keywordDefine >> Define <$> parseVarName <*> parseExpr +defineExpr :: Parser EgisonTopExpr +defineExpr = keywordDefine >> Define <$> varName <*> expr -parseTestExpr :: Parser EgisonTopExpr -parseTestExpr = keywordTest >> Test <$> parseExpr +testExpr :: Parser EgisonTopExpr +testExpr = keywordTest >> Test <$> expr -parseExecuteExpr :: Parser EgisonTopExpr -parseExecuteExpr = keywordExecute >> Execute <$> sepEndBy stringLiteral whiteSpace +executeExpr :: Parser EgisonTopExpr +executeExpr = keywordExecute >> Execute <$> sepEndBy stringLiteral whiteSpace -parseLoadFileExpr :: Parser EgisonTopExpr -parseLoadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral +loadFileExpr :: Parser EgisonTopExpr +loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral -parseLoadExpr :: Parser EgisonTopExpr -parseLoadExpr = keywordLoad >> Load <$> stringLiteral +loadExpr :: Parser EgisonTopExpr +loadExpr = keywordLoad >> Load <$> stringLiteral -parseExprs :: Parser [EgisonExpr] -parseExprs = endBy parseExpr whiteSpace +exprs :: Parser [EgisonExpr] +exprs = endBy expr whiteSpace -parseExpr :: Parser EgisonExpr -parseExpr = do expr <- parseExpr' - option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> parseExpr') +expr :: Parser EgisonExpr +expr = do expr <- expr' + option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> expr') -parseExpr' :: Parser EgisonExpr -parseExpr' = (try parseConstantExpr - <|> try parseVarExpr - <|> parseInductiveDataExpr - <|> try parseArrayExpr - <|> parseTupleExpr - <|> parseCollectionExpr - <|> parens (parseIfExpr - <|> parseLambdaExpr - <|> parsePatternFunctionExpr - <|> parseLetRecExpr - <|> parseLetExpr - <|> parseDoExpr - <|> parseMatchAllExpr - <|> parseMatchExpr - <|> parseMatcherExpr - <|> parseMatchLambdaExpr - <|> parseApplyExpr - <|> parseAlgebraicDataMatcherExpr - <|> parseGenerateArrayExpr - <|> parseArraySizeExpr - <|> parseArrayRefExpr) +expr' :: Parser EgisonExpr +expr' = (try constantExpr + <|> try varExpr + <|> inductiveDataExpr + <|> try arrayExpr + <|> tupleExpr + <|> collectionExpr + <|> parens (ifExpr + <|> lambdaExpr + <|> patternFunctionExpr + <|> letRecExpr + <|> letExpr + <|> doExpr + <|> matchAllExpr + <|> matchExpr + <|> matcherExpr + <|> matchLambdaExpr + <|> applyExpr + <|> algebraicDataMatcherExpr + <|> generateArrayExpr + <|> arraySizeExpr + <|> arrayRefExpr) "expression") -parseVarExpr :: Parser EgisonExpr -parseVarExpr = VarExpr <$> ident +varExpr :: Parser EgisonExpr +varExpr = VarExpr <$> ident -parseInductiveDataExpr :: Parser EgisonExpr -parseInductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy parseExpr whiteSpace +inductiveDataExpr :: Parser EgisonExpr +inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace -parseTupleExpr :: Parser EgisonExpr -parseTupleExpr = brackets $ TupleExpr <$> sepEndBy parseExpr whiteSpace +tupleExpr :: Parser EgisonExpr +tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace -parseCollectionExpr :: Parser EgisonExpr -parseCollectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy parseInnerExpr whiteSpace +collectionExpr :: Parser EgisonExpr +collectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy innerExpr whiteSpace where - parseInnerExpr :: Parser InnerExpr - parseInnerExpr = (char '@' >> SubCollectionExpr <$> parseExpr) - <|> ElementExpr <$> parseExpr + innerExpr :: Parser InnerExpr + innerExpr = (char '@' >> SubCollectionExpr <$> expr) + <|> ElementExpr <$> expr -parseArrayExpr :: Parser EgisonExpr -parseArrayExpr = between lp rp $ ArrayExpr <$> sepEndBy parseExpr whiteSpace +arrayExpr :: Parser EgisonExpr +arrayExpr = between lp rp $ ArrayExpr <$> sepEndBy expr whiteSpace where lp = P.lexeme lexer (string "[|") rp = P.lexeme lexer (string "|]") -parseMatchAllExpr :: Parser EgisonExpr -parseMatchAllExpr = keywordMatchAll >> MatchAllExpr <$> parseExpr <*> parseExpr <*> parseMatchClause +matchAllExpr :: Parser EgisonExpr +matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> matchClause -parseMatchExpr :: Parser EgisonExpr -parseMatchExpr = keywordMatch >> MatchExpr <$> parseExpr <*> parseExpr <*> parseMatchClauses +matchExpr :: Parser EgisonExpr +matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses -parseMatchLambdaExpr :: Parser EgisonExpr -parseMatchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> parseExpr <*> parseMatchClauses +matchLambdaExpr :: Parser EgisonExpr +matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses -parseMatchClauses :: Parser [MatchClause] -parseMatchClauses = braces $ sepEndBy parseMatchClause whiteSpace +matchClauses :: Parser [MatchClause] +matchClauses = braces $ sepEndBy matchClause whiteSpace -parseMatchClause :: Parser MatchClause -parseMatchClause = brackets $ (,) <$> parsePattern <*> parseExpr +matchClause :: Parser MatchClause +matchClause = brackets $ (,) <$> pattern <*> expr -parseMatcherExpr :: Parser EgisonExpr -parseMatcherExpr = keywordMatcher >> MatcherExpr <$> parsePPMatchClauses +matcherExpr :: Parser EgisonExpr +matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -parsePPMatchClauses :: Parser MatcherInfo -parsePPMatchClauses = braces $ sepEndBy parsePPMatchClause whiteSpace +ppMatchClauses :: Parser MatcherInfo +ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace -parsePPMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) -parsePPMatchClause = brackets $ (,,) <$> parsePPPattern <*> parseExpr <*> parsePDMatchClauses +ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) +ppMatchClause = brackets $ (,,) <$> pppattern <*> expr <*> pdMatchClauses -parsePDMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] -parsePDMatchClauses = braces $ sepEndBy parsePDMatchClause whiteSpace +pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] +pdMatchClauses = braces $ sepEndBy pdMatchClause whiteSpace -parsePDMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr) -parsePDMatchClause = brackets $ (,) <$> parsePDPattern <*> parseExpr +pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr) +pdMatchClause = brackets $ (,) <$> pdPattern <*> expr -parsePPPattern :: Parser PrimitivePatPattern -parsePPPattern = parsePPWildCard - <|> parsePPPatVar - <|> parsePPValuePat - <|> parsePPInductivePat +pppattern :: Parser PrimitivePatPattern +pppattern = ppWildCard + <|> pppatVar + <|> ppValuePat + <|> ppInductivePat "primitive-pattren-pattern" -parsePPWildCard :: Parser PrimitivePatPattern -parsePPWildCard = reservedOp "_" *> pure PPWildCard +ppWildCard :: Parser PrimitivePatPattern +ppWildCard = reservedOp "_" *> pure PPWildCard -parsePPPatVar :: Parser PrimitivePatPattern -parsePPPatVar = reservedOp "$" *> pure PPPatVar +pppatVar :: Parser PrimitivePatPattern +pppatVar = reservedOp "$" *> pure PPPatVar -parsePPValuePat :: Parser PrimitivePatPattern -parsePPValuePat = string ",$" >> PPValuePat <$> ident +ppValuePat :: Parser PrimitivePatPattern +ppValuePat = string ",$" >> PPValuePat <$> ident -parsePPInductivePat :: Parser PrimitivePatPattern -parsePPInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy parsePPPattern whiteSpace) +ppInductivePat :: Parser PrimitivePatPattern +ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy pppattern whiteSpace) -parsePDPattern :: Parser PrimitiveDataPattern -parsePDPattern = reservedOp "_" *> pure PDWildCard +pdPattern :: Parser PrimitiveDataPattern +pdPattern = reservedOp "_" *> pure PDWildCard <|> (char '$' >> PDPatVar <$> ident) - <|> braces ((PDConsPat <$> parsePDPattern <*> (char '@' *> parsePDPattern)) - <|> (PDSnocPat <$> (char '@' *> parsePDPattern) <*> parsePDPattern) + <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern)) + <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern) <|> pure PDEmptyPat) - <|> angles (PDInductivePat <$> upperName <*> sepEndBy parsePDPattern whiteSpace) - <|> PDConstantPat <$> parseConstantExpr + <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace) + <|> PDConstantPat <$> constantExpr "primitive-data-pattern" -parseIfExpr :: Parser EgisonExpr -parseIfExpr = keywordIf >> IfExpr <$> parseExpr <*> parseExpr <*> parseExpr +ifExpr :: Parser EgisonExpr +ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr -parseLambdaExpr :: Parser EgisonExpr -parseLambdaExpr = keywordLambda >> LambdaExpr <$> parseVarNames <*> parseExpr +lambdaExpr :: Parser EgisonExpr +lambdaExpr = keywordLambda >> LambdaExpr <$> varNames <*> expr -parsePatternFunctionExpr :: Parser EgisonExpr -parsePatternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> parseVarNames <*> parsePattern +patternFunctionExpr :: Parser EgisonExpr +patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern -parseLetRecExpr :: Parser EgisonExpr -parseLetRecExpr = keywordLetRec >> LetRecExpr <$> parseBindings <*> parseExpr +letRecExpr :: Parser EgisonExpr +letRecExpr = keywordLetRec >> LetRecExpr <$> bindings <*> expr -parseLetExpr :: Parser EgisonExpr -parseLetExpr = keywordLet >> LetExpr <$> parseBindings <*> parseExpr +letExpr :: Parser EgisonExpr +letExpr = keywordLet >> LetExpr <$> bindings <*> expr -parseDoExpr :: Parser EgisonExpr -parseDoExpr = keywordDo >> DoExpr <$> parseBindings <*> parseExpr +doExpr :: Parser EgisonExpr +doExpr = keywordDo >> DoExpr <$> bindings <*> expr -parseBindings :: Parser [BindingExpr] -parseBindings = braces $ sepEndBy parseBinding whiteSpace +bindings :: Parser [BindingExpr] +bindings = braces $ sepEndBy binding whiteSpace -parseBinding :: Parser BindingExpr -parseBinding = brackets $ (,) <$> parseVarNames <*> parseExpr +binding :: Parser BindingExpr +binding = brackets $ (,) <$> varNames <*> expr -parseVarNames :: Parser [String] -parseVarNames = return <$> parseVarName - <|> brackets (sepEndBy parseVarName whiteSpace) +varNames :: Parser [String] +varNames = return <$> varName + <|> brackets (sepEndBy varName whiteSpace) -parseVarName :: Parser String -parseVarName = char '$' >> ident +varName :: Parser String +varName = char '$' >> ident -parseApplyExpr :: Parser EgisonExpr -parseApplyExpr = (keywordApply >> ApplyExpr <$> parseExpr <*> parseExpr) - <|> parseApplyExpr' +applyExpr :: Parser EgisonExpr +applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr) + <|> applyExpr' -parseApplyExpr' :: Parser EgisonExpr -parseApplyExpr' = do - func <- parseExpr - args <- parseArgs +applyExpr' :: Parser EgisonExpr +applyExpr' = do + func <- expr + args <- args let vars = lefts args case vars of [] -> return . ApplyExpr func . TupleExpr $ rights args @@ -239,118 +252,122 @@ else fail "invalid partial application" | otherwise -> fail "invalid partial application" where - parseArgs = sepEndBy parseArg whiteSpace - parseArg = try (Right <$> parseExpr) - <|> char '$' *> (Left <$> option "" parseIndex) - parseIndex = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit + args = sepEndBy arg whiteSpace + arg = try (Right <$> expr) + <|> char '$' *> (Left <$> option "" index) + index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit annonVars n = take n $ map (('#':) . show) [1..] -parseAlgebraicDataMatcherExpr :: Parser EgisonExpr -parseAlgebraicDataMatcherExpr = keywordAlgebraicDataMatcher - >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 parseInductivePat' whiteSpace) +algebraicDataMatcherExpr :: Parser EgisonExpr +algebraicDataMatcherExpr = keywordAlgebraicDataMatcher + >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace) where - parseInductivePat' :: Parser (String, [EgisonExpr]) - parseInductivePat' = angles $ (,) <$> lowerName <*> sepEndBy parseExpr whiteSpace + inductivePat' :: Parser (String, [EgisonExpr]) + inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace -parseGenerateArrayExpr :: Parser EgisonExpr -parseGenerateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> parseVarNames <*> parseExpr <*> parseExpr +generateArrayExpr :: Parser EgisonExpr +generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> varNames <*> expr <*> expr -parseArraySizeExpr :: Parser EgisonExpr -parseArraySizeExpr = keywordArraySize >> ArraySizeExpr <$> parseExpr +arraySizeExpr :: Parser EgisonExpr +arraySizeExpr = keywordArraySize >> ArraySizeExpr <$> expr -parseArrayRefExpr :: Parser EgisonExpr -parseArrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> parseExpr <*> parseExpr +arrayRefExpr :: Parser EgisonExpr +arrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> expr <*> expr -- Patterns -parsePattern :: Parser EgisonPattern -parsePattern = do pattern <- parsePattern' - option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> parseExpr') +pattern :: Parser EgisonPattern +pattern = do pattern <- pattern' + option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr') -parsePattern' :: Parser EgisonPattern -parsePattern' = parseWildCard - <|> parsePatVar - <|> parseVarPat - <|> parseValuePat - <|> parsePredPat - <|> parseCutPat - <|> parseNotPat - <|> parseTuplePat - <|> parseInductivePat - <|> parseContPat - <|> parens (parseAndPat - <|> parseOrPat - <|> parseApplyPat - <|> parseLoopPat) +pattern' :: Parser EgisonPattern +pattern' = wildCard + <|> patVar + <|> varPat + <|> valuePat + <|> predPat + <|> cutPat + <|> notPat + <|> tuplePat + <|> inductivePat + <|> contPat + <|> parens (andPat + <|> orPat + <|> applyPat + <|> loopPat + <|> letPat) -parseWildCard :: Parser EgisonPattern -parseWildCard = reservedOp "_" >> pure WildCard +wildCard :: Parser EgisonPattern +wildCard = reservedOp "_" >> pure WildCard -parsePatVar :: Parser EgisonPattern -parsePatVar = P.lexeme lexer $ PatVar <$> parseVarName +patVar :: Parser EgisonPattern +patVar = P.lexeme lexer $ PatVar <$> varName -parseVarPat :: Parser EgisonPattern -parseVarPat = VarPat <$> ident +varPat :: Parser EgisonPattern +varPat = VarPat <$> ident -parseValuePat :: Parser EgisonPattern -parseValuePat = reservedOp "," >> ValuePat <$> parseExpr +valuePat :: Parser EgisonPattern +valuePat = reservedOp "," >> ValuePat <$> expr -parsePredPat :: Parser EgisonPattern -parsePredPat = reservedOp "?" >> PredPat <$> parseExpr +predPat :: Parser EgisonPattern +predPat = reservedOp "?" >> PredPat <$> expr -parseCutPat :: Parser EgisonPattern -parseCutPat = reservedOp "!" >> CutPat <$> parsePattern +letPat :: Parser EgisonPattern +letPat = keywordLet >> LetPat <$> bindings <*> pattern -parseNotPat :: Parser EgisonPattern -parseNotPat = reservedOp "^" >> NotPat <$> parsePattern +cutPat :: Parser EgisonPattern +cutPat = reservedOp "!" >> CutPat <$> pattern -parseTuplePat :: Parser EgisonPattern -parseTuplePat = brackets $ TuplePat <$> sepEndBy parsePattern whiteSpace +notPat :: Parser EgisonPattern +notPat = reservedOp "^" >> NotPat <$> pattern -parseInductivePat :: Parser EgisonPattern -parseInductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy parsePattern whiteSpace +tuplePat :: Parser EgisonPattern +tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace -parseContPat :: Parser EgisonPattern -parseContPat = reservedOp "..." >> pure ContPat +inductivePat :: Parser EgisonPattern +inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace -parseAndPat :: Parser EgisonPattern -parseAndPat = reservedOp "&" >> AndPat <$> sepEndBy parsePattern whiteSpace +contPat :: Parser EgisonPattern +contPat = reservedOp "..." >> pure ContPat -parseOrPat :: Parser EgisonPattern -parseOrPat = reservedOp "|" >> OrPat <$> sepEndBy parsePattern whiteSpace +andPat :: Parser EgisonPattern +andPat = reservedOp "&" >> AndPat <$> sepEndBy pattern whiteSpace -parseApplyPat :: Parser EgisonPattern -parseApplyPat = ApplyPat <$> parseExpr <*> sepEndBy parsePattern whiteSpace +orPat :: Parser EgisonPattern +orPat = reservedOp "|" >> OrPat <$> sepEndBy pattern whiteSpace -parseLoopPat :: Parser EgisonPattern -parseLoopPat = keywordLoop >> LoopPat <$> parseVarName <*> parseExpr <*> parsePattern <*> parsePattern +applyPat :: Parser EgisonPattern +applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace +loopPat :: Parser EgisonPattern +loopPat = keywordLoop >> LoopPat <$> varName <*> expr <*> pattern <*> option (NotPat WildCard) pattern + -- Constants -parseConstantExpr :: Parser EgisonExpr -parseConstantExpr = parseCharExpr - <|> parseStringExpr - <|> parseBoolExpr - <|> try parseFloatExpr - <|> parseIntegerExpr +constantExpr :: Parser EgisonExpr +constantExpr = charExpr + <|> stringExpr + <|> boolExpr + <|> try floatExpr + <|> integerExpr <|> (keywordSomething *> pure SomethingExpr) <|> (keywordUndefined *> pure UndefinedExpr) "constant" -parseCharExpr :: Parser EgisonExpr -parseCharExpr = CharExpr <$> charLiteral +charExpr :: Parser EgisonExpr +charExpr = CharExpr <$> charLiteral -parseStringExpr :: Parser EgisonExpr -parseStringExpr = StringExpr <$> stringLiteral +stringExpr :: Parser EgisonExpr +stringExpr = StringExpr <$> stringLiteral -parseBoolExpr :: Parser EgisonExpr -parseBoolExpr = BoolExpr <$> boolLiteral +boolExpr :: Parser EgisonExpr +boolExpr = BoolExpr <$> boolLiteral -parseIntegerExpr :: Parser EgisonExpr -parseIntegerExpr = IntegerExpr <$> integerLiteral +integerExpr :: Parser EgisonExpr +integerExpr = IntegerExpr <$> integerLiteral -parseFloatExpr :: Parser EgisonExpr -parseFloatExpr = FloatExpr <$> floatLiteral +floatExpr :: Parser EgisonExpr +floatExpr = FloatExpr <$> floatLiteral -- -- Tokens @@ -386,7 +403,7 @@ , "if" , "apply" , "lambda" - , "pattern-constructor" + , "pattern-function" , "letrec" , "let" , "loop" 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 @@ -87,6 +87,7 @@ | ValuePat EgisonExpr | PredPat EgisonExpr | IndexedPat EgisonPattern [EgisonExpr] + | LetPat [BindingExpr] EgisonPattern | CutPat EgisonPattern | NotPat EgisonPattern | AndPat [EgisonPattern] @@ -280,7 +281,7 @@ type PatternBinding = (Var, EgisonPattern) -data LoopContext = LoopContext (String, ObjectRef) ObjectRef EgisonPattern EgisonPattern +data LoopContext = LoopContext Binding ObjectRef EgisonPattern EgisonPattern -- -- Errors