diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.3.9 +Version: 2.3.10 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. @@ -27,7 +27,7 @@ etc/template-for-test.hs Library - Build-Depends: base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths + Build-Depends: base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io Hs-Source-Dirs: hs-src Exposed-Modules: Language.Egison.Core Language.Egison.Types @@ -41,13 +41,13 @@ Executable egison Main-is: egisoni.hs - Build-depends: egison, base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, regex-posix + Build-depends: egison, base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, regex-posix, strict-io Other-modules: Paths_egison Hs-Source-Dirs: hs-src/Interpreter Executable egisonc Main-is: egisonc.hs - Build-depends: egison, base >= 4.0 && < 5, array, containers, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, process + Build-depends: egison, base >= 4.0 && < 5, array, containers, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, process, strict-io Other-modules: Paths_egison Hs-Source-Dirs: hs-src/Compiler diff --git a/etc/template-for-test.hs b/etc/template-for-test.hs --- a/etc/template-for-test.hs +++ b/etc/template-for-test.hs @@ -7,8 +7,10 @@ evalTopExprs _ [] = return () evalTopExprs env (topExpr:rest) = do str <- runIOThrowsREPL $ evalTopExpr env topExpr - putStrLn str - evalTopExprs env rest + case topExpr of + Test _ -> do putStrLn str + evalTopExprs env rest + _ -> evalTopExprs env rest main :: IO () main = do 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 @@ -11,6 +11,8 @@ import qualified System.Exit () import System.Directory (doesFileExist) import System.IO +import System.IO.Strict (SIO) +import qualified System.IO.Strict as SIO import Data.IORef import Data.Version import Paths_egison @@ -76,14 +78,14 @@ evalTopExpr env (LoadFile filename) = do result <- liftIO $ doesFileExist filename if result - then do (liftIO $ readFile filename) >>= load env + then do (liftIO $ SIO.run $ SIO.readFile filename) >>= load env return $ filename ++ " loaded." else throwError $ Default $ "File does not exist: " ++ filename evalTopExpr env (Load libname) = do filename <- liftIO (getDataFileName libname) result <- liftIO $ doesFileExist filename if result - then do (liftIO $ readFile filename) >>= load env + then do (liftIO $ SIO.run $ SIO.readFile filename) >>= load env return $ filename ++ " loaded." else throwError $ Default $ "Library does not exist: " ++ libname @@ -685,7 +687,7 @@ case mRestFrame of Nothing -> return Nothing Just restFrame -> return (Just (frame ++ restFrame)) -primitivePatternMatchList _ _ = throwError (Default "primitivePatternMatchList : number of patterns and targets are different") +primitivePatternMatchList _ _ = throwError $ Default "primitivePatternMatchList : number of patterns and targets are different" objectRefToInnerRefs :: ObjectRef -> IOThrowsError [InnerValRef] @@ -696,6 +698,7 @@ Value (Collection val) -> do objRefs <- liftIO $ mapM (newIORef . Value) val return $ map IElement objRefs + _ -> throwError $ Default "objectRefToInnerRefs: subcollection must be collection" isEmptyCollection :: ObjectRef -> IOThrowsError Bool isEmptyCollection objRef = do @@ -721,7 +724,7 @@ ((IElement _):_) -> return False ((ISubCollection subObjRef):rest) -> do subInnerRefs <- objectRefToInnerRefs subObjRef - liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ reverse subInnerRefs + liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ subInnerRefs isEmptyCollectionForSnoc objRef Value (Collection []) -> return True Value (Collection _) -> return False @@ -757,7 +760,7 @@ return (racObjRef, rdcObjRef) ((ISubCollection subObjRef):rest) -> do subInnerRefs <- objectRefToInnerRefs subObjRef - liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ reverse subInnerRefs + liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ subInnerRefs snocDestruct objRef Value (Collection vals) -> do case reverse vals of @@ -816,7 +819,8 @@ {- I/O primitives -} ioPrimitives :: [(String, [EgisonVal] -> IOThrowsError EgisonVal)] -ioPrimitives = [("open-input-file", makePort ReadMode), +ioPrimitives = [("get-lib-dir-name", getLibDirName), + ("open-input-file", makePort ReadMode), ("open-output-file", makePort WriteMode), ("close-input-port", closePort), ("close-output-port", closePort), diff --git a/hs-src/Language/Egison/Macro.hs b/hs-src/Language/Egison/Macro.hs --- a/hs-src/Language/Egison/Macro.hs +++ b/hs-src/Language/Egison/Macro.hs @@ -60,6 +60,9 @@ newLoopExpr <- expandMacro frame loopExpr newTailExpr <- expandMacro frame tailExpr return $ LoopExpr loopVar indexVar newRangeExpr newLoopExpr newTailExpr +expandMacro frame (ValuePatExpr patExpr) = do + newPatExpr <- expandMacro frame patExpr + return $ ValuePatExpr newPatExpr --expandMacro frame (LetExpr bindings body) = undefined --expandMacro frame (LetRecExpr bindings body) = undefined expandMacro frame (MatchExpr tgtExpr typExpr mcs) = do 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 @@ -11,9 +11,15 @@ import System.Directory (doesFileExist, removeFile) import System.IO.Error hiding (try) +import Paths_egison + --------------------------------------------------- -- I/O Primitives --------------------------------------------------- +getLibDirName :: [EgisonVal] -> IOThrowsError EgisonVal +getLibDirName [] = liftIO $ (getDataFileName "") >>= return . String +getLibDirName _ = throwError $ Default $ "readCharFromPort: invalid arguments" + makePort :: IOMode -> [EgisonVal] -> IOThrowsError EgisonVal makePort mode [(World actions), (String filename)] = do port <- liftM (Port filename) $ liftIO $ openFile filename mode 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 @@ -4,7 +4,6 @@ import Data.Array import Data.IORef import qualified Data.Map --- import Data.Maybe import System.IO import Text.ParserCombinators.Parsec hiding (spaces) @@ -299,8 +298,8 @@ showExpr (PatVarExpr name nums) = "$" ++ name ++ unwordsNumExprs nums showExpr WildCardExpr = "_" showExpr (ValuePatExpr expr) = "," ++ showExpr expr -showExpr (PatVarOmitExpr pvar) = "$~" ++ showExpr pvar -showExpr (VarOmitExpr pvar) = "~" ++ showExpr pvar +showExpr (PatVarOmitExpr pvar) = "$`" ++ showExpr pvar +showExpr (VarOmitExpr pvar) = "`" ++ showExpr pvar showExpr (CutPatExpr _) = "#" showExpr (NotPatExpr _) = "#" showExpr (AndPatExpr _) = "#" @@ -327,7 +326,7 @@ "(letrec " ++ showRecursiveBindings bindings ++ " " ++ showExpr body ++ ")" showExpr (DoExpr bindings body) = "(do " ++ showBindings bindings ++ " " ++ showExpr body ++ ")" -showExpr (TypeExpr destructor) = +showExpr (TypeExpr _) = "(type " ++ "..." ++ ")" showExpr (MatchExpr tgtExpr typExpr _) = "(match " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)" diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -26,26 +26,29 @@ [[ ] (helper xs ys)] [[_ _] {}]}))]} (helper pxs tgt))]}] + [ [(List a)] + {[$tgt (letrec {[$helper (lambda [$pys $tgt] + (match [pys tgt] [(List a) (List a)] + {[[ _] {tgt}] + [[ ] (helper xs ys)] + [[_ _] {}]}))]} + (helper pys tgt))]}] [ [(List a) (List a)] - {[$tgt (letrec {[$loop-fn - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] [{x @as} bs]) - (loop-fn xs))}]}))]} - (loop-fn tgt))]}] + {[$tgt (letrec {[$helper (lambda [$xs $ys $r] + (match ys (List a) + {[ {[xs {}] @r}] + [ (helper {@xs z} zs {[xs ys] @r})]}))]} + (helper {} tgt {}))]}] + [ [(List a)] + {[$tgt (match-all tgt (List a) [ ys])]}] + [ [(List a)] + {[$tgt (match-all tgt (List a) [ xs])]}] [ [(List a) (List a)] - {[$tgt (letrec {[$loop-fn - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] [{@as x} bs]) - (loop-fn xs))}]}))]} - (loop-fn tgt))]}] + {[$tgt (letrec {[$helper (lambda [$xs $ys $r] + (match ys (List a) + {[ {[{} xs] @r}] + [ (helper {@xs z} zs {[ys xs] @r})]}))]} + (helper {} tgt {}))]}] [_ [Something] {[$tgt {tgt}]}] }))) diff --git a/sample/array-test.egi b/sample/array-test.egi --- a/sample/array-test.egi +++ b/sample/array-test.egi @@ -26,5 +26,5 @@ (test (array-ref [2 3] bss)) (test (match ass (Array Integer) - {[> ] + {[(& ) ] [_ ]})) diff --git a/sample/collection-test.egi b/sample/collection-test.egi --- a/sample/collection-test.egi +++ b/sample/collection-test.egi @@ -1,9 +1,15 @@ +(load "lib/poker-hands.egi") + +;; match List +(test (match-all {1 2 3 4 5} (List Integer) [ [x xs]])) + (test (match-all {1 2 3 4 5} (List Integer) [ xs])) +(test (match-all {1 2 3 4 5} (List Integer) [ xs])) + (test (match-all {[1 2] [1 2]} (List [Integer Integer]) [ [a b]])) - ;; match Multiset (test (match-all {1 2 3 4 5} (Multiset Integer) [> [m n]])) @@ -105,6 +111,13 @@ [> ns])) ;; pattern macro +(define $single + (macro [$s $pat] + )) + +(test (match-all {1 2 3 1 2} (Multiset Integer) + [(single %k _) k])) + (define $pair (macro [$s $pat] >)) @@ -133,7 +146,7 @@ (define $isStraight? (lambda [$Ns] (match Ns (Multiset Integer) - {[ ] [_ ]}))) diff --git a/sample/graph-test.egi b/sample/graph-test.egi --- a/sample/graph-test.egi +++ b/sample/graph-test.egi @@ -1,40 +1,25 @@ -(define $g { - - - - }) +(load "lib/graph.egi") -(define $g { - - - - }) +(define $g1 { + + + + }) -(test (match-all g Graph - [ _> - _> - _> - _>>> - [n1 n2 n3]])) +(define $g2 { + + + + }) -(test (match-all g Graph - [ _> - _> - _> - _> - _> - _>>>>> - [n1 n2 n3 n4 n5]])) +(test (hamilton-cycle g1)) +(test {[1 2 3 4 5] [1 5 4 3 2] [2 1 5 4 3] [2 3 4 5 1] [3 2 1 5 4] [3 4 5 1 2] [4 3 2 1 5] [4 5 1 2 3] [5 1 2 3 4] [5 4 3 2 1]}) -(test (match-all g Graph - [ _> - _> - _> - _> - - >>>>> - [n1 n2 n3 n4 n5]])) +(test (hamilton-path g1)) +(test {[1 2 3 4 5] [1 5 4 3 2] [2 1 3 4 5] [2 1 5 4 3] [2 3 1 4 5] [2 3 1 5 4] [2 3 4 1 5] [2 3 4 5 1] [3 2 1 4 5] [3 2 1 5 4] [3 4 5 1 2] [4 3 2 1 5] [4 5 1 2 3] [4 5 1 3 2] [5 1 2 3 4] [5 1 4 3 2] [5 4 1 2 3] [5 4 1 3 2] [5 4 3 1 2] [5 4 3 2 1]}) -(test (hamilton-cycle g)) +(test (hamilton-cycle g2)) +(test {}) -(test (hamilton-path g)) +(test (hamilton-path g2)) +(test {[1 2 3 4 5] [5 4 3 2 1]}) diff --git a/sample/n-queen.egi b/sample/n-queen.egi --- a/sample/n-queen.egi +++ b/sample/n-queen.egi @@ -4,7 +4,8 @@ [ diff --git a/sample/number-test.egi b/sample/number-test.egi --- a/sample/number-test.egi +++ b/sample/number-test.egi @@ -1,24 +1,14 @@ -(test (if ((= (List Integer)) (between 3 5) - {3 4 5}) - - )) +(test (between 3 5)) +(test {3 4 5}) -(test (if (eq? (min&max {10 20 4 40 23}) - [4 40]) - - )) +(test (min&max {10 20 4 40 23})) +(test [4 40]) -(test (if (eq-n? (fib 10) - 89) - - )) +(test (fib 10)) +(test 89) -(test (if (eq-n? (fact 10) - 3628800) - - )) +(test (fact 10)) +(test 3628800) -(test (if (eq-n? (gcd {10 20 40 35}) - 5) - - )) +(test (gcd {10 20 40 35})) +(test 5) diff --git a/sample/poker-hands-test.egi b/sample/poker-hands-test.egi --- a/sample/poker-hands-test.egi +++ b/sample/poker-hands-test.egi @@ -1,23 +1,29 @@ +(load "lib/poker-hands.egi") + (test (poker-hands { 4> 2> 13> 1> 3>})) +(test ) (test (poker-hands { 1> 2> 1> 1> 2>})) +(test ) (test (poker-hands { 4> 2> 5> 1> 3>})) +(test ) (test (poker-hands { 4> 10> 5> 1> 3>})) +(test )