diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.1.15 +Version: 2.1.16 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. @@ -29,10 +29,10 @@ Exposed-Modules: Language.Egison.Core Language.Egison.Types Language.Egison.Variables --- Language.Egison.Compiler Language.Egison.Numerical Language.Egison.Parser Language.Egison.Primitives + Language.Egison.Macro Other-modules: Paths_egison diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -26,6 +26,7 @@ "\\\~" "\\\#" "|" + "%" "\\\&" "@" "\\<_\\>" 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 @@ -4,6 +4,7 @@ import Language.Egison.Primitives import Language.Egison.Types import Language.Egison.Variables +import Language.Egison.Macro import Control.Monad.Error import Data.Array import qualified Data.Map @@ -193,6 +194,8 @@ return $ Value $ AndPat patObjRefs cEval1 (Closure env (FuncExpr args body)) = do return $ Value $ Func args body env +cEval1 (Closure _ (MacroExpr args body)) = do + return $ Value $ Macro args body cEval1 (Closure env (IfExpr condExpr expr1 expr2)) = do obj <- cEval1 $ Closure env condExpr case obj of @@ -268,6 +271,10 @@ Value (Func fArgs body cEnv) -> do frame <- liftIO (makeClosure env argExpr) >>= makeFrame fArgs newEnv <- liftIO $ extendEnv cEnv frame cEval1 (Closure newEnv body) + Value (Macro mArgs body) -> do argExprs <- liftThrows $ tupleExprToExprList argExpr + newBody <- expandMacro (Data.Map.fromList (zip mArgs argExprs)) body + liftIO $ putStrLn $ showExpr newBody + cEval1 (Closure env newBody) _ -> throwError $ Default "not function" cEval1 val = return val @@ -275,7 +282,9 @@ cApply1 fnObjRef argObjRef = do fnObj <- cRefEval1 fnObjRef case fnObj of - Value (IOFunc fn) -> throwError $ Default "undefined ioFunc" + Value (IOFunc fn) -> do arg <- cRefEval argObjRef + val <- fn (tupleToList arg) + return $ Value val Value (PrimitiveFunc fn) -> do arg <- cRefEval argObjRef val <- liftThrows $ fn (tupleToList arg) return $ Value val @@ -336,6 +345,16 @@ return $ concat frames _ -> throwError $ Default "makeFrame: not tuple" +tupleExprToExprList :: EgisonExpr -> ThrowsError [EgisonExpr] +tupleExprToExprList (TupleExpr innerExprs) = innerExprsToExprList innerExprs +tupleExprToExprList expr = return [expr] + +innerExprsToExprList :: [InnerExpr] -> ThrowsError [EgisonExpr] +innerExprsToExprList [] = return [] +innerExprsToExprList ((ElementExpr expr):rest) = do retRest <- innerExprsToExprList rest + return (expr:retRest) +innerExprsToExprList ((SubCollectionExpr _):_) = throwError $ Default "innerExprsToExprList: subcollection is not supported" + innerValRefsToObjRefList :: [InnerValRef] -> IOThrowsError [ObjectRef] innerValRefsToObjRefList [] = return [] innerValRefsToObjRefList (innerRef:rest) = do diff --git a/hs-src/Language/Egison/Macro.hs b/hs-src/Language/Egison/Macro.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Macro.hs @@ -0,0 +1,88 @@ +module Language.Egison.Macro where +import Language.Egison.Types +import qualified Data.Map + +type MacroFrame = Data.Map.Map String EgisonExpr + +getExpr :: MacroFrame -> String -> Maybe EgisonExpr +getExpr frame name = Data.Map.lookup name frame + +expandMacro :: MacroFrame -> EgisonExpr -> IOThrowsError EgisonExpr +expandMacro frame (VarExpr name []) = + case getExpr frame name of + Nothing -> return $ MacroVarExpr name [] + Just expr -> return expr +expandMacro frame (PatVarOmitExpr expr) = do + newExpr <- expandMacro frame expr + case newExpr of + MacroVarExpr name numExprs -> return $ PatVarExpr name numExprs + _ -> return $ PatVarOmitExpr newExpr +expandMacro frame (VarOmitExpr expr) = do + newExpr <- expandMacro frame expr + case newExpr of + MacroVarExpr name numExprs -> return $ VarExpr name numExprs + _ -> return $ VarOmitExpr newExpr +expandMacro frame (InductiveDataExpr cons exprs) = do + newExprs <- mapM (expandMacro frame) exprs + return $ InductiveDataExpr cons newExprs +expandMacro frame (TupleExpr innerExprs) = do + newInnerExprs <- mapM (expandMacroInnerExpr frame) innerExprs + return $ TupleExpr newInnerExprs +expandMacro frame (CollectionExpr innerExprs) = do + newInnerExprs <- mapM (expandMacroInnerExpr frame) innerExprs + return $ CollectionExpr newInnerExprs +expandMacro frame (PredPatExpr predName argExprs) = do + newArgExprs <- mapM (expandMacro frame) argExprs + return $ PredPatExpr predName newArgExprs +expandMacro frame (CutPatExpr patExpr) = do + newPatExpr <- expandMacro frame patExpr + return $ CutPatExpr newPatExpr +expandMacro frame (NotPatExpr patExpr) = do + newPatExpr <- expandMacro frame patExpr + return $ CutPatExpr newPatExpr +expandMacro frame (OrPatExpr patExprs) = do + newPatExprs <- mapM (expandMacro frame) patExprs + return $ OrPatExpr newPatExprs +expandMacro frame (AndPatExpr patExprs) = do + newPatExprs <- mapM (expandMacro frame) patExprs + return $ AndPatExpr newPatExprs +expandMacro frame (FuncExpr args body) = do + newBody <- expandMacro frame body + return $ FuncExpr args newBody +expandMacro frame (IfExpr condExpr expr1 expr2) = do + newCondExpr <- expandMacro frame condExpr + newExpr1 <- expandMacro frame expr1 + newExpr2 <- expandMacro frame expr2 + return $ IfExpr newCondExpr newExpr1 newExpr2 +expandMacro frame (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr) = do + newRangeExpr <- expandMacro frame rangeExpr + newLoopExpr <- expandMacro frame loopExpr + newTailExpr <- expandMacro frame tailExpr + return $ LoopExpr loopVar indexVar newRangeExpr newLoopExpr newTailExpr +--expandMacro frame (LetExpr bindings body) = undefined +--expandMacro frame (LetRecExpr bindings body) = undefined +expandMacro frame (MatchExpr tgtExpr typExpr mcs) = do + newTgtExpr <- expandMacro frame tgtExpr + newTypExpr <- expandMacro frame typExpr + newMcs <- mapM (expandMacroMatchClause frame) mcs + return $ MatchExpr newTgtExpr newTypExpr newMcs +expandMacro frame (MatchAllExpr tgtExpr typExpr mc) = do + newTgtExpr <- expandMacro frame tgtExpr + newTypExpr <- expandMacro frame typExpr + newMc <- expandMacroMatchClause frame mc + return $ MatchAllExpr newTgtExpr newTypExpr newMc +expandMacro _ expr = return expr + +expandMacroMatchClause :: MacroFrame -> MatchClause -> IOThrowsError MatchClause +expandMacroMatchClause frame (patExpr, body) = do + newPatExpr <- expandMacro frame patExpr + newBody <- expandMacro frame body + return (newPatExpr, newBody) + +expandMacroInnerExpr :: MacroFrame -> InnerExpr -> IOThrowsError InnerExpr +expandMacroInnerExpr frame (ElementExpr expr) = do + newExpr <- expandMacro frame expr + return $ ElementExpr newExpr +expandMacroInnerExpr frame (SubCollectionExpr expr) = do + newExpr <- expandMacro frame expr + return $ SubCollectionExpr newExpr 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 @@ -228,16 +228,25 @@ parsePatVar = do (name, nums) <- parsePatVar2 return $ PatVarExpr name nums -parseSymbol2 :: Parser VarExpr -parseSymbol2 = do char '#' - name <- identifier - nums <- lexeme parseIndexNums - return (name, nums) +parseMacroVarExpr :: Parser EgisonExpr +parseMacroVarExpr = do + char '%' + name <- identifier + nums <- lexeme parseIndexNums + return $ MacroVarExpr name nums -parseSymbol :: Parser EgisonExpr -parseSymbol = do (name, nums) <- parseSymbol2 - return $ SymbolExpr name nums - +parsePatVarOmitExpr :: Parser EgisonExpr +parsePatVarOmitExpr = do + string "$~" + expr <- lexeme parseExpr + return $ PatVarOmitExpr expr + +parseVarOmitExpr :: Parser EgisonExpr +parseVarOmitExpr = do + char '~' + expr <- lexeme parseExpr + return $ VarOmitExpr expr + parseArgs :: Parser ArgsExpr parseArgs = do try (do (name, _) <- lexeme parsePatVar2 @@ -370,9 +379,10 @@ <|> lexeme parseChar <|> lexeme parseString <|> try (lexeme parseBool) - <|> try (lexeme parseSymbol) <|> try (lexeme parsePattern) --- <|> lexeme parsePatVarOmitExpr + <|> lexeme parseMacroVarExpr + <|> lexeme parsePatVarOmitExpr + <|> lexeme parseVarOmitExpr <|> lexeme parseVar <|> angles (do cons <- lexeme identifier argExprs <- sepEndBy parseExpr whiteSpace @@ -385,6 +395,12 @@ args <- lexeme parseArgs body <- lexeme parseExpr return (FuncExpr args body) + <|> do try (string "macro" >> many1 space) + args <- lexeme (brackets (sepEndBy (do (name, _) <- parsePatVar2 + return name) + whiteSpace)) + body <- lexeme parseExpr + return (MacroExpr args body) <|> do try (string "if" >> many1 space) condExpr <- lexeme parseExpr expr1 <- lexeme parseExpr 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 @@ -84,10 +84,11 @@ | NumberExpr Integer | FloatExpr Double | VarExpr String [EgisonExpr] - | SymbolExpr String [EgisonExpr] + | MacroVarExpr String [EgisonExpr] + | PatVarOmitExpr EgisonExpr + | VarOmitExpr EgisonExpr | PatVarExpr String [EgisonExpr] | WildCardExpr - | PatVarOmitExpr EgisonExpr | CutPatExpr EgisonExpr | NotPatExpr EgisonExpr | AndPatExpr [EgisonExpr] @@ -97,6 +98,7 @@ | TupleExpr [InnerExpr] | CollectionExpr [InnerExpr] | FuncExpr Args EgisonExpr + | MacroExpr [String] EgisonExpr | LoopExpr String String EgisonExpr EgisonExpr EgisonExpr | ParamsExpr String EgisonExpr EgisonExpr | IfExpr EgisonExpr EgisonExpr EgisonExpr @@ -166,6 +168,7 @@ | Type Frame | Destructor DestructInfo | Func Args EgisonExpr Env + | Macro [String] EgisonExpr | PrimitiveFunc ([EgisonVal] -> ThrowsError EgisonVal) | IOFunc ([EgisonVal] -> IOThrowsError EgisonVal) | Port String Handle @@ -270,6 +273,10 @@ unwordsList :: Show a => [a] -> String unwordsList = unwords . map show +-- |Convert a list of Egison expressions into a space-separated string +unwordsExpr :: [EgisonExpr] -> String +unwordsExpr = unwords . map showExpr + -- |Convert a list of Egison expressions into a '_'-separated string unwordsNumExprs :: [EgisonExpr] -> String unwordsNumExprs [] = "" @@ -301,20 +308,24 @@ showExpr (NumberExpr contents) = show contents showExpr (FloatExpr contents) = show contents showExpr (VarExpr name nums) = name ++ unwordsNumExprs nums -showExpr (SymbolExpr name nums) = "#" ++ name ++ unwordsNumExprs nums +showExpr (MacroVarExpr name nums) = "%" ++ name ++ unwordsNumExprs nums showExpr (PatVarExpr name nums) = "$" ++ name ++ unwordsNumExprs nums showExpr WildCardExpr = "_" -showExpr (PatVarOmitExpr pvar) = "(omit " ++ showExpr pvar ++ ")" +showExpr (PatVarOmitExpr pvar) = "$~" ++ showExpr pvar +showExpr (VarOmitExpr pvar) = "~" ++ showExpr pvar showExpr (CutPatExpr _) = "#" showExpr (NotPatExpr _) = "#" showExpr (AndPatExpr _) = "#" showExpr (OrPatExpr _) = "#" showExpr (PredPatExpr _ _) = "#" -showExpr (InductiveDataExpr cons _) = "<" ++ cons ++ "...>" +showExpr (InductiveDataExpr cons []) = "<" ++ cons ++ ">" +showExpr (InductiveDataExpr cons exprs) = "<" ++ cons ++ " " ++ unwordsExpr exprs ++ ">" showExpr (TupleExpr _) = "[...]" showExpr (CollectionExpr _) = "{...}" showExpr (FuncExpr _ _) = "(lambda [" ++ "..." ++ "] ...)" +showExpr (MacroExpr _ _) = + "(macro [" ++ "..." ++ "] ...)" showExpr (LoopExpr lVar iVar rExpr lExpr tExpr) = "(loop $" ++ lVar ++ " $" ++ iVar ++ " " ++ showExpr rExpr ++ " " ++ showExpr lExpr ++ " " ++ showExpr tExpr ++ ")" showExpr (ParamsExpr pVar pExpr body) =