egison 2.3.9 → 2.3.10

raw patch · 13 files changed

+104/−92 lines, 13 filesdep +strict-ioPVP ok

version bump matches the API change (PVP)

Dependencies added: strict-io

API changes (from Hackage documentation)

Files

• egison.cabal +4/−4
• etc/template-for-test.hs +4/−2
• hs-src/Language/Egison/Core.hs +10/−6
• hs-src/Language/Egison/Macro.hs +3/−0
• hs-src/Language/Egison/Primitives.hs +6/−0
• hs-src/Language/Egison/Types.hs +3/−4
• lib/core/collection.egi +21/−18
• sample/array-test.egi +1/−1
• sample/collection-test.egi +15/−2
• sample/graph-test.egi +19/−34
• sample/n-queen.egi +2/−1
• sample/number-test.egi +10/−20
• sample/poker-hands-test.egi +6/−0

@@ -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 

@@ -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

@@ -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),

@@ -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

@@ -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

@@ -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 _) = "#<cut-pat>" showExpr (NotPatExpr _) = "#<not-pat>" showExpr (AndPatExpr _) = "#<and-pat>"@@ -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 ++ " ...)"

@@ -26,26 +26,29 @@                                       [[<cons $x $xs> <cons ,x $ys>] (helper xs ys)]                                       [[_ _] {}]}))]}                  (helper pxs tgt))]}]+       [<join _ ,$pys> [(List a)]+        {[$tgt (letrec {[$helper (lambda [$pys $tgt]+                                   (match [pys tgt] [(List a) (List a)]+                                     {[[<nil> _] {tgt}]+                                      [[<snoc $x $xs> <snoc ,x $ys>] (helper xs ys)]+                                      [[_ _] {}]}))]}+                 (helper pys tgt))]}]        [<join _ _> [(List a) (List a)]-        {[$tgt (letrec {[$loop-fn-                         (lambda [$ts]-                           (match ts (List a)-                             {[<nil> {[{} {}]}]-                              [<cons $x $xs>-                               {[{} 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)+									 {[<nil> {[xs {}] @r}]+									  [<cons $z $zs> (helper {@xs z} zs {[xs ys] @r})]}))]}+				 (helper {} tgt {}))]}]+       [<nioj ,$pxs _> [(List a)]+        {[$tgt (match-all tgt (List a) [<join $ys ,pxs> ys])]}]+       [<nioj _ ,$pys> [(List a)]+        {[$tgt (match-all tgt (List a) [<join ,pys $xs> xs])]}]        [<nioj _ _> [(List a) (List a)]-        {[$tgt (letrec {[$loop-fn-                         (lambda [$ts]-                           (match ts (List a)-                             {[<nil> {[{} {}]}]-                              [<snoc $x $xs>-                               {[{} 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)+									 {[<nil> {[{} xs] @r}]+									  [<cons $z $zs> (helper {@xs z} zs {[ys xs] @r})]}))]}+				 (helper {} tgt {}))]}]        [_ [Something]         {[$tgt {tgt}]}]        })))

@@ -26,5 +26,5 @@ (test (array-ref [2 3] bss))  (test (match ass (Array Integer)-        {[<cons ,[2 2] $n <cons ,[2 3] ,(+ n 1) _>> <ok>]+        {[(& <cons ,[2 2] $n> <cons ,[2 3] ,(+ n 1)>) <ok>]          [_ <ko>]}))

@@ -1,9 +1,15 @@+(load "lib/poker-hands.egi")++;; match List+(test (match-all {1 2 3 4 5} (List Integer) [<snoc $x $xs> [x xs]]))+ (test (match-all {1 2 3 4 5} (List Integer) [<join ,{1 2} $xs> xs])) +(test (match-all {1 2 3 4 5} (List Integer) [<join ,{1 2} $xs> xs]))+ (test (match-all {[1 2] [1 2]} (List [Integer Integer])         [<cons [$a $b] _> [a b]])) - ;; match Multiset (test (match-all {1 2 3 4 5} (Multiset Integer)         [<cons $m <cons $n _>> [m n]]))@@ -105,6 +111,13 @@         [<join _ <join $ns _>> ns]))  ;; pattern macro+(define $single+  (macro [$s $pat]+    <cons $`s pat>))++(test (match-all {1 2 3 1 2} (Multiset Integer)+        [(single %k _) k]))+ (define $pair   (macro [$s $pat]     <cons $`s <cons ,`s pat>>))@@ -133,7 +146,7 @@ (define $isStraight?   (lambda [$Ns]     (match Ns (Multiset Integer)-      {[<cons (as $n (max Ns))+      {[<cons (& ,(max Ns) $n)          (loop-pat (- n 1))>         <ok>]        [_ <ko>]})))

@@ -1,40 +1,25 @@-(define $g {<node 1 {2 3 4 5} {2 3 4 5}>-            <node 2 {1 3} {1 3}>-            <node 3 {1 2 4} {1 2 4}>-            <node 4 {1 3 5} {1 3 5}>-            <node 5 {1 5} {1 5}>})+(load "lib/graph.egi") -(define $g {<node 1 {2} {2}>-            <node 2 {1 3} {1 3}>-            <node 3 {2 4} {2 4}>-            <node 4 {3 5} {3 5}>-            <node 5 {4} {4}>})+(define $g1 {<node 1 {2 3 4 5} {2 3 4 5}>+             <node 2 {1 3} {1 3}>+             <node 3 {1 2 4} {1 2 4}>+             <node 4 {1 3 5} {1 3 5}>+             <node 5 {1 4} {1 4}>}) -(test (match-all g Graph-        [<cons <node $n1 <cons $n2 _> _>-          <cons <node ,n2 <cons $n3 _> _>-           <cons <node ,n3 <cons ,n1 _> _>-            _>>>-         [n1 n2 n3]]))+(define $g2 {<node 1 {2} {2}>+             <node 2 {1 3} {1 3}>+             <node 3 {2 4} {2 4}>+             <node 4 {3 5} {3 5}>+             <node 5 {4} {4}>}) -(test (match-all g Graph-        [<cons <node $n1 <cons $n2 _> _>-          <cons <node ,n2 <cons $n3 _> _>-           <cons <node ,n3 <cons $n4 _> _>-            <cons <node ,n4 <cons $n5 _> _>-             <cons <node ,n5 <cons ,n1 _> _>-              _>>>>>-         [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-        [<cons <node $n1 <cons $n2 _> _>-          <cons <node ,n2 <cons $n3 _> _>-           <cons <node ,n3 <cons $n4 _> _>-            <cons <node ,n4 <cons $n5 _> _>-             <cons <node ,n5 _ _>-              <nil>>>>>>-         [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]})

@@ -4,7 +4,8 @@       [<cons $a_1              (loop $l $i (between 2 n)                    <cons (loop $l1 $i1 (between 1 (- i 1))-                               (& ^,(- a_i1 (- i i1)) ^,(+ a_i1 (- i i1))+                               (& ^,(- a_i1 (- i i1))+                                  ^,(+ a_i1 (- i i1))                                   l1)                                $a_i)                          l>

@@ -1,24 +1,14 @@-(test (if ((= (List Integer)) (between 3 5)-                              {3 4 5})-          <ok>-          <ko>))+(test (between 3 5))+(test {3 4 5}) -(test (if (eq? (min&max {10 20 4 40 23})-               [4 40])-          <ok>-          <ko>))+(test (min&max {10 20 4 40 23}))+(test [4 40]) -(test (if (eq-n? (fib 10)-                 89)-          <ok>-          <ko>))+(test (fib 10))+(test 89) -(test (if (eq-n? (fact 10)-                 3628800)-          <ok>-          <ko>))+(test (fact 10))+(test 3628800) -(test (if (eq-n? (gcd {10 20 40 35})-                 5)-          <ok>-          <ko>))+(test (gcd {10 20 40 35}))+(test 5)

@@ -1,23 +1,29 @@+(load "lib/poker-hands.egi")+ (test (poker-hands {<card <club> 4>                     <card <club> 2>                     <card <club> 13>                     <card <club> 1>                     <card <club> 3>}))+(test <straight-flush>)  (test (poker-hands {<card <diamond> 1>                     <card <club> 2>                     <card <club> 1>                     <card <heart> 1>                     <card <diamond> 2>}))+(test <full-house>)  (test (poker-hands {<card <diamond> 4>                     <card <club> 2>                     <card <club> 5>                     <card <heart> 1>                     <card <diamond> 3>}))+(test <straight>)  (test (poker-hands {<card <diamond> 4>                     <card <club> 10>                     <card <club> 5>                     <card <heart> 1>                     <card <diamond> 3>}))+(test <nothing>)