diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.2.1 +Version: 2.2.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. diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -24,6 +24,7 @@ "\\\." "\\\," "\\\!" + "`" "\\\~" "\\\#" "|" @@ -94,7 +95,8 @@ ((eq (string-to-char (thing-at-point 'char)) 91) (forward-char) (if (eq (string-to-char (thing-at-point 'char)) 124) - (+ 2 cp))) + (+ 2 cp) + (+ 1 cp))) (t (+ 1 cp))))) 0)))) 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 @@ -38,6 +38,7 @@ _ <- evalString env $ "(load \"lib/core/base.egi\")" _ <- evalString env $ "(load \"lib/core/number.egi\")" _ <- evalString env $ "(load \"lib/core/collection.egi\")" + _ <- evalString env $ "(load \"lib/core/array.egi\")" return () @@ -170,9 +171,29 @@ cEval1 (Closure env (CollectionExpr innerExprs)) = do innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs return $ Intermidiate $ ICollection innerRefs -cEval1 (Closure env (ArrayExpr exprs)) = do - vals <- mapM (eval env) exprs - return $ Value $ Array $ listArray (1, (length vals)) vals +cEval1 (Closure env (ArrayExpr innerArrayExprs)) = do + let dimension = calcDimension innerArrayExprs + let size = calcSize innerArrayExprs + elemExprs <- liftThrows $ calcElemExprs innerArrayExprs + vals <- mapM (eval env) elemExprs + return $ Value $ Array dimension size $ listArray (1, (fromIntegral (length vals))) vals + where calcDimension aExprs = helper 1 aExprs + where helper n [] = n + helper n ((AElementExpr _):_) = n + helper n ((AInnerArrayExpr inner):_) = helper (n + 1) inner + calcSize aExprs = helper [] aExprs + where helper ns [] = ns ++ [0] + helper ns aExprs2@((AElementExpr _):_) = ns ++ [(fromIntegral (length aExprs2))] + helper ns aExprs2@((AInnerArrayExpr inner):_) = helper (ns ++ [(fromIntegral (length aExprs2))]) inner + calcElemExprs [] = return [] + calcElemExprs aExprs@((AElementExpr _):_) = mapM (\aExpr -> case aExpr of + AElementExpr expr -> return expr + _ -> throwError $ Default "type error in array") + aExprs + calcElemExprs aExprs@((AInnerArrayExpr _):_) = liftM concat $ mapM (\aExpr -> case aExpr of + AInnerArrayExpr aExprs2 -> calcElemExprs aExprs2 + _ -> throwError $ Default "type error in array") + aExprs cEval1 (Closure _ WildCardExpr) = return $ Value WildCard cEval1 (Closure env (PatVarExpr name numExprs)) = do numVals <- mapM (eval env) numExprs @@ -266,6 +287,16 @@ rangeObjRef <- liftIO $ makeClosure env rangeExpr let loopObj = Loop loopVar indexVar rangeObjRef loopExpr tailExpr expandLoop env loopObj +cEval1 (Closure env (ArrayMapExpr fnExpr arrExpr)) = do + fnObjRef <- liftIO $ makeClosure env fnExpr + arrObj <- cEval1 (Closure env arrExpr) + case arrObj of + Value (Array d ms _) -> do + let is = map (\iss -> (Value . Tuple) $ map (Element . Number) iss) $ indexList ms + isRefs <- liftIO $ mapM newIORef is + vals <- mapM (cApply fnObjRef) isRefs + return $ Value $ Array d ms $ listArray (1, (fromIntegral (length vals))) vals + _ -> throwError $ Default "array-map: not array" cEval1 (Closure env (ApplyExpr opExpr argExpr)) = do op <- cEval1 (Closure env opExpr) case op of @@ -285,6 +316,21 @@ _ -> throwError $ Default "not function" cEval1 val = return val +cApply :: ObjectRef -> ObjectRef -> IOThrowsError EgisonVal +cApply fnObjRef argObjRef = do + fnObj <- cRefEval1 fnObjRef + case fnObj of + Value (IOFunc fn) -> do arg <- cRefEval argObjRef + val <- fn (tupleToList arg) + return $ val + Value (PrimitiveFunc fn) -> do arg <- cRefEval argObjRef + val <- liftThrows $ fn (tupleToList arg) + return $ val + Value (Func fArgs body cEnv) -> do frame <- makeFrame fArgs argObjRef + newEnv <- liftIO $ extendEnv cEnv frame + cEval (Closure newEnv body) + _ -> throwError $ Default "cApply1 not function" + cApply1 :: ObjectRef -> ObjectRef -> IOThrowsError Object cApply1 fnObjRef argObjRef = do fnObj <- cRefEval1 fnObjRef @@ -949,16 +995,19 @@ ("&&", boolBinop (&&)), ("||", boolBinop (||)), - ("eof?", isEgisonEOF), - ("array-dimension", arrayDimension), ("array-size", arraySize), + ("array-keys", arrayKeys), + ("array-range?", arrayIsRange), + ("array-ref", arrayRef), -- ("array-sub-ref", arrayRef), - ("array-to-collection", arrayToCollection), - ("collection-to-array", collectionToArray) +-- ("array-to-collection", arrayToCollection), +-- ("collection-to-array", collectionToArray), + + ("eof?", isEgisonEOF) ] diff --git a/hs-src/Language/Egison/Numerical.hs b/hs-src/Language/Egison/Numerical.hs --- a/hs-src/Language/Egison/Numerical.hs +++ b/hs-src/Language/Egison/Numerical.hs @@ -166,59 +166,40 @@ --------------------------------------------------- arrayDimension :: [EgisonVal] -> ThrowsError EgisonVal -arrayDimension [val] = helper 0 val - where helper d (Array arr) = - let xs = elems arr in - case xs of - [] -> return $ Number (d + 1) - (e:_) -> case e of - Array _ -> helper (d + 1) e - _ -> return $ Number (d + 1) - helper d _ = return $ Number d +arrayDimension [(Array d _ _)] = return $ Number d +arrayDimension [x] = throwError $ TypeMismatch "array" [x] arrayDimension badArgList = throwError $ NumArgs 1 badArgList arraySize :: [EgisonVal] -> ThrowsError EgisonVal -arraySize [(Number n), val@(Array _)] = helper n val - where helper 1 (Array arr) = return $ Number $ fromIntegral $ length $ indices arr - helper n2 (Array arr) = - if n2 > 1 - then let xs = elems arr in - case xs of - (e:_) -> case e of - Array _ -> helper (n2 - 1) e - _ -> throwError $ Default "arraySize: larger dimention size than actual" - _ -> throwError $ Default "arraySize: larger dimention size than actual" - else throwError $ Default "arraySize: dimention size must be more than 1" - helper _ _ = throwError $ Default "arraySize: type mismatch" +arraySize [(Number m), (Array _ ns _)] = return $ Number $ nth m ns arraySize [x, y] = throwError $ TypeMismatch "number, array" [x, y] arraySize badArgList = throwError $ NumArgs 2 badArgList +arrayKeys :: [EgisonVal] -> ThrowsError EgisonVal +arrayKeys [(Array _ ms _)] = return $ Collection $ map (\iss -> (Element . Tuple) $ map (Element . Number) iss) $ indexList ms +arrayKeys [x] = throwError $ TypeMismatch "array" [x] +arrayKeys badArgList = throwError $ NumArgs 1 badArgList + +arrayIsRange :: [EgisonVal] -> ThrowsError EgisonVal +arrayIsRange [key, (Array _ ms _)] = do + ns <- mapM (\val -> case val of + Number n -> return n + _ -> throwError $ TypeMismatch "number" [val]) + (tupleToList key) + return $ Bool $ helper ns ms + where helper [] [] = True + helper (n:ns) (m:ms) = if (n > 0 && n <= m) + then helper ns ms + else False + +arrayIsRange [x, y] = throwError $ TypeMismatch "key, array" [x, y] +arrayIsRange badArgList = throwError $ NumArgs 2 badArgList + arrayRef :: [EgisonVal] -> ThrowsError EgisonVal -arrayRef [tuple, val@(Array _)] = do ns <- mapM unpackNum $ tupleToList tuple - helper ns val - where helper [n] (Array arr) = return (arr ! (fromIntegral n)) - helper (n:ns) (Array arr) = - if n > 0 - then let e = arr ! (fromIntegral n) in - case e of - Array _ -> helper ns e - _ -> throwError $ Default "arraySize: larger dimention size than actual" - else throwError $ Default "arrayRef: index number should be more than 0" - helper _ _ = throwError $ Default "arraySize: type mismatch" +arrayRef [tuple, (Array _ ms arr)] = do + ns <- mapM unpackNum $ tupleToList tuple + let i = integersToInteger ms ns + return $ (arr ! i) arrayRef [x, y] = throwError $ TypeMismatch "tuple of number, array" [x, y] arrayRef badArgList = throwError $ NumArgs 2 badArgList -arrayToCollection :: [EgisonVal] -> ThrowsError EgisonVal -arrayToCollection [val@(Array _)] = helper val - where helper (Array arr) = do es <- mapM helper $ elems arr - return $ Collection (map Element es) - helper val2 = return val2 -arrayToCollection [x] = throwError $ TypeMismatch "array" [x] -arrayToCollection badArgList = throwError $ NumArgs 1 badArgList - -collectionToArray :: [EgisonVal] -> ThrowsError EgisonVal -collectionToArray [(Collection innerVals)] = - let vals = innerValsToList innerVals in - return $ Array $ listArray (1, (length vals)) vals -collectionToArray [x] = throwError $ TypeMismatch "collection" [x] -collectionToArray badArgList = throwError $ NumArgs 1 badArgList 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 @@ -237,13 +237,13 @@ parsePatVarOmitExpr :: Parser EgisonExpr parsePatVarOmitExpr = do - string "$~" + string "$`" expr <- lexeme parseExpr return $ PatVarOmitExpr expr parseVarOmitExpr :: Parser EgisonExpr parseVarOmitExpr = do - char '~' + char '`' expr <- lexeme parseExpr return $ VarOmitExpr expr @@ -389,7 +389,16 @@ parseMatchClause = brackets (do pat <- lexeme parseExpr body <- lexeme parseExpr return (pat, body)) - + +parseArrayElementExpr :: Parser ArrayElementExpr +parseArrayElementExpr = + do try (lexeme (string "[~")) + exprs <- sepEndBy parseArrayElementExpr whiteSpace + (lexeme (string "~]")) + return (AInnerArrayExpr exprs) + <|> do expr <- parseExpr + return (AElementExpr expr) + -- |Parse an expression parseExpr :: Parser EgisonExpr parseExpr = @@ -404,7 +413,7 @@ <|> lexeme parseVarOmitExpr <|> lexeme parseVar <|> do try (lexeme (string "[|")) - exprs <- sepEndBy parseExpr whiteSpace + exprs <- sepEndBy parseArrayElementExpr whiteSpace (lexeme (string "|]")) return (ArrayExpr exprs) <|> angles (do cons <- lexeme identifier @@ -472,6 +481,10 @@ loopExpr <- lexeme parseExpr tailExpr <- lexeme parseExpr return (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr) + <|> do try (string "array-map" >> many1 space) + fnExpr <- lexeme parseExpr + arrExpr <- lexeme parseExpr + return (ArrayMapExpr fnExpr arrExpr) <|> do opExpr <- lexeme parseExpr argExprs <- sepEndBy parseExpr whiteSpace return (ApplyExpr opExpr (TupleExpr (map ElementExpr argExprs)))) 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 @@ -1,9 +1,7 @@ module Language.Egison.Types where import Control.Monad.Error -import Data.Complex() import Data.Array -import Data.Dynamic() import Data.IORef import qualified Data.Map -- import Data.Maybe @@ -98,7 +96,7 @@ | InductiveDataExpr String [EgisonExpr] | TupleExpr [InnerExpr] | CollectionExpr [InnerExpr] - | ArrayExpr [EgisonExpr] + | ArrayExpr [ArrayElementExpr] | FuncExpr Args EgisonExpr | MacroExpr [String] EgisonExpr | LoopExpr String String EgisonExpr EgisonExpr EgisonExpr @@ -112,9 +110,14 @@ | DestructorExpr DestructInfoExpr | MatchExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllExpr EgisonExpr EgisonExpr MatchClause + | ArrayMapExpr EgisonExpr EgisonExpr | ApplyExpr EgisonExpr EgisonExpr deriving (Show) +data ArrayElementExpr = AElementExpr EgisonExpr + | AInnerArrayExpr [ArrayElementExpr] + deriving (Show) + type ArgsExpr = Args type MatchClause = (EgisonExpr, EgisonExpr) @@ -173,7 +176,7 @@ | InductiveData String [EgisonVal] | Tuple [InnerVal] | Collection [InnerVal] - | Array (Array Int EgisonVal) + | Array Integer [Integer] (Array Integer EgisonVal) | Type Frame | Destructor DestructInfo | Func Args EgisonExpr Env @@ -332,6 +335,7 @@ showExpr (InductiveDataExpr cons exprs) = "<" ++ cons ++ " " ++ unwordsExpr exprs ++ ">" showExpr (TupleExpr _) = "[...]" showExpr (CollectionExpr _) = "{...}" +showExpr (ArrayExpr _) = "[|...|]" showExpr (FuncExpr _ _) = "(lambda [" ++ "..." ++ "] ...)" showExpr (MacroExpr _ _) = @@ -357,6 +361,8 @@ "(match " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)" showExpr (MatchAllExpr tgtExpr typExpr _) = "(match-all " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)" +showExpr (ArrayMapExpr fnExpr arrExpr) = + "(array-map " ++ showExpr fnExpr ++ " " ++ showExpr arrExpr ++ " )" showExpr (ApplyExpr opExpr argExpr) = "(" ++ showExpr opExpr ++ " " ++ showExpr argExpr ++ ")" @@ -399,6 +405,22 @@ instance Eq EgisonVal where x == y = eqVal x y +showArray :: [Integer] -> [EgisonVal] -> String +showArray ns vals = "[|" ++ helper ns vals ++ "|]" + where helper [_] vals2 = unwordsList vals2 + helper (_:ns2) vals2 = let xss = divideList (multiplyList ns2) vals2 in + concat $ map (\xs -> "[~" ++ helper ns2 xs ++ "~]") xss + where divideList :: Integer -> [a] -> [[a]] + divideList n ls = helper2 n [] ls + where helper2 _ ret [] = ret + helper2 n2 ret xs = let (hs, ts) = divideList2 n2 xs in + helper2 n2 (ret ++ [hs]) ts + divideList2 :: Integer -> [a] -> ([a], [a]) + divideList2 n xs = helper2 n [] xs + where helper2 0 hs ts = (hs, ts) + helper2 n2 hs (x:ts) = helper2 (n2 - 1) (hs ++ [x]) ts + + showVal :: EgisonVal -> String showVal (World _) = "#" showVal (Bool True) = "#t" @@ -419,7 +441,7 @@ showVal (InductiveData cons args) = "<" ++ cons ++ " " ++ unwordsList args ++ ">" showVal (Tuple innerVals) = "[" ++ showInnerVals innerVals ++ "]" showVal (Collection innerVals) = "{" ++ showInnerVals innerVals ++ "}" -showVal (Array _) = "#" +showVal (Array _ ns arr) = showArray ns $ elems arr showVal (Type _) = "#" showVal (Destructor _) = "#" showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)" @@ -472,3 +494,33 @@ -- - utility stringToCharCollection :: String -> IO EgisonVal stringToCharCollection = undefined + + + + + + +--- extra + +nth :: Integer -> [a] -> a +nth 1 (x:xs) = x +nth n (x:xs) = nth (n - 1) xs + +integersToInteger :: [Integer] -> [Integer] -> Integer +integersToInteger [_] [n] = n +integersToInteger (_:ms) (n:ns) = (n - 1) * (multiplyList ms) + integersToInteger ms ns + +multiplyList :: [Integer] -> Integer +multiplyList [n] = n +multiplyList (n:ns) = n * (multiplyList ns) + +indexList :: [Integer] -> [[Integer]] +indexList [m] = map (\i -> [i]) $ betweenNumbers 1 m +indexList (m:ms) = concat $ map (\n -> map (\is -> n:is) $ indexList ms) + (betweenNumbers 1 m) + +betweenNumbers :: Integer -> Integer -> [Integer] +betweenNumbers m n = if m == n + then [n] + else (m:(betweenNumbers (m + 1) n)) + diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -39,6 +39,12 @@ (define $Char (type {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (destructor + {[,$c [] + {[$tgt (if (= tgt c) + {[]} + {})]}]})] [$= eq-c?]})) (define $String