egison 2.2.1 → 2.2.2

raw patch · 7 files changed

+167/−64 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +1/−1
• elisp/egison-mode.el +3/−1
• hs-src/Language/Egison/Core.hs +56/−7
• hs-src/Language/Egison/Numerical.hs +27/−46
• hs-src/Language/Egison/Parser.hs +17/−4
• hs-src/Language/Egison/Types.hs +57/−5
• lib/core/base.egi +6/−0

@@ -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.

@@ -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)))) 

@@ -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)                ] 

@@ -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

@@ -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))))

@@ -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 _) = "#<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 _) = "#<array>"+showVal (Array _ ns arr) = showArray ns $ elems arr showVal (Type _) = "#<type>" showVal (Destructor _) = "#<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))+       

@@ -39,6 +39,12 @@ (define $Char   (type     {[$var-match (lambda [$tgt] {tgt})]+     [$inductive-match+      (destructor+        {[,$c []+          {[$tgt (if (= tgt c)+                     {[]}+                     {})]}]})]      [$= eq-c?]}))  (define $String