diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -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 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 @@ -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) + + ] 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 @@ -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. diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -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) diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -49,6 +49,19 @@ {[ {}] [ {(fn x) @(map fn xs)}]}))) +(define $foldr + (lambda [$fn $init $ls] + (match ls (List Something) + {[ init] + [ (fn x (foldr fn init xs))]}))) + +(define $foldl + (lambda [$fn $init $ls] + (match ls (List Something) + {[ init] + [ (let {[$y (fn init x)]} + (foldl fn y xs))]}))) + (define $filter (lambda [$pred $ls] (match ls (List Something) diff --git a/sample/io-test.egi b/sample/io-test.egi deleted file mode 100644 --- a/sample/io-test.egi +++ /dev/null @@ -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) diff --git a/sample/io/argv-test.egi b/sample/io/argv-test.egi new file mode 100644 --- /dev/null +++ b/sample/io/argv-test.egi @@ -0,0 +1,6 @@ +(define $main + (lambda [$: $argv] + (do {[$: (write-string : "output : ")] + [$: (write : argv)] + [$: (write-char : '\n')]} + :))) diff --git a/sample/io/cat.egi b/sample/io/cat.egi new file mode 100644 --- /dev/null +++ b/sample/io/cat.egi @@ -0,0 +1,17 @@ +(define $main + (lambda [$: $argv] + (match argv (List String) + {[> + (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)]} + :)))] + [_ ]}))) + diff --git a/sample/io/char-test.egi b/sample/io/char-test.egi new file mode 100644 --- /dev/null +++ b/sample/io/char-test.egi @@ -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')]} + :))) diff --git a/sample/io/copy.egi b/sample/io/copy.egi new file mode 100644 --- /dev/null +++ b/sample/io/copy.egi @@ -0,0 +1,19 @@ +(define $main + (lambda [$: $argv] + (match argv (List String) + {[>> + (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)]} + :)))] + [_ ]}))) + diff --git a/sample/io/hello.egi b/sample/io/hello.egi new file mode 100644 --- /dev/null +++ b/sample/io/hello.egi @@ -0,0 +1,4 @@ +(define $main + (lambda [$: $argv] + (do {[$: (print : "Hello world!")]} + :))) diff --git a/sample/io/read-write-test.egi b/sample/io/read-write-test.egi new file mode 100644 --- /dev/null +++ b/sample/io/read-write-test.egi @@ -0,0 +1,9 @@ +(define $main + (lambda [$: $argv] + (do {[$: (write-string : "input : ")] + [$: (flush :)] + [[$: $val] (read :)] + [$: (write-string : "output : ")] + [$: (write : val)] + [$: (write-char : '\n')]} + :)))