diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.7.11 +Version: 3.7.12 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. @@ -51,7 +51,7 @@ Homepage: http://www.egison.org License: MIT License-file: LICENSE -Author: Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda +Author: Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda, Mayuko Kori Maintainer: Satoshi Egi Category: Compilers/Interpreters Build-type: Simple @@ -85,9 +85,9 @@ Test-Suite test Type: exitcode-stdio-1.0 Hs-Source-Dirs: test - Main-Is: UnitTest.hs - Build-Depends: egison, base >= 4.0 && < 5, transformers, mtl, Glob, HUnit, test-framework, test-framework-hunit - Other-modules: Paths_egison + Main-Is: Test.hs + Build-Depends: egison, base >= 4.0 && < 5, transformers, mtl, Glob, HUnit, test-framework, test-framework-hunit, filepath + Other-modules: Paths_egison, UnitTest Benchmark benchmark Type: exitcode-stdio-1.0 diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -223,7 +223,7 @@ showBanner :: IO () showBanner = do - putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2017 Satoshi Egi" + putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2018 Satoshi Egi" putStrLn $ "https://www.egison.org" putStrLn $ "Welcome to Egison Interpreter!" -- putStrLn $ "** Information **" 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 @@ -590,9 +590,13 @@ _ -> applyFunc env func (Value (makeTuple args)) evalExpr env (ApplyExpr func arg) = do - func <- evalExpr env func + func <- evalExpr env func >>= appendDFscripts 0 arg <- evalExpr env arg case func of + Value (TensorData t@(Tensor ns fs js)) -> do + tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value >>= removeDFscripts + Intermediate (ITensor t@(Tensor ns fs js)) -> do + tMap (\f -> applyFunc env f arg) t >>= fromTensor Value (MemoizedFunc name ref hashRef env names body) -> do indices <- evalWHNF arg indices' <- mapM fromEgison $ fromTupleValue indices @@ -608,32 +612,6 @@ writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body)) return whnf _ -> applyFunc env func arg >>= removeDFscripts --- evalExpr env (ApplyExpr func arg) = do --- func <- evalExpr env func >>= appendDFscripts 0 --- arg <- evalExpr env arg --- -- arg <- evalExpr env arg >>= fromTupleWHNF --- -- let k = fromIntegral (length arg) --- -- arg <- mapM (\(_,j) -> appendDFscripts 0 j) (zip [1..k] arg) >>= makeITuple --- case func of --- Value (TensorData t@(Tensor ns fs js)) -> do --- tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value >>= removeDFscripts --- Intermediate (ITensor t@(Tensor ns fs js)) -> do --- tMap (\f -> applyFunc env f arg) t >>= fromTensor --- Value (MemoizedFunc name ref hashRef env names body) -> do --- indices <- evalWHNF arg --- indices' <- mapM fromEgison $ fromTupleValue indices --- hash <- liftIO $ readIORef hashRef --- case HL.lookup indices' hash of --- Just objRef -> do --- evalRef objRef --- Nothing -> do --- whnf <- applyFunc env (Value (Func Nothing env names body)) arg --- retRef <- newEvaluatedObjectRef whnf --- hash <- liftIO $ readIORef hashRef --- liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) --- writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body)) --- return whnf --- _ -> applyFunc env func arg >>= removeDFscripts evalExpr env (WedgeApplyExpr func arg) = do func <- evalExpr env func >>= appendDFscripts 0 @@ -1226,12 +1204,14 @@ then return MNil else do (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends) + b2 <- evalRef cdrEndsRef >>= isEmptyCollection carEndsNum <- evalRef carEndsRef >>= fromWHNF if startNum > carEndsNum then return MNil else if startNum == carEndsNum - then return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees), - MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] + then if b2 + then return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees)] + else return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees), MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] else return $ fromList [MState env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] AndPat patterns -> let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees 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 @@ -956,8 +956,8 @@ let k2 = fromIntegral $ length ns2 - length js2' let js2 = js2' ++ map (DFscript 0) [1..k2] let (cjs, tjs1, tjs2) = h js1 js2 - t1' <- tTranspose (cjs ++ tjs1) t1 - t2' <- tTranspose (cjs ++ tjs2) t2 + t1' <- tTranspose (cjs ++ tjs1) (Tensor ns1 xs1 js1) + t2' <- tTranspose (cjs ++ tjs2) (Tensor ns2 xs2 js2) let cns = take (length cjs) (tSize t1') rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns) rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns) @@ -1186,6 +1186,7 @@ show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")" show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")" show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")" + show _ = "(not supported)" instance Show EgisonValue where show (Char c) = "c#" ++ [c] @@ -1582,7 +1583,7 @@ extendEnv (Env env idx) bdg = Env ((: env) $ HashMap.fromList bdg) idx refVar :: Env -> Var -> Maybe ObjectRef -refVar (Env env idx) var = msum $ map (HashMap.lookup var) env +refVar (Env env _) var = msum $ map (HashMap.lookup var) env -- -- Pattern Match diff --git a/sample/demo1-ja.egi b/sample/demo1-ja.egi --- a/sample/demo1-ja.egi +++ b/sample/demo1-ja.egi diff --git a/sample/demo1.egi b/sample/demo1.egi --- a/sample/demo1.egi +++ b/sample/demo1.egi @@ -1,9 +1,9 @@ -;; Extract all twin primes from the infinite list of prime numbers with pattern-matching! +;; Extract all twin primes from the infinite list of prime numbers with pattern matching! (define $twin-primes (match-all primes (list integer) [>> [p (+ p 2)]])) -;; Enumerate first 10 twin primes +;; Enumerate first 10 twin primes. (take 10 twin-primes) ;=>{[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]} diff --git a/sample/math/geometry/exterior-derivative.egi b/sample/math/geometry/exterior-derivative.egi --- a/sample/math/geometry/exterior-derivative.egi +++ b/sample/math/geometry/exterior-derivative.egi @@ -6,8 +6,11 @@ (lambda [%X] !((flip ∂/∂) params X))) -(d (f x y z)) -;[| (f|1 x y z) (f|2 x y z) (f|3 x y z) |] -(df-normalize (d (d (f x y z)))) +(define $f (function [x y z])) + +(d f) +;[| f|x f|y f|z |] + +(df-normalize (d (d f))) ;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 0 |] |] diff --git a/sample/primes.egi b/sample/primes.egi --- a/sample/primes.egi +++ b/sample/primes.egi @@ -10,7 +10,7 @@ [>> [p (+ p 2)]])) -;; Enumerate first 10 twin primes +;; Enumerate the first 10 twin primes (take 10 twin-primes) ;; Extract all prime-triplets from the infinite list of prime numbers with pattern-matching! @@ -21,6 +21,6 @@ >>> [p m (+ p 6)]])) -;; Enumerate first 10 twin primes +;; Enumerate the first 10 prime triplets (take 10 prime-triplets) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,54 @@ +module Main where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.IORef +import Data.List + +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (hUnitTestToTests) +import Test.HUnit +import System.FilePath.Glob (glob) +import System.FilePath (takeDirectory, replaceDirectory, splitPath) + +import Language.Egison.Types +import Language.Egison.Core +import Language.Egison.Primitives +import Language.Egison + +import UnitTest + +main = do + unitTestCases <- glob "test/[^answer]**/*.egi" + sampleTestCases <- glob "test/answer/**/*.egi" + defaultMain $ hUnitTestToTests $ test $ map runUnitTestCase unitTestCases ++ map runSampleTestCase sampleTestCases + +runSampleTestCase :: FilePath -> Test +runSampleTestCase file = TestLabel file . TestCase $ do + env <- initialEnv + let directory_path = takeDirectory file + answers <- readFile file + assertEgisonM (lines answers) $ do + exprs <- loadFile (replaceDirectory file $ concat $ drop 2 $ splitPath directory_path) + let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs + env' <- recursiveBind env bindings + vals <- forM tests (evalExprDeep env') + return $ zip tests vals + where + assertEgisonM :: [String] -> EgisonM [(EgisonExpr, EgisonValue)] -> Assertion + assertEgisonM answers m = fromEgisonM m >>= assertString . either show (f answers) + + collectDefsAndTests (Define name expr) (bindings, tests) = + ((name, expr) : bindings, tests) + collectDefsAndTests (Test expr) (bindings, tests) = + (bindings, expr : tests) + collectDefsAndTests _ r = r + + f :: [String] -> [(EgisonExpr, EgisonValue)] -> String + f answers ls = g answers ls 0 + g x y i = let (e, v) = unzip y in + if (x !! i) == show (v !! i) + then (if i < (length y - 1) then g x y (i + 1) + else "") + else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ show (v !! i) diff --git a/test/UnitTest.hs b/test/UnitTest.hs --- a/test/UnitTest.hs +++ b/test/UnitTest.hs @@ -1,25 +1,18 @@ -module Main where +module UnitTest ( runUnitTestCase ) where import Control.Applicative import Control.Monad import Data.IORef -import Test.Framework (defaultMain) -import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.HUnit -import System.FilePath.Glob (glob) import Language.Egison.Types import Language.Egison.Core import Language.Egison.Primitives import Language.Egison -main = do - testCases <- glob "test/**/*.egi" - defaultMain $ hUnitTestToTests $ test $ map runTestCase testCases - -runTestCase :: FilePath -> Test -runTestCase file = TestLabel file . TestCase $ do +runUnitTestCase :: FilePath -> Test +runUnitTestCase file = TestLabel file . TestCase $ do env <- initialEnv assertEgisonM $ do exprs <- loadFile file @@ -31,7 +24,7 @@ assertEgisonM m = fromEgisonM m >>= assertString . either show (const "") collectDefsAndTests (Define name expr) (bindings, tests) = - (((stringToVar $ show name), expr) : bindings, tests) + ((name, expr) : bindings, tests) collectDefsAndTests (Test expr) (bindings, tests) = (bindings, expr : tests) collectDefsAndTests _ r = r