egison 2.1.10 → 2.1.11

raw patch · 12 files changed

+157/−113 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +7/−3
• hs-src/Language/Egison/Core.hs +6/−2
• hs-src/Language/Egison/Numerical.hs +6/−0
• hs-src/Language/Egison/Primitives.hs +60/−24
• lib/core/collection.egi +13/−0
• sample/io-test.egi +0/−84
• sample/io/argv-test.egi +6/−0
• sample/io/cat.egi +17/−0
• sample/io/char-test.egi +10/−0
• sample/io/copy.egi +19/−0
• sample/io/hello.egi +4/−0
• sample/io/read-write-test.egi +9/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             2.1.10+Version:             2.1.11 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,12 @@ 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 sample/io-test.egi sample/poker-hands-test.egi sample/compile-test.egi elisp/egison-mode.el etc/template.hs-+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+                     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+                     etc/template.hs  Library   Build-Depends:   base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths

@@ -316,7 +316,7 @@            Value (Tuple innerVals) -> do              objRefs <- liftIO $ mapM (newIORef . Value) $ innerValsToList innerVals              liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs-           _ -> throwError $ Default "extendLet: not tuple"+           _ -> liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss [objRef]  makeFrame :: Args -> ObjectRef -> IOThrowsError [(Var, ObjectRef)] makeFrame (AVar name) objRef = return $ [((name,[]), objRef)]@@ -834,5 +834,9 @@               ("eq-s?", strBoolBinop (==)),                              ("&&", boolBinop (&&)),-              ("||", boolBinop (||))]+              ("||", boolBinop (||)),++              ("eof?", isEgisonEOF)++              ] 

@@ -121,7 +121,13 @@ --floatToString [x] = throwError $ TypeMismatch "number" x --floatToString badArgList = throwError $ NumArgs 1 badArgList +isEgisonEOF :: [EgisonVal] -> ThrowsError EgisonVal+isEgisonEOF [EOF] = return $ Bool True+isEgisonEOF [_] = return $ Bool False+isEgisonEOF badArgList = throwError $ NumArgs 1 badArgList+ -- - end Numeric operations section+  -- |Extract an bool from the given value, throwing a type error if --  the wrong type is passed.

