egison 2.2.2 → 2.2.3

raw patch · 8 files changed

+131/−19 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +3/−3
• elisp/egison-mode.el +2/−0
• hs-src/Language/Egison/Core.hs +17/−9
• hs-src/Language/Egison/Numerical.hs +37/−2
• hs-src/Language/Egison/Parser.hs +2/−2
• hs-src/Language/Egison/Types.hs +3/−3
• lib/core/array.egi +37/−0
• sample/array-test.egi +30/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             2.2.2+Version:             2.2.3 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.@@ -16,8 +16,8 @@ Build-type:          Simple Cabal-version:       >=1.8 -Data-files:          lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/graph.egi lib/poker-hands.egi-                     sample/number-test.egi sample/collection-test.egi sample/graph-test.egi+Data-files:          lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/core/array.egi lib/graph.egi lib/poker-hands.egi+                     sample/number-test.egi sample/collection-test.egi sample/array-test.egi sample/graph-test.egi                      sample/poker-hands-test.egi sample/compile-test.egi                      sample/io/argv-test.egi sample/io/cat.egi sample/io/copy.egi sample/io/char-test.egi sample/io/hello.egi sample/io/read-write-test.egi                      elisp/egison-mode.el

@@ -20,6 +20,7 @@      "\\<loop\\>"      "\\<match\\>"      "\\<match-all\\>"+     "\\<generate-array\\>"       "\\\."      "\\\,"@@ -110,6 +111,7 @@         ((equal "match-all" name) 2)         ((equal "type" name) 2)         ((equal "destructor" name) 2)+        ((equal "generate-array" name) 2)         ))  (defun egison-indent-line ()

@@ -287,16 +287,15 @@   rangeObjRef <- liftIO $ makeClosure env rangeExpr   let loopObj = Loop loopVar indexVar rangeObjRef loopExpr tailExpr   expandLoop env loopObj-cEval1 (Closure env (ArrayMapExpr fnExpr arrExpr)) = do+cEval1 (Closure env (GenerateArrayExpr fnExpr rangeExpr)) = 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"+  rangeVal <- eval env rangeExpr+  ms <- liftThrows $ mapM unpackNum $ tupleToList rangeVal+  let d = fromIntegral $ length ms+  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 cEval1 (Closure env (ApplyExpr opExpr argExpr)) = do   op <- cEval1 (Closure env opExpr)   case op of@@ -991,11 +990,20 @@                ("eq-c?", charBoolBinop (==)),               ("eq-s?", strBoolBinop (==)),++              ("string-append", stringBinop (++)),               +              ("string-to-chars", stringToChars),+              ("chars-to-string", charsToString),+                             ("&&", boolBinop (&&)),               ("||", boolBinop (||)), +              ("tuple-to-collection", tupleToCollection),+              ("collection-to-tuple", collectionToTuple),+               ("array-dimension", arrayDimension),+              ("array-range", arrayRange),               ("array-size", arraySize),               ("array-keys", arrayKeys), 

@@ -31,6 +31,10 @@ floatBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal floatBinop op aparams = mapM unpackFloat aparams >>= return . Float . foldl1 op +stringBinop :: (String -> String -> String) -> [EgisonVal] -> ThrowsError EgisonVal+stringBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+stringBinop op aparams = mapM unpackString aparams >>= return . String . foldl1 op+ charBoolBinop :: (Char -> Char -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal charBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal charBoolBinop op aparams = mapM unpackChar aparams >>= doOp@@ -129,7 +133,6 @@  -- - end Numeric operations section - -- |Extract an bool from the given value, throwing a type error if --  the wrong type is passed. unpackBool :: EgisonVal -> ThrowsError Bool@@ -161,6 +164,34 @@ unpackFloat notFloat = throwError $ TypeMismatch "float" [notFloat]  +tupleToCollection :: [EgisonVal] -> ThrowsError EgisonVal+tupleToCollection vals = return $ Collection $ map Element vals++collectionToTuple :: [EgisonVal] -> ThrowsError EgisonVal+collectionToTuple [(Collection innerVals)] = do+  let vals = innerValsToList innerVals+  case vals of+    [val] -> return val+    _ -> return $ Tuple $ map Element vals+collectionToTuple [x] = throwError $ TypeMismatch "collection" [x]+collectionToTuple badArgList = throwError $ NumArgs 1 badArgList++stringToChars :: [EgisonVal] -> ThrowsError EgisonVal+stringToChars [(String str)] = return $ Collection $ map (\c -> Element $ Char c) str+stringToChars [x] = throwError $ TypeMismatch "string" [x]+stringToChars badArgList = throwError $ NumArgs 1 badArgList++charsToString :: [EgisonVal] -> ThrowsError EgisonVal+charsToString [(Collection innerVals)] = do+  let chars = innerValsToList innerVals+  cs <- mapM (\char -> case char of+                         Char c -> return c+                         _ -> throwError $ TypeMismatch "chars" [char])+             chars+  return $ String cs+charsToString [x] = throwError $ TypeMismatch "collection of chars" [x]+charsToString badArgList = throwError $ NumArgs 1 badArgList+ --------------------------------------------------- -- Array ---------------------------------------------------@@ -170,6 +201,11 @@ arrayDimension [x] = throwError $ TypeMismatch "array" [x] arrayDimension badArgList = throwError $ NumArgs 1 badArgList +arrayRange :: [EgisonVal] -> ThrowsError EgisonVal+arrayRange [(Array _ ns _)] = return $ Tuple $ map (Element . Number) ns+arrayRange [x] = throwError $ TypeMismatch "array" [x]+arrayRange badArgList = throwError $ NumArgs 1 badArgList+ arraySize :: [EgisonVal] -> ThrowsError EgisonVal arraySize [(Number m), (Array _ ns _)] = return $ Number $ nth m ns arraySize [x, y] = throwError $ TypeMismatch "number, array" [x, y]@@ -191,7 +227,6 @@        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 

@@ -481,10 +481,10 @@                  loopExpr <- lexeme parseExpr                  tailExpr <- lexeme parseExpr                  return (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr)-          <|> do try (string "array-map" >> many1 space)+          <|> do try (string "generate-array" >> many1 space)                  fnExpr <- lexeme parseExpr                  arrExpr <- lexeme parseExpr-                 return (ArrayMapExpr fnExpr arrExpr)+                 return (GenerateArrayExpr fnExpr arrExpr)           <|> do opExpr <- lexeme parseExpr                  argExprs <- sepEndBy parseExpr whiteSpace                  return (ApplyExpr opExpr (TupleExpr (map ElementExpr argExprs))))

@@ -110,7 +110,7 @@   | DestructorExpr DestructInfoExpr   | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause-  | ArrayMapExpr EgisonExpr EgisonExpr+  | GenerateArrayExpr EgisonExpr EgisonExpr   | ApplyExpr EgisonExpr EgisonExpr  deriving (Show) @@ -361,8 +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 (GenerateArrayExpr fnExpr arrExpr) =+  "(generate-array " ++ showExpr fnExpr ++ " " ++ showExpr arrExpr ++ " )" showExpr (ApplyExpr opExpr argExpr) =   "(" ++ showExpr opExpr ++ " " ++ showExpr argExpr ++ ")"   

@@ -0,0 +1,37 @@+;;+;; Array.egi+;;++(define $Array+  (lambda [$a]+    (type+      {[$var-match (lambda [$tgt] {tgt})]+       [$inductive-match+        (destructor+          {[<cons ,$key _ _> [a (Array a)]+            {[$arr (if (array-range? key arr)+                       {[(array-ref key arr) arr]}+                       {})]}]})]})))++(define $range-to-keys+  (lambda $ms+    (letrec {[$range-to-keys2+              (lambda [$ms]+                (match ms (List Integer)+                  {[<nil> {{}}]+                   [<cons $n $ns>+                    (let {[$iss (range-to-keys2 ns)]}+                      (concat (map (lambda [$i]+                                     (map (lambda [$is] {i @is})+                                          iss))+                                   (between 1 n))))]}))]}+      (map collection-to-tuple (range-to-keys2 (tuple-to-collection ms))))))++(define $keys-for-display+  (lambda [$mx $my]+    (let {[$xs (between 1 mx)]+          [$ys (reverse (between 1 my))]}+      (map (lambda [$y]+             (map (lambda [$x] [x y])+                  xs))+           ys))))

@@ -0,0 +1,30 @@+(define $ass [|[~1 2 3~]+               [~4 5 6~]+               [~7 8 9~]+               [~10 11 12~]|])++(test (array-dimension ass))++(test (array-size 1 ass))++(test (array-size 2 ass))++(test (array-range ass))++(test (array-ref [2 2] ass))++(test (array-ref [2 3] ass))++(test (array-range? [2 3] ass))++(test (array-range? [2 4] ass))++(test (generate-array (lambda [$i1 $i2] (* (array-ref [i1 i2] ass) 2)) (array-range ass)))++(define $bss (generate-array (lambda [$i1 $i2] (* (array-ref [i1 i2] ass) 2)) (array-range ass)))++(test (array-ref [2 3] bss))++(test (match ass (Array Integer)+        {[<cons ,[2 2] $n <cons ,[2 3] ,(+ n 1) _>> <ok>]+         [_ <ko>]}))