diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.11 +Version: 3.2.12 Synopsis: Programming language with non-linear pattern-matching against unfree data types Description: An interpreter for Egison, the programming langugage that realized non-linear pattern-matching with unfree data types. With Egison, you can represent pattern-matching with unfree data types intuitively, @@ -17,7 +17,7 @@ Extra-Source-Files: benchmark/Benchmark.hs -Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/string.egi lib/core/database.egi +Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/string.egi lib/core/database.egi lib/core/io.egi lib/tree/xml.egi lib/math/prime.egi elisp/egison-mode.el diff --git a/hs-src/Interpreter/egisoni.hs b/hs-src/Interpreter/egisoni.hs --- a/hs-src/Interpreter/egisoni.hs +++ b/hs-src/Interpreter/egisoni.hs @@ -10,6 +10,9 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error +import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) +import qualified Data.Sequence as Sq + import Data.Version import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 () @@ -44,7 +47,7 @@ either print (const $ return ()) result Options {optLoadOnly = False} -> do env <- primitiveEnv >>= loadLibraries - result <- evalEgisonTopExprs env [LoadFile file, Execute args] + result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))] either print (const $ return ()) result data Options = Options { diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -70,6 +70,7 @@ , "lib/core/natural-number.egi" , "lib/core/string.egi" , "lib/core/database.egi" + , "lib/core/io.egi" ] fromEgisonM :: EgisonM a -> IO (Either EgisonError a) 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 @@ -61,9 +61,8 @@ val <- evalExpr' env expr liftIO $ print val return env -evalTopExpr env (Execute argv) = do - main <- refVar env "main" >>= evalRef - io <- applyFunc main $ Value $ Collection $ Sq.fromList $ map makeStringValue argv +evalTopExpr env (Execute expr) = do + io <- evalExpr env expr case io of Value (IOFunc m) -> m >> return env _ -> throwError $ TypeMismatch "io" io @@ -199,6 +198,15 @@ genLet (names, expr) expr' = LetExpr [(["#1", "#2"], ApplyExpr expr $ TupleExpr [VarExpr "#1"])] $ LetExpr [(names, VarExpr "#2")] expr' + +evalExpr env (IoExpr expr) = do + io <- evalExpr env expr + case io of + Value (IOFunc m) -> do + val <- m >>= evalDeep + case val of + Tuple [_, val'] -> return $ Value val' + _ -> throwError $ TypeMismatch "io" io evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do target <- newThunk env target 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 @@ -101,7 +101,7 @@ testExpr = keywordTest >> Test <$> expr executeExpr :: Parser EgisonTopExpr -executeExpr = keywordExecute >> Execute <$> sepEndBy stringLiteral whiteSpace +executeExpr = keywordExecute >> Execute <$> expr loadFileExpr :: Parser EgisonTopExpr loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral @@ -130,6 +130,7 @@ <|> letRecExpr <|> letExpr <|> doExpr + <|> ioExpr <|> matchAllExpr <|> matchExpr <|> matcherExpr @@ -267,6 +268,9 @@ varName :: Parser String varName = char '$' >> ident +ioExpr :: Parser EgisonExpr +ioExpr = keywordIo >> IoExpr <$> expr + applyExpr :: Parser EgisonExpr applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr) <|> applyExpr' @@ -464,6 +468,7 @@ , "match" , "matcher" , "do" + , "io" , "algebraic-data-matcher" , "generate-array" , "array-size" @@ -508,6 +513,7 @@ keywordMatchLambda = reserved "match-lambda" keywordMatcher = reserved "matcher" keywordDo = reserved "do" +keywordIo = reserved "io" keywordSomething = reserved "something" keywordUndefined = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher" 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 @@ -20,12 +20,18 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.Text as T ---import qualified Database.SQLite3 as SQLite -- for 'egison-sqlite' ---import qualified Database.MySQL.Base as MySQL -- for 'egison-mysql' +{-- -- for 'egison-sqlite' +import qualified Database.SQLite3 as SQLite +--} -- for 'egison-sqlite' +{-- -- for 'egison-mysql' +import qualified Database.MySQL.Base as MySQL +--} -- for 'egison-mysql' + import Control.Monad import Language.Egison.Types +import Language.Egison.Parser import Language.Egison.Core primitiveEnv :: IO Env @@ -147,8 +153,13 @@ , ("assert", assert) , ("assert-equal", assertEqual) --- , ("pure-sqlite", pureSQLite) -- for 'egison-sqlite' --- , ("pure-mysql", pureMySQL) -- for 'egison-mysql' +{-- -- for 'egison-sqlite' + , ("pure-sqlite", pureSQLite) +--} -- for 'egison-sqlite' + +{-- -- for 'egison-mysql' + , ("pure-mysql", pureMySQL) +--} -- for 'egison-mysql' ] integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc @@ -365,7 +376,7 @@ SQLite.close db ret <- readIORef rowsRef return $ reverse ret ---} +--} -- for 'egison-sqlite' {-- -- for 'egison-mysql' pureMySQL :: PrimitiveFunc @@ -391,7 +402,7 @@ Nothing -> return "null") rows' <- fetchAllRows ret return $ row':rows' ---} +--} -- for 'egison-mysql' -- -- IO Primitives @@ -405,11 +416,10 @@ , ("close-output-port", closePort) , ("read-char", readChar) , ("read-line", readLine) --- , ("read", readFromStdin) + , ("read", readFromStdin) , ("write-char", writeChar) , ("write-string", writeString) - , ("write", write) --- , ("print", writeStringLine) + , ("write", writeToStdout) , ("eof?", isEOFStdin) , ("flush", flushStdout) , ("read-char-from-port", readCharFromPort) @@ -419,8 +429,10 @@ , ("write-string-to-port", writeStringToPort) , ("write-to-port", writeToPort) , ("eof-port?", isEOFPort) --- , ("print-to-port", writeStringLineToPort) , ("flush-port", flushPort) + + , ("read-file", readFile') + , ("rand", randRange) ] -- , ("get-lib-dir-name", getLibDirName) ] @@ -450,8 +462,8 @@ writeString = (liftError .) $ oneArg $ \val -> makeIO' . liftIO . putStr <$> fromStringValue val -write :: PrimitiveFunc -write = oneArg $ \val -> +writeToStdout :: PrimitiveFunc +writeToStdout = oneArg $ \val -> makeIO' . liftIO . putStr . show <$> evalDeep val readChar :: PrimitiveFunc @@ -460,6 +472,9 @@ readLine :: PrimitiveFunc readLine = noArg $ return $ makeIO $ liftIO $ liftM makeStringValue getLine +readFromStdin :: PrimitiveFunc +readFromStdin = noArg $ return $ makeIO $ (liftIO getLine) >>= readExpr >>= evalExpr' nullEnv + flushStdout :: PrimitiveFunc flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout @@ -495,9 +510,10 @@ isEOFPort = (liftError .) $ oneArg $ \val -> makeIO . liftIO . liftM Bool . hIsEOF <$> fromPortValue val ---rand :: PrimitiveFunc ---rand = noArg $ return $ makeIO $ liftIO $ liftM Integer $ getStdRandom random - +readFile' :: PrimitiveFunc +readFile' = (liftError .) $ oneArg $ \val -> + makeIO . liftIO . liftM makeStringValue . readFile <$> fromStringValue val + randRange :: PrimitiveFunc randRange = (liftError .) $ twoArgs $ \val val' -> return . makeIO . liftIO . liftM Integer . getStdRandom . randomR =<< liftM2 (,) (fromIntegerValue val) (fromIntegerValue val') 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 @@ -40,7 +40,7 @@ data EgisonTopExpr = Define String EgisonExpr | Test EgisonExpr - | Execute [String] + | Execute EgisonExpr -- temporary : we will replace load to import and export | LoadFile String | Load String @@ -75,6 +75,7 @@ | MatcherExpr MatcherInfo | DoExpr [BindingExpr] EgisonExpr + | IoExpr EgisonExpr | ApplyExpr EgisonExpr EgisonExpr diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -2,6 +2,8 @@ ;; Base.egi ;; +(define $id (lambda [$x] x)) + (define $bool (matcher {[,$val [] diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -82,7 +82,7 @@ {x @(filter pred rs)} (filter pred rs))]}))) -(define $split +(define $separate (lambda [$pred $ls] (letrec {[$helper (lambda [$ls $xs $ys] (match ls (list something) diff --git a/lib/core/io.egi b/lib/core/io.egi new file mode 100644 --- /dev/null +++ b/lib/core/io.egi @@ -0,0 +1,40 @@ +;;;;; +;;;;; Collection.egi +;;;;; + +;;; +;;; IO +;;; +(define $print + (lambda [$x] + (do {[(write-string x)] + [(write-string "\n")] + } + []))) + +(define $print-to-port + (lambda [$port $x] + (do {[(write-string-to-port port x)] + [(write-string-to-port port "\n")] + } + []))) + +;;; +;;; Collection +;;; +(define $each + (lambda [$proc $xs] + (match xs (list something) + {[ (do {} [])] + [ + (do {[(proc x)] + [(each proc rs)] + } + [])]}))) + +;;; +;;; Others +;;; +(define $pure-rand + (lambda [$s $e] + (io (rand s e)))) diff --git a/lib/core/string.egi b/lib/core/string.egi --- a/lib/core/string.egi +++ b/lib/core/string.egi @@ -8,6 +8,18 @@ (define $intercalate (compose intersperse concat)) +(define $split + (lambda [$in $ls] + (match ls (list something) + {[> {xs @(split in rs)}] + [_ {ls}]}))) + +(define $split/m + (lambda [$a $in $ls] + (match ls (list a) + {[> {xs @(split/m $a in rs)}] + [_ {ls}]}))) + (define $palindrome? (lambda [$str] (match str string