@@ -1,16 +1,15 @@ module Language.Egison.Primitives where-import Language.Egison.Numerical import Language.Egison.Parser import Language.Egison.Types-import qualified Control.Exception import Control.Monad.Error+import Control.Exception (try) import Data.Char hiding (isSymbol) import Data.Array import Data.Unique import qualified Data.Map import System.IO import System.Directory (doesFileExist, removeFile)-import System.IO.Error+import System.IO.Error hiding (try)  --------------------------------------------------- -- I/O Primitives@@ -72,21 +71,37 @@  readChar :: [EgisonVal] -> IOThrowsError EgisonVal readChar [World actions] = do-  c <- liftIO $ getChar-  let newWorld = World $ (ReadFromPort "stdin" [c]):actions-  return $ makeTupleFromValList [newWorld, Char c]+  liftIO $ hSetBuffering stdin NoBuffering+  input <- liftIO $ try (liftIO getChar)+  liftIO $ hSetBuffering stdin LineBuffering+  case input of+    Left e -> if isEOFError e+                then do+                  let newWorld = World $ (ReadFromPort "stdin" "EOF"):actions+                  return $ makeTupleFromValList [newWorld, EOF]+                else throwError $ Default "I/O error read-char"+    Right inpChr -> do+      let newWorld = World $ (ReadFromPort "stdin" [inpChr]):actions+      return $ makeTupleFromValList [newWorld, Char inpChr] readChar _ = throwError $ Default $ "readChar: invalid arguments"  readLine :: [EgisonVal] -> IOThrowsError EgisonVal readLine [World actions] = do-  str <- liftIO $ getLine-  let newWorld = World $ (ReadFromPort "stdin" str):actions-  return $ makeTupleFromValList [newWorld, String str]+  input <- liftIO $ try (liftIO getLine)+  case input of+    Left e -> if isEOFError e+                then do+                  let newWorld = World $ (ReadFromPort "stdin" "EOF"):actions+                  return $ makeTupleFromValList [newWorld, EOF]+                else throwError $ Default "I/O error read-line"+    Right inpStr -> do+      let newWorld = World $ (ReadFromPort "stdin" inpStr):actions+      return $ makeTupleFromValList [newWorld, String inpStr] readLine _ = throwError $ Default $ "readLine: invalid arguments"  readFromStdin :: [EgisonVal] -> IOThrowsError EgisonVal readFromStdin [World actions] = do-  str <- liftIO $ hGetExpr stdin+  str <- hGetExpr stdin   let newWorld = World $ (ReadFromPort "stdin" str):actions   expr <- liftThrows $ readExpr str   val <- liftThrows $ exprToVal expr@@ -132,21 +147,37 @@  readCharFromPort :: [EgisonVal] -> IOThrowsError EgisonVal readCharFromPort [World actions, Port filename port] = do-  c <- liftIO $ hGetChar port-  let newWorld = World $ (ReadFromPort filename [c]):actions-  return $ makeTupleFromValList [newWorld, Char c]+  liftIO $ hSetBuffering port NoBuffering+  input <- liftIO $ try (liftIO $ hGetChar port)+  liftIO $ hSetBuffering port LineBuffering+  case input of+    Left e -> if isEOFError e+                then do+                  let newWorld = World $ (ReadFromPort filename "EOF"):actions+                  return $ makeTupleFromValList [newWorld, EOF]+                else throwError $ Default "I/O error read-char-from-port"+    Right inpChr -> do+      let newWorld = World $ (ReadFromPort filename [inpChr]):actions+      return $ makeTupleFromValList [newWorld, Char inpChr] readCharFromPort _ = throwError $ Default $ "readCharFromPort: invalid arguments"  readLineFromPort :: [EgisonVal] -> IOThrowsError EgisonVal readLineFromPort [World actions, Port filename port] = do-  str <- liftIO $ hGetLine port-  let newWorld = World $ (ReadFromPort filename str):actions-  return $ makeTupleFromValList [newWorld, String str]+  input <- liftIO $ try (liftIO $ hGetLine port)+  case input of+    Left e -> if isEOFError e+                then do+                  let newWorld = World $ (ReadFromPort filename "EOF"):actions+                  return $ makeTupleFromValList [newWorld, EOF]+                else throwError $ Default "I/O error read-line-from-port"+    Right inpStr -> do+      let newWorld = World $ (ReadFromPort filename inpStr):actions+      return $ makeTupleFromValList [newWorld, String inpStr] readLineFromPort _ = throwError $ Default $ "readLineFromPort: invalid arguments"  readFromPort :: [EgisonVal] -> IOThrowsError EgisonVal readFromPort [World actions, Port filename port] = do-  str <- liftIO $ hGetExpr port+  str <- hGetExpr port   let newWorld = World $ (ReadFromPort filename str):actions   expr <- liftThrows $ readExpr str   val <- liftThrows $ exprToVal expr@@ -154,18 +185,23 @@ readFromPort _ = throwError $ Default $ "read: invalid arguments"  -hGetExpr :: Handle -> IO String+hGetExpr :: Handle -> IOThrowsError String hGetExpr h = do   str <- loop ""   return str  where-    loop :: String -> IO String+    loop :: String -> IOThrowsError String     loop input0 = do-      input <- hGetLine h-      let newInput = input0 ++ input-      if countParens newInput-        then return newInput-        else loop newInput+      input <- liftIO $ try (liftIO $ hGetLine h)+      case input of+        Left e -> if isEOFError e+                    then throwError $ Default "EOF error read or read-from-port"+                    else throwError $ Default "I/O error read or read-from-port"+        Right inpStr ->+          let newInput = input0 ++ inpStr in+          if countParens newInput+            then return newInput+            else loop newInput  countParens :: String -> Bool countParens str = let countOpen = length $ filter (\c -> ('(' == c)

@@ -49,6 +49,19 @@       {[<nil> {}]        [<cons $x $xs> {(fn x) @(map fn xs)}]}))) +(define $foldr+  (lambda [$fn $init $ls]+    (match ls (List Something)+      {[<nil> init]+       [<cons $x $xs> (fn x (foldr fn init xs))]})))++(define $foldl+  (lambda [$fn $init $ls]+    (match ls (List Something)+      {[<nil> init]+       [<cons $x $xs> (let {[$y (fn init x)]}+                        (foldl fn y xs))]})))+ (define $filter   (lambda [$pred $ls]     (match ls (List Something)

@@ -1,84 +0,0 @@-(define $main-  (lambda [$: $argv]-    (do {[$: (write : {1 2 3})]-         [$: (write-char : '\n')]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[$: (print : "Hello world!")]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[[$: $p] (open-output-file : "hello.txt")]-         [$: (print-to-port : p "Hello world!")]-         [$: (close-output-port : p)]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[$: (write-string : "input char : ")]-         [$: (flush :)]-         [[$: $c] (read-char :)]-         [$: (write-string : "output : ")]-         [$: (write-char : c)]-         [$: (write-char : '\n')]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[$: (write-string : "input : ")]-         [$: (flush :)]-         [[$: $str] (read-line :)]-         [$: (write-string : "output : ")]-         [$: (print : str)]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[$: (write-string : "input : ")]-         [$: (flush :)]-         [[$: $val] (read :)]-         [$: (write-string : "output : ")]-         [$: (write : val)]-         [$: (write-char : '\n')]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[$: (write-string : "input number : ")]-         [$: (flush :)]-         [[$: $num] (read :)]-         [$: (write-string : "output : ")]-         [$: (write : (+ num 1))]-         [$: (write-char : '\n')]}-        :)))--(define $main-  (lambda [$: $argv]-    (do {[$: (write-string : "output : ")]-         [$: (write : argv)]-         [$: (write-char : '\n')]}-        :)))--(define $main-  (lambda [$:]-    (do {[$: (print : "Return world? (y/n) : ")]-         [[$: $c] (read-char :)]}-        (match c Character-          {['y' :]-           ['n' 0]}))))--(execute)---(define $main-  (lambda [$:]-    (do {[$: (print : "Return world? (1/0) : ")]-         [[$: $n] (read :)]}-        (match n Integer-          {[,1 :]-           [,0 0]}))))--(execute)

@@ -0,0 +1,6 @@+(define $main+  (lambda [$: $argv]+    (do {[$: (write-string : "output : ")]+         [$: (write : argv)]+         [$: (write-char : '\n')]}+        :)))

@@ -0,0 +1,17 @@+(define $main+  (lambda [$: $argv]+    (match argv (List String)+      {[<cons $file1 <nil>>+        (do {[[$: $port] (open-input-file : file1)]}+            (letrec {[$copyLoop (lambda [$:]+                                  (do {[[$: $line] (read-line-from-port : port)]}+                                      (if (eof? line)+                                          :+                                          (do {[$: (write-string : line)]+                                               [$: (write-char : '\n')]}+                                              (copyLoop :)))))]}+              (do {[$: (copyLoop :)]+                   [$: (close-input-port : port)]}+                  :)))]+       [_ <argv-error>]})))+

@@ -0,0 +1,10 @@+(define $main+  (lambda [$: $argv]+    (do {[$: (write-string : "input char : ")]+         [$: (flush :)]+         [[$: $c] (read-char :)]+         [$: (write-char : '\n')]}+         [$: (write-string : "output : ")]+         [$: (write-char : c)]+         [$: (write-char : '\n')]}+        :)))

@@ -0,0 +1,19 @@+(define $main+  (lambda [$: $argv]+    (match argv (List String)+      {[<cons $file1 <cons $file2 <nil>>>+        (do {[[$: $port1] (open-input-file : file1)]+             [[$: $port2] (open-output-file : file2)]}+            (letrec {[$copyLoop (lambda [$:]+                                  (do {[[$: $line] (read-line-from-port : port1)]}+                                      (if (eof? line)+                                          :+                                          (do {[$: (write-string-to-port : port2 line)]+                                               [$: (write-char-to-port : port2 '\n')]}+                                              (copyLoop :)))))]}+              (do {[$: (copyLoop :)]+                   [$: (close-output-port : port2)]+                   [$: (close-input-port : port1)]}+                  :)))]+       [_ <argv-error>]})))+

@@ -0,0 +1,4 @@+(define $main+  (lambda [$: $argv]+    (do {[$: (print : "Hello world!")]}+        :)))

@@ -0,0 +1,9 @@+(define $main+  (lambda [$: $argv]+    (do {[$: (write-string : "input : ")]+         [$: (flush :)]+         [[$: $val] (read :)]+         [$: (write-string : "output : ")]+         [$: (write : val)]+         [$: (write-char : '\n')]}+        :)))