egison 2.4.7 → 3.0.0

raw patch · 49 files changed

+2067/−4214 lines, 49 filesdep +Globdep +HUnitdep +bytestringdep −processPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, HUnit, bytestring, criterion, deepseq, test-framework, test-framework-hunit, unordered-containers

Dependencies removed: process

API changes (from Hackage documentation)

Files

• benchmark/Benchmark.hs +27/−0
• egison.cabal +27/−29
• elisp/egison-mode.el +6/−7
• etc/template-for-test.hs +0/−19
• etc/template.hs +0/−18
• hs-src/Compiler/egisonc.hs +0/−178
• hs-src/Interpreter/egisoni.hs +56/−129
• hs-src/Language/Egison.hs +57/−0
• hs-src/Language/Egison/Core.hs +478/−934
• hs-src/Language/Egison/Desugar.hs +203/−0
• hs-src/Language/Egison/Macro.hs +0/−97
• hs-src/Language/Egison/Numerical.hs +0/−70
• hs-src/Language/Egison/Parser.hs +428/−388
• hs-src/Language/Egison/Primitives.hs +283/−225
• hs-src/Language/Egison/Types.hs +244/−438
• hs-src/Language/Egison/Variables.hs +0/−126
• lib/coc.egi +0/−55
• lib/core/array.egi +0/−88
• lib/core/base.egi +27/−40
• lib/core/collection.egi +139/−196
• lib/core/number.egi +46/−47
• lib/core/pattern.egi +9/−13
• lib/graph.egi +0/−56
• lib/poker-hands.egi +0/−100
• lib/tree.egi +0/−16
• sample/array-test.egi +0/−30
• sample/collection-test.egi +0/−177
• sample/graph-test.egi +0/−25
• sample/icfpc2012/maps/contest1.map +0/−6
• sample/icfpc2012/maps/contest10.map +0/−24
• sample/icfpc2012/maps/contest2.map +0/−7
• sample/icfpc2012/maps/contest3.map +0/−9
• sample/icfpc2012/maps/contest4.map +0/−9
• sample/icfpc2012/maps/contest5.map +0/−12
• sample/icfpc2012/maps/contest6.map +0/−15
• sample/icfpc2012/maps/contest7.map +0/−9
• sample/icfpc2012/maps/contest8.map +0/−18
• sample/icfpc2012/maps/contest9.map +0/−17
• sample/icfpc2012/mine.egi +0/−466
• sample/io/argv-test.egi +0/−6
• sample/io/cat.egi +0/−17
• sample/io/char-test.egi +0/−10
• sample/io/copy.egi +0/−19
• sample/io/hello.egi +0/−4
• sample/io/read-write-test.egi +0/−9
• sample/n-queen.egi +0/−13
• sample/number-test.egi +0/−14
• sample/poker-hands-test.egi +0/−29
• test/UnitTest.hs +37/−0

@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleInstances #-}+module Main where+import Control.Applicative ((<$>), (<*>))+import Control.Monad.Error+import Control.Applicative+import Control.DeepSeq (NFData(rnf))+import Criterion.Main+import Criterion.Config+import Text.Parsec+import Text.Parsec.ByteString++import Language.Egison++runEgisonFile :: String -> IO (Either EgisonError Env)+runEgisonFile path = do+  env <- loadPrimitives nullEnv >>= loadLibraries+  evalEgisonTopExpr env $ LoadFile path++config :: Config+config = defaultConfig { cfgSamples   = ljust 3 +                       , cfgPerformGC = ljust True }++main :: IO ()+main = defaultMainWith config (return ()) [+    bgroup "fact" [ bench "30000" $ runEgisonFile "benchmark/fact-30000.egi" ]+  ]+

@@ -1,7 +1,7 @@ Name:                egison-Version:             2.4.7-Synopsis:            An Interpreter and Compiler for the Programming Language Egison-Description:         An interpreter and compiler for the programming language Egison.+Version:             3.0.0+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.                      With Egison, you can represent pattern matching for unfree data intuitively,                      especially for collection data, such as lists, multisets, sets, and so on.@@ -10,48 +10,46 @@ Homepage:            http://egison.pira.jp License:             MIT License-file:        LICENSE-Author:              Satoshi Egi+Author:              Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda Maintainer:          egisatoshi@gmail.com Category:            Compilers/Interpreters Build-type:          Simple Cabal-version:       >=1.8 -Data-files:          lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/core/array.egi lib/core/pattern.egi-                     lib/graph.egi lib/poker-hands.egi lib/coc.egi lib/tree.egi-                     sample/number-test.egi sample/collection-test.egi sample/array-test.egi sample/graph-test.egi-                     sample/poker-hands-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-                     sample/n-queen.egi-                     sample/icfpc2012/mine.egi sample/icfpc2012/maps/*.map+Extra-Source-Files:  benchmark/Benchmark.hs+++Data-files:          lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/core/pattern.egi                      elisp/egison-mode.el-                     etc/template.hs-                     etc/template-for-test.hs  Library-  Build-Depends:   base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io+  Build-Depends:   base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring   Hs-Source-Dirs:  hs-src-  Exposed-Modules: Language.Egison.Core+  Exposed-Modules:+                   Language.Egison+                   Language.Egison.Core+                   Language.Egison.Desugar                    Language.Egison.Types-                   Language.Egison.Variables-                   Language.Egison.Numerical+                   --Language.Egison.Variables+                   --Language.Egison.Numerical                    Language.Egison.Parser                    Language.Egison.Primitives-                   Language.Egison.Macro   Other-modules:   Paths_egison +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 +Benchmark benchmark+  Type: exitcode-stdio-1.0+  Hs-Source-Dirs:  benchmark+  Main-Is: Benchmark.hs+  Build-Depends: egison, base >= 4.0 && < 5, deepseq, criterion >= 0.5, transformers, mtl, parsec >= 3.0+ 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, strict-io+  Build-depends:       egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, regex-posix, strict-io, bytestring   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, strict-io-  Other-modules:       Paths_egison-  Hs-Source-Dirs:      hs-src/Compiler--Source-Repository head-  type:           git-  location:       https://github.com/egisatoshi/egison2

@@ -1,10 +1,10 @@ ;;; egison-mode.el --- Egison editing mode -;; Copyright 2011-2012 Satoshi Egi+;; Copyright 2011-2013 Satoshi Egi  ;;; Author: Satoshi Egi <egisatoshi@gmail.com>-;;; URL: https://github.com/egisatoshi/egison2/blob/master/elisp/egison-mode.el-;;; Version: 0.1.2+;;; URL: https://github.com/egisatoshi/egison3/blob/master/elisp/egison-mode.el+;;; Version: 0.1.3  ;; Code goes here @@ -21,14 +21,13 @@      "\\<if\\>"      "\\<let\\>"      "\\<letrec\\>"-     "\\<type\\>"+     "\\<matcher\\>"      "\\<loop\\>"      "\\<match\\>"      "\\<match-all\\>"-     "\\<generate-array\\>"       "\\<undefined\\>"-     "\\<Something\\>"+     "\\<something\\>"            "\\\."      "\\\,"@@ -119,7 +118,7 @@         ((equal "do" name) 2)         ((equal "match" name) 2)         ((equal "match-all" name) 2)-        ((equal "type" name) 2)+        ((equal "matcher" name) 2)         ((equal "generate-array" name) 2)         )) 

@@ -1,19 +0,0 @@-module Main where-import Language.Egison.Core-import Language.Egison.Types-import Control.Monad.Error--evalTopExprs :: Env -> [TopExpr] -> IO ()-evalTopExprs _ [] = return ()-evalTopExprs env (topExpr:rest) = do-  str <- runIOThrowsREPL $ evalTopExpr env topExpr-  case topExpr of-    Test _ -> do putStrLn str-                 evalTopExprs env rest-    _ -> evalTopExprs env rest--main :: IO ()-main = do-  env <- primitiveBindings-  evalTopExprs env topExprs-

@@ -1,18 +0,0 @@-module Main where-import Language.Egison.Core-import Language.Egison.Types-import Control.Monad.Error-import System.Environment--main :: IO ()-main = do-  args <- getArgs-  env <- primitiveBindings-  ret1 <- runIOThrows $ liftM concat $ mapM (evalTopExpr env) topExprs-  case ret1 of-   Just errMsg -> putStrLn errMsg-   _ -> do-     ret2 <- runIOThrows $ evalTopExpr env $ Execute args-     case ret2 of-       Just errMsg -> putStrLn errMsg-       _ -> return ()

@@ -1,178 +0,0 @@-module Main where-import Language.Egison.Core-import Language.Egison.Types-import Language.Egison.Parser-import Control.Monad.Error-import System.Cmd (system)-import System.Console.GetOpt-import System.FilePath (dropExtension)-import System.Environment-import System.Directory (doesFileExist, copyFile, removeFile)-import System.Exit (ExitCode (..), exitWith, exitFailure)-import System.IO-import Paths_egison--templateFile :: String-templateFile = "etc/template.hs"--templateFileForTest :: String-templateFileForTest = "etc/template-for-test.hs"--main :: IO ()-main = do -  args <- getArgs-  let (actions, nonOpts, _) = getOpt Permute options args-  let opts = foldl (flip id) defaultOptions actions-  case opts of-    Options {optShowHelp = True} -> printHelp-    Options {optShowVersion = True} -> printVersionNumber-    Options {optOutput = output} ->-      if null nonOpts-        then showUsage-        else do-          let inFile = nonOpts !! 0-              outExec = case output of-                Just outFile -> outFile-                Nothing -> dropExtension inFile-          process opts inFile outExec--data Options = Options {-    optShowVersion :: Bool,-    optShowHelp :: Bool,-    optOutput :: Maybe String,-    optProf :: Bool,-    optTest :: Bool-    }--showUsage :: IO ()-showUsage = do-  putStrLn "egisonc: no input files"-  -defaultOptions :: Options-defaultOptions = Options {-    optShowVersion = False,-    optShowHelp = False,-    optOutput = Nothing,-    optProf = False,-    optTest = False-    }--options :: [OptDescr (Options -> Options)]-options = [-  Option ['v', 'V'] ["version"]-    (NoArg (\opts -> opts {optShowVersion = True}))-    "show version number",-  Option ['h', '?'] ["help"]-    (NoArg (\opts -> opts {optShowHelp = True}))-    "show usage information",-  Option ['o'] ["output"]-    (ReqArg (\out opts -> opts {optOutput = Just out})-            "FILE")-    "output file to write",-  Option ['p'] ["prof"]-    (NoArg (\opts -> opts {optProf = True}))-    "use profiling system",-  Option ['t'] ["test"]-    (NoArg (\opts -> opts {optTest = True}))-    "execute test expressions"-  ]--printVersionNumber :: IO ()-printVersionNumber = do-  putStrLn egisonVersion-  exitWith ExitSuccess--printHelp :: IO ()-printHelp = do-  putStrLn "Usage: egisonc [options] file"-  putStrLn ""-  putStrLn "Options:"-  putStrLn "  --help                Display this information"-  putStrLn "  --version             Display egison version information"-  putStrLn "  --output filename     Write executable to the given filename"-  putStrLn "  --prof                Make use of GHC profiling system"-  putStrLn "  --test                Execute test expressions"-  putStrLn ""-  exitWith ExitSuccess--process :: Options -> String -> String -> IO ()-process opts inFile outExec = do-  result <- (runIOThrows $ liftM show $ createHaskellFile opts inFile)-  case result of-   Just errMsg -> putStrLn errMsg-   _ -> compileHaskellFile opts outExec--appendLoadExprForCoreLibraries :: [TopExpr] -> [TopExpr]-appendLoadExprForCoreLibraries topExprs = [(Load "lib/core/base.egi"),-                                           (Load "lib/core/number.egi"),-                                           (Load "lib/core/collection.egi"),-                                           (Load "lib/core/array.egi")-                                           ] ++ topExprs-   -createHaskellFile :: Options -> String -> IOThrowsError ()-createHaskellFile opts inFile =-  case opts of-    Options {optTest = True} -> do-      templatePath <- liftIO $ getDataFileName templateFileForTest-      liftIO $ copyFile templatePath "./_tmp.hs"-      egisonProgram <- liftIO $ readFile inFile-      topExprs <- liftThrows $ readTopExprList egisonProgram-      topExprs2 <- expandLoadExprs opts $ appendLoadExprForCoreLibraries topExprs-      liftIO $ appendFile "./_tmp.hs" "\ntopExprs :: [TopExpr]\n"-      liftIO $ appendFile "./_tmp.hs" "topExprs = "-      liftIO $ appendFile "./_tmp.hs" $ show topExprs2-      return ()-    _ -> do-      templatePath <- liftIO $ getDataFileName templateFile-      liftIO $ copyFile templatePath "./_tmp.hs"-      egisonProgram <- liftIO $ readFile inFile-      topExprs <- liftThrows $ readTopExprList egisonProgram-      topExprs2 <- expandLoadExprs opts $ appendLoadExprForCoreLibraries topExprs-      liftIO $ appendFile "./_tmp.hs" "\ntopExprs :: [TopExpr]\n"-      liftIO $ appendFile "./_tmp.hs" "topExprs = "-      liftIO $ appendFile "./_tmp.hs" $ show topExprs2-      return ()--expandLoadExprs :: Options -> [TopExpr] -> IOThrowsError [TopExpr]-expandLoadExprs _ [] = return []-expandLoadExprs opts ((LoadFile filename):topExprs) = do-  result <- liftIO $ doesFileExist filename-  if result-    then do-      loadProgram <- liftIO $ readFile filename-      loadTopExprs <- liftThrows $ readTopExprList loadProgram-      rets <- expandLoadExprs opts topExprs-      return $ loadTopExprs ++ rets-    else throwError $ Default $ "File does not exist: " ++ filename-expandLoadExprs opts ((Load libname):topExprs) = do-  filename <- liftIO (getDataFileName libname)-  result <- liftIO $ doesFileExist filename-  if result-    then do-      loadProgram <- liftIO $ readFile filename-      loadTopExprs <- liftThrows $ readTopExprList loadProgram-      rets <- expandLoadExprs opts topExprs-      return $ loadTopExprs ++ rets-    else throwError $ Default $ "Library does not exist: " ++ libname-expandLoadExprs opts (topExpr@(Test _):topExprs) =-  case opts of-    Options {optTest = True} -> do-      rets <- expandLoadExprs opts topExprs-      return $ topExpr:rets-    _ -> expandLoadExprs opts topExprs-expandLoadExprs opts (topExpr:topExprs) = do-  rets <- expandLoadExprs opts topExprs-  return $ topExpr:rets-  -compileHaskellFile :: Options -> String -> IO ()-compileHaskellFile opts filename = do-  let ghc = "ghc"-  case opts of-    Options {optProf = True} ->-      system $ ghc ++ " -prof -auto-all -o " ++ filename ++ " _tmp.hs"-    _ ->-      system $ ghc ++ " -O2 -o " ++ filename ++ " _tmp.hs"-  removeFile "./_tmp.hs"-  removeFile "./_tmp.hi"-  removeFile "./_tmp.o"-  return ()

@@ -1,138 +1,65 @@ module Main where-import Language.Egison.Core      -- Egison Interpreter-import Language.Egison.Parser-import Language.Egison.Types     -- Egison data types-import Language.Egison.Variables -- Egison variable operations-import System.Console.GetOpt++import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error-import System.IO++import Data.Version+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.Char8 ()+import qualified Data.ByteString.Lazy.Char8 as B+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import Text.Regex.Posix+ import System.Environment+import System.Directory (getHomeDirectory)+import System.FilePath ((</>)) import System.Console.Haskeline-import System.Exit (ExitCode (..), exitWith, exitFailure)-import Text.Regex.Posix+import Language.Egison  main :: IO ()-main = do-  args <- getArgs-  let (actions, nonOpts, _) = getOpt Permute options args-  let opts = foldl (flip id) defaultOptions actions-  case opts of-    Options {optShowHelp = True} -> printHelp-    Options {optShowVersion = True} -> printVersionNumber-    Options {optPrompt = prompt, optShowBanner = bannerFlag} ->-      if null nonOpts-        then do if bannerFlag-                   then showBanner-                   else return ()-                runRepl prompt-                if bannerFlag-                  then showByebyeMessage-                  else return ()-        else do runOne $ nonOpts--data Options = Options {-    optShowVersion :: Bool,-    optShowHelp :: Bool,-    optShowBanner :: Bool,-    optPrompt :: String-    }--showUsage :: IO ()-showUsage = do-  putStrLn "egisonc: no input files"-  -defaultOptions :: Options-defaultOptions = Options {-    optShowVersion = False,-    optShowHelp = False,-    optShowBanner = True,-    optPrompt = "> "-    }--options :: [OptDescr (Options -> Options)]-options = [-  Option ['v', 'V'] ["version"]-    (NoArg (\opts -> opts {optShowVersion = True}))-    "show version number",-  Option ['h', '?'] ["help"]-    (NoArg (\opts -> opts {optShowHelp = True}))-    "show usage information",-  Option [] ["no-banner"]-    (NoArg (\opts -> opts {optShowBanner = False}))-    "show usage information",-  Option ['p'] ["prompt"]-    (ReqArg (\prompt opts -> opts {optPrompt = prompt})-            "String")-    "output file to write"-  ]--printVersionNumber :: IO ()-printVersionNumber = do-  putStrLn egisonVersion-  exitWith ExitSuccess--printHelp :: IO ()-printHelp = do-  putStrLn "Usage: egisonc [options] file"-  putStrLn ""-  putStrLn "Options:"-  putStrLn "  --help                Display this information"-  putStrLn "  --version             Display egison version information"-  putStrLn "  --no-banner           Don't show banner"-  putStrLn "  --prompt string       Set prompt of the interpreter"-  putStrLn ""-  exitWith ExitSuccess---- REPL Section-flushStr :: String -> IO ()-flushStr str = putStr str >> hFlush stdout+main = do args <- getArgs+          env <- primitiveEnv >>= loadLibraries+          if null args+            then showBanner >> repl env "> "+            else do+              result <- evalEgisonTopExpr env $ (LoadFile $ args !! 0)+              either print (const $ return ()) result --- |Execute a single egison file from the command line-runOne :: [String] -> IO ()-runOne args = do-  env <- primitiveBindings-  -- Load standard library-  _ <- loadLibraries env-  result <- runIOThrows $ liftM show $ evalTopExpr env $ Load (args !! 0)-  case result of-    Just errMsg -> putStrLn errMsg-    _  -> do -      -- Call into (main) if it exists...-      alreadyDefined <- liftIO $ isBound env ("main", [])-      when alreadyDefined (do-        mainResult <- runIOThrows $ liftM show $ evalMain env $ args-        case mainResult of-          Just errMsg -> putStrLn errMsg-          _  -> return ())+showBanner :: IO ()+showBanner = do+  putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2013 Satoshi Egi"+  putStrLn $ "http://egison.pira.jp"+  putStrLn $ "Welcome to Egison Interpreter!" --- |Start the REPL (interactive interpreter)-runRepl :: String -> IO ()-runRepl prompt = do-    env <- primitiveBindings-    _ <- loadLibraries env-    runInputT defaultSettings (loop env prompt "")-    where-        loop :: Env -> String -> String -> InputT IO ()-        loop env prompt2 input0 = do-            minput <- getInputLine prompt2-            case minput of-                Nothing -> return ()-                Just "" -> if input0 == ""-                             then loop env prompt2 ""-                             else loop env (take (length prompt) (repeat ' ')) (input0 ++ "\n")-                Just input -> do-                  let newInput = input0 ++ input-                  let eTopExpr = readTopExpr newInput-                  case eTopExpr of-                    Left e -> do-                      if show e =~ "unexpected end of input" -- Is this really OK?-                        then loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n"-                        else do liftIO $ putStrLn $ show e-                                loop env prompt ""-                    Right _ -> do-                      result <- liftIO (evalString env newInput)-                      if (length result) > 0-                        then do outputStrLn result-                                loop env prompt ""-                        else loop env prompt ""+showByebyeMessage :: IO ()+showByebyeMessage = do+  putStrLn $ "Leaving Egison Interpreter." +repl :: Env -> String -> IO ()+repl env prompt = do+  home <- getHomeDirectory+  liftIO (runInputT (settings home) $ loop env prompt "")+  where+    settings :: MonadIO m => FilePath -> Settings m+    settings home = defaultSettings { historyFile = Just (home </> ".egison_history") }+    +    loop :: Env -> String -> String -> InputT IO ()+    loop env prompt' rest = do+      input <- getInputLine prompt'+      case input of+        Nothing -> liftIO showByebyeMessage >> return ()+        Just "quit" -> liftIO showByebyeMessage >> return ()+        Just "" ->  loop env prompt ""+        Just input' -> do+          let newInput = rest ++ input'+          result <- liftIO $ runEgisonTopExpr env newInput+          case result of+            Left err | show err =~ "unexpected end of input" -> do+              loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n"+            Left err -> do+              liftIO $ putStrLn $ show err+              loop env prompt ""+            Right env' ->+              loop env' prompt ""+    

@@ -0,0 +1,57 @@++module Language.Egison+       ( module Language.Egison.Types+       , module Language.Egison.Parser+       , module Language.Egison.Primitives+       , version+       , loadLibraries+       , loadPrimitives+       , runEgisonTopExpr+       , evalEgisonTopExpr+       ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad.Error++import Data.Version+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.Char8 ()+import qualified Data.ByteString.Lazy.Char8 as B+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import qualified Paths_egison as P++import Language.Egison.Types+import Language.Egison.Core+import Language.Egison.Parser+import Language.Egison.Primitives++version :: Version+version = P.version++loadLibraries :: Env -> IO Env+loadLibraries env = do+  result <- runEgisonM $ foldM evalTopExpr env (map Load libraries)+  case result of+    Left err -> do+      print . show $ err+      return env+    Right env' -> +      return env'+  where+    libraries :: [String]+    libraries = [ "lib/core/base.egi"+                , "lib/core/collection.egi"+                , "lib/core/number.egi"+                , "lib/core/pattern.egi" ]+                +loadPrimitives :: Env -> IO Env+loadPrimitives env = (++) <$> return env <*> primitiveEnv++runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env)+runEgisonTopExpr env input = runEgisonM $ do +  expr <- liftError $ readTopExpr input+  evalTopExpr env expr++evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env)+evalEgisonTopExpr env expr = runEgisonM $ evalTopExpr env expr

@@ -1,935 +1,479 @@ module Language.Egison.Core where-import Language.Egison.Numerical-import Language.Egison.Parser-import Language.Egison.Primitives-import Language.Egison.Types-import Language.Egison.Variables-import Language.Egison.Macro-import Control.Monad.Error-import Data.Array-import qualified Data.Map-import qualified System.Exit ()-import System.Directory (doesFileExist)-import System.IO-import qualified System.IO.Strict as SIO-import Data.IORef-import Data.Version-import Paths_egison--egisonVersion :: String-egisonVersion = showVersion version---- |A utility function to display the egison console banner-showBanner :: IO ()-showBanner = do-  putStrLn $ "Egison Version " ++ egisonVersion ++ " (c) 2011-2012 Satoshi Egi"-  putStrLn $ "http://egison.pira.jp"-  putStrLn $ "Welcome to Egison Interpreter!"---- |A utility function to display the egison console byebye message-showByebyeMessage :: IO ()-showByebyeMessage = do-  putStrLn $ "Leaving Egison."-  putStrLn $ "Byebye. See you again! (^^)/"---- |Load standard libraries into the given environment-loadLibraries :: Env -> IO ()-loadLibraries env = do-  -- Load standard library-  _ <- evalString env $ "(load \"lib/core/base.egi\")"-  _ <- evalString env $ "(load \"lib/core/number.egi\")"-  _ <- evalString env $ "(load \"lib/core/collection.egi\")"-  _ <- evalString env $ "(load \"lib/core/array.egi\")"-  _ <- evalString env $ "(load \"lib/core/pattern.egi\")"-  return ()--  --- |A utility function to escape backslashes in the given string-escapeBackslashes :: String -> String-escapeBackslashes s = foldr step [] s-  where step x xs  | x == '\\'  = '\\' : '\\' : xs-                   | otherwise =  x : xs ---evalString :: Env -> String -> IO String-evalString env str = runIOThrowsREPL $ (liftThrows $ readTopExpr str) >>= evalTopExpr env--evalMain :: Env -> [String] -> IOThrowsError EgisonVal-evalMain env args = do-  let mainExpr = VarExpr "main" []-  main <- cEval1 $ Closure env mainExpr-  mainRef <- liftIO $ newIORef main-  let argvExpr = CollectionExpr $ map (ElementExpr . StringExpr) args-  argv <- cEval1 $ Closure env argvExpr-  argvRef <- liftIO $ newIORef argv-  worldRef <- liftIO $ newIORef $ Value $ World []-  argsRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ [worldRef, argvRef]-  ret <- cApply1 mainRef argsRef-  cEval ret---- |Evaluate egison top expression that has already been loaded into haskell-evalTopExpr :: Env -> TopExpr -> IOThrowsError String-evalTopExpr env (Test expr) = liftM show $ eval env expr-evalTopExpr env (Define name expr) = do clr <- liftIO $ makeClosure env expr-                                        defineVar env (name, []) clr-                                        return name-evalTopExpr env (Execute args) = do evalMain env args-                                    return ""-evalTopExpr env (LoadFile filename) = do-  result <- liftIO $ doesFileExist filename-  if result-    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 $ SIO.run $ SIO.readFile filename) >>= load env-            return $ filename ++ " loaded."-    else throwError $ Default $ "Library does not exist: " ++ libname--  -load :: Env -> String -> IOThrowsError ()-load env str = do-  exprs <- liftThrows $ readTopExprList str-  mapM (evalTopExpr env) exprs-  return ()---- |Evaluate egison expression that has already been loaded into haskell-eval :: Env -> EgisonExpr -> IOThrowsError EgisonVal-eval env expr = do-  obj <- cEval1 (Closure env expr)-  case obj of-    Value val -> return val-    Intermidiate iVal -> iEval iVal-    _ -> throwError $ Default $ "eval: cannot reach here!: " ++ show obj--iEval :: IntermidiateVal -> IOThrowsError EgisonVal-iEval (IInductiveData cons argRefs) = do-  args <- mapM cRefEval argRefs-  return $ InductiveData cons args-iEval (ICollection innerRefs) = do-  vals <- innerRefsEval innerRefs-  return $ Collection vals-iEval (ITuple objRefs) = do-  vals <- mapM cRefEval objRefs-  return $ Tuple vals--innerRefsEval :: [InnerValRef] -> IOThrowsError [EgisonVal]-innerRefsEval [] = return []-innerRefsEval ((IElement objRef):rest) = do-  val <- cRefEval objRef-  vals <- innerRefsEval rest-  return (val:vals)-innerRefsEval ((ISubCollection subObjRef):rest) = do-  subVal <- cRefEval subObjRef-  case subVal of-    Collection vals -> do-      retRest <- innerRefsEval rest-      return $ vals ++ retRest-    _ -> throwError $ Default "innerRefsEval: not collection for subcollection"--cRefEval :: ObjectRef -> IOThrowsError EgisonVal-cRefEval objRef = do-  obj <- liftIO $ readIORef objRef-  val <- cEval obj-  liftIO $ writeIORef objRef $ Value val-  return val--cRefEval1 :: ObjectRef -> IOThrowsError Object-cRefEval1 objRef = do-  obj <- liftIO $ readIORef objRef-  case obj of-    Closure _ _ -> do-      obj2 <- cEval1 obj-      liftIO $ writeIORef objRef obj2-      return obj2-    _ -> return obj--cEval :: Object -> IOThrowsError EgisonVal-cEval (Closure env expr) = eval env expr-cEval (Value val) = return val-cEval (Intermidiate iVal) = iEval iVal-cEval (Loop _ _ _ _ _) = throwError $ Default "cEval: cannot reach here: loop object cannot be evaluated"--cEval1 :: Object -> IOThrowsError Object-cEval1 (Closure _ (BoolExpr contents)) = return $ Value (Bool contents)-cEval1 (Closure _ (CharExpr contents)) = return $ Value (Char contents)-cEval1 (Closure _ (StringExpr contents)) = return $ Value (String contents)-cEval1 (Closure _ (NumberExpr contents)) = return $ Value (Number contents)-cEval1 (Closure _ (FloatExpr contents)) = return $ Value (Float contents)-cEval1 (Closure _ SomethingExpr) = return $ Value Something-cEval1 (Closure env (VarExpr name numExprs)) = do-  numVals <- mapM (eval env) numExprs-  nums <- mapM (\nVal -> case nVal of-                           Number num -> return num-                           _ -> throwError  $ Default "cEval1: cannot reach here!")-               numVals-  objRef <- getVar env (name, nums)-  obj <- cRefEval1 objRef-  case obj of -- for Macro expansion-    Loop _ _ _ _ _ -> expandLoop env obj-    _ -> return obj-cEval1 (Closure _ (InductiveDataExpr cons [])) = do-  return $ Value $ InductiveData cons []-cEval1 (Closure env (InductiveDataExpr cons argExprs)) = do-  args <- liftIO $ mapM (makeClosure env) argExprs-  return $ Intermidiate $ IInductiveData cons args-cEval1 (Closure _ (TupleExpr [])) = do-  return $ Value $ Tuple []-cEval1 (Closure env (TupleExpr exprs)) = do-  objRefs <- liftIO $ mapM (makeClosure env) exprs-  case objRefs of-    [objRef] -> cRefEval1 objRef-    _ -> return $ Intermidiate $ ITuple objRefs-cEval1 (Closure env (CollectionExpr innerExprs)) = do-  innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs-  return $ Intermidiate $ ICollection innerRefs-cEval1 (Closure env (ArrayExpr innerArrayExprs)) = do-  let dimension = calcDimension innerArrayExprs-  let size = calcSize innerArrayExprs-  elemExprs <- liftThrows $ calcElemExprs innerArrayExprs-  vals <- mapM (eval env) elemExprs-  return $ Value $ Array dimension size $ listArray (1, (fromIntegral (length vals))) vals- where calcDimension aExprs = helper 1 aExprs-        where helper n [] = n-              helper n ((AElementExpr _):_) = n-              helper n ((AInnerArrayExpr inner):_) = helper (n + 1) inner-       calcSize aExprs = helper [] aExprs-        where helper ns [] = ns ++ [0]-              helper ns aExprs2@((AElementExpr _):_) = ns ++ [(fromIntegral (length aExprs2))]-              helper ns aExprs2@((AInnerArrayExpr inner):_) = helper (ns ++ [(fromIntegral (length aExprs2))]) inner-       calcElemExprs [] = return []-       calcElemExprs aExprs@((AElementExpr _):_) = mapM (\aExpr -> case aExpr of-                                                                     AElementExpr expr -> return expr-                                                                     _ -> throwError $ Default "type error in array")-                                                        aExprs-       calcElemExprs aExprs@((AInnerArrayExpr _):_) = liftM concat $ mapM (\aExpr -> case aExpr of-                                                                                       AInnerArrayExpr aExprs2 -> calcElemExprs aExprs2-                                                                                       _ -> throwError $ Default "type error in array")-                                                                          aExprs-cEval1 (Closure _ WildCardExpr) = return $ Value WildCard-cEval1 (Closure env (PatVarExpr name numExprs)) = do-  numVals <- mapM (eval env) numExprs-  nums <- mapM (\nVal -> case nVal of-                           Number num -> return num-                           _ -> throwError $ Default "cEval1: cannot reach here!")-               numVals-  return $ Value $ PatVar name nums-cEval1 (Closure env (ValuePatExpr expr)) = do-  objRef <- liftIO $ makeClosure env expr-  return $ Value $ ValuePat objRef-cEval1 (Closure env (PredPatExpr predExpr argExprs)) = do-  predObjRef <- liftIO $ makeClosure env predExpr-  argObjRefs <- liftIO $ mapM (makeClosure env) argExprs-  return $ Value $ PredPat predObjRef argObjRefs-cEval1 (Closure env (CutPatExpr patExpr)) = do-  patObjRef <- liftIO $ makeClosure env patExpr-  return $ Value $ CutPat patObjRef-cEval1 (Closure env (NotPatExpr patExpr)) = do-  patObjRef <- liftIO $ makeClosure env patExpr-  return $ Value $ NotPat patObjRef-cEval1 (Closure env (OrPatExpr patExprs)) = do-  patObjRefs <- liftIO $ mapM (makeClosure env) patExprs-  return $ Value $ OrPat patObjRefs-cEval1 (Closure env (AndPatExpr patExprs)) = do-  patObjRefs <- liftIO $ mapM (makeClosure env) patExprs-  return $ Value $ AndPat patObjRefs-cEval1 (Closure env (FuncExpr args body)) = do-  argsObjRef <- liftIO $ makeClosure env args-  return $ Value $ Func argsObjRef body env-cEval1 (Closure _ (MacroExpr args body)) = do-  return $ Value $ Macro args body-cEval1 (Closure env (IfExpr condExpr expr1 expr2)) = do-  obj <- cEval1 $ Closure env condExpr-  case obj of-    Value (Bool True) -> cEval1 $ Closure env expr1-    Value (Bool False) -> cEval1 $ Closure env expr2-    _ -> throwError $ Default "if: condition is not bool value"-cEval1 (Closure env (LetExpr bindings body)) = do-  newEnv <- extendLet env bindings-  cEval1 (Closure newEnv body)-cEval1 (Closure env (LetRecExpr bindings body)) = do-  newEnv <- liftIO $ extendLetRec env bindings-  cEval1 $ Closure newEnv body-cEval1 (Closure env (DoExpr [] body)) = do-  cEval1 $ Closure env body-cEval1 (Closure env (DoExpr (binding:bindings) body)) = do-  newEnv <- extendLet env [binding]-  cEval1 $ Closure newEnv $ DoExpr bindings body-cEval1 (Closure env (TypeExpr destructInfoExpr)) = do-  destructInfo <- liftIO $ makeDestructInfo destructInfoExpr-  return $ Value $ Type destructInfo- where makeDestructInfo [] = return []-       makeDestructInfo ((pppat, typExpr, pmcs):rest) = do-         typObjRef <- liftIO $ makeClosure env typExpr-         let epmcs = map (\(ppat, body) -> (env, ppat, body)) pmcs-         retRest <- makeDestructInfo rest-         return ((pppat, typObjRef, epmcs):retRest)-cEval1 (Closure env (MatchAllExpr tgtExpr typExpr (patExpr, body))) = do-  patObjRef <- liftIO $ makeClosure env patExpr-  tgtObjRef <- liftIO $ makeClosure env tgtExpr-  typObjRef <- liftIO $ makeClosure env typExpr-  matchs <- patternMatch MAll [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]-  rets <- mapM (\match -> do newEnv <- liftIO $ extendEnv env match-                             objRef <- liftIO $ newIORef (Closure newEnv body)-                             return objRef)-               matchs-  return $ Intermidiate $ ICollection $ map IElement rets-cEval1 (Closure env (MatchExpr tgtExpr typExpr mcs)) = do-  tgtObjRef <- liftIO $ makeClosure env tgtExpr-  typObjRef <- liftIO $ makeClosure env typExpr-  mcLoop tgtObjRef typObjRef mcs- where mcLoop _ _ [] = throwError $ Default "end of match clauses"-       mcLoop tgtObjRef typObjRef ((patExpr, body):rest) = do-         patObjRef <- liftIO $ makeClosure env patExpr-         matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]-         case matchs of-           [] -> mcLoop tgtObjRef typObjRef rest-           [match] -> do newEnv <- liftIO $ extendEnv env match-                         cEval1 (Closure newEnv body)-           _ -> throwError $ Default "cEval1.mcLoop: cannot reach here"-cEval1 (Closure env (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr)) = do-  rangeObjRef <- liftIO $ makeClosure env rangeExpr-  let loopObj = Loop loopVar indexVar rangeObjRef loopExpr tailExpr-  expandLoop env loopObj-cEval1 (Closure env (GenerateArrayExpr fnExpr rangeExpr)) = do-  fnObjRef <- liftIO $ makeClosure env fnExpr-  rangeVal <- eval env rangeExpr-  ms <- liftThrows $ mapM fromEgisonVal $ tupleToList rangeVal-  let d = fromIntegral $ length ms-  let is = map (\iss -> (Value . Tuple) $ map Number iss) $ indexList ms-  isRefs <- liftIO $ mapM newIORef is-  vals <- mapM (cApply fnObjRef) isRefs-  return $ Value $ Array d ms $ listArray (1, (fromIntegral (length vals))) vals-cEval1 (Closure env (ApplyExpr opExpr argExpr)) = do-  op <- cEval1 (Closure env opExpr)-  case op of-    Value (IOFunc fn) -> do arg <- eval env argExpr-                            val <- fn (tupleToList arg)-                            return $ Value val-    Value (PrimitiveFunc fn) -> do arg <- eval env argExpr-                                   val <- liftThrows $ fn (tupleToList arg)-                                   return $ Value val-    Value (Func fArgs body cEnv) -> do argObjRef <- liftIO $ makeClosure env argExpr-                                       frame <- makeFrame fArgs argObjRef-                                       newEnv <- liftIO $ extendEnv cEnv frame-                                       cEval1 (Closure newEnv body)-    Value (Macro mArgs body) -> do argExprs <- liftThrows $ tupleExprToExprList argExpr-                                   newBody <- expandMacro (Data.Map.fromList (zip mArgs argExprs)) body-                                   cEval1 (Closure env newBody)-    _ -> throwError $ Default "not function"-cEval1 (Closure _ UndefinedExpr) = do-  throwError ReachToUndefined-cEval1 val = do-  return val--cApply :: ObjectRef -> ObjectRef -> IOThrowsError EgisonVal-cApply fnObjRef argObjRef = do-  fnObj <- cRefEval1 fnObjRef-  case fnObj of-    Value (IOFunc fn) -> do arg <- cRefEval argObjRef-                            val <- fn (tupleToList arg)-                            return $ val-    Value (PrimitiveFunc fn) -> do arg <- cRefEval argObjRef-                                   val <- liftThrows $ fn (tupleToList arg)-                                   return $ val-    Value (Func fArgs body cEnv) -> do frame <- makeFrame fArgs argObjRef-                                       newEnv <- liftIO $ extendEnv cEnv frame-                                       cEval (Closure newEnv body)-    _ -> throwError $ Default "cApply1 not function"--cApply1 :: ObjectRef -> ObjectRef -> IOThrowsError Object-cApply1 fnObjRef argObjRef = do-  fnObj <- cRefEval1 fnObjRef-  case fnObj of-    Value (IOFunc fn) -> do arg <- cRefEval argObjRef-                            val <- fn (tupleToList arg)-                            return $ Value val-    Value (PrimitiveFunc fn) -> do arg <- cRefEval argObjRef-                                   val <- liftThrows $ fn (tupleToList arg)-                                   return $ Value val-    Value (Func fArgs body cEnv) -> do frame <- makeFrame fArgs argObjRef-                                       newEnv <- liftIO $ extendEnv cEnv frame-                                       cEval1 (Closure newEnv body)-    _ -> throwError $ Default "cApply1: not function"---expandLoop :: Env -> Object -> IOThrowsError Object-expandLoop env (Loop loopVar indexVar rangeObjRef loopExpr tailExpr) = do-  cRefEval1 rangeObjRef-  b <- isEmptyCollection rangeObjRef-  if b-    then cEval1 $ Closure env tailExpr-    else do (carObjRef,cdrObjRef) <- consDestruct rangeObjRef-            loopObjRef <- liftIO $ newIORef $ Loop loopVar indexVar cdrObjRef loopExpr tailExpr-            newEnv <- liftIO $ extendEnv env [((loopVar,[]),loopObjRef),((indexVar,[]),carObjRef)]-            cEval1 $ Closure newEnv loopExpr-expandLoop _ obj = throwError $ Default $ "expandLoop: cannot reach here: " ++ show obj-           -extendLet :: Env -- ^ Environment -          -> [(EgisonExpr, EgisonExpr)] -- ^ Extensions to the environment-          -> IOThrowsError Env -- ^ Extended environment-extendLet env binding = do- frame <- helper binding- liftIO $ extendEnv env frame- where helper :: [(EgisonExpr, EgisonExpr)] -> IOThrowsError FrameList-       helper [] = return []-       helper ((patExpr, tgtExpr):rest) = do-         patObjRef <- liftIO $ makeClosure env patExpr-         tgtObjRef <- liftIO $ makeClosure env tgtExpr-         frame <- makeFrame patObjRef tgtObjRef-         retRest <- helper rest-         return $ frame ++ retRest--makeFrame :: ObjectRef -> ObjectRef -> IOThrowsError FrameList-makeFrame patObjRef tgtObjRef = do-  patObjRefs <- tupleToObjRefs patObjRef-  let n = length patObjRefs-  if n == 1-    then do typObjRef <- liftIO $ newIORef $ Value Something-            matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]           -            case matchs of-              [match] -> return match-              _ -> throwError $ Default "makeFrame: binding error"-    else do typObjRef <- liftIO $ newIORef $ (Value . Tuple) $ replicate (length patObjRefs) Something-            matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]           -            case matchs of-              [match] -> do return match-              _ -> throwError $ Default "makeFrame: binding error"--tupleExprToExprList :: EgisonExpr -> ThrowsError [EgisonExpr]-tupleExprToExprList (TupleExpr exprs) = return exprs-tupleExprToExprList expr = return [expr]--innerExprsToExprList :: [InnerExpr] -> ThrowsError [EgisonExpr]-innerExprsToExprList [] = return []-innerExprsToExprList ((ElementExpr expr):rest) = do retRest <- innerExprsToExprList rest-                                                    return (expr:retRest)-innerExprsToExprList ((SubCollectionExpr _):_) = throwError $ Default "innerExprsToExprList: subcollection is not supported"-    -innerValRefsToObjRefs :: [InnerValRef] -> IOThrowsError [ObjectRef]-innerValRefsToObjRefs [] = return []-innerValRefsToObjRefs (innerRef:rest) = do-  restRet <- innerValRefsToObjRefs rest-  case innerRef of-    IElement objRef -> return $ objRef:restRet-    ISubCollection objRef -> do-      obj2 <- cRefEval1 objRef-      case obj2 of-        Intermidiate (ICollection innerRefs) -> do-          objRefs <- innerValRefsToObjRefs innerRefs-          return $ objRefs ++ restRet-        Value (Collection vals) -> do-          objRefs <- liftIO $ mapM newIORef $ map Value vals-          return $ objRefs ++ restRet-        _ -> throwError $ Default "innerValRefsToObjRefs: not collection"--patternMatch :: MatchFlag -> [MState] -> IOThrowsError [FrameList]-patternMatch _ [] = return []-patternMatch MAll ((MState frame []):rest) = do-  frames <- patternMatch MAll rest-  return (frame:frames)-patternMatch MOne ((MState frame []):_) = do-  return [frame]-patternMatch flag ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef)-                                  :atoms))-                 :states) = do-  patObj <- liftIO $ readIORef patObjRef-  case patObj of-    Closure env expr ->-      do newEnv <- liftIO $ extendEnv env bf-         patObj2 <- cEval1 $ Closure newEnv expr-         patObjRef2 <- liftIO $ newIORef patObj2-         patternMatch flag ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef)-                                           :atoms))-                            :states)-    Value WildCard -> patternMatch flag ((MState frame atoms):states)-    Value (PatVar name nums) -> do-      typObj <- cRefEval1 typObjRef-      case typObj of-        Value (Type deconsInfo) -> do-          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef-          case indRet of-            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                      inTgtObjRefss) ++ states)-        Value Something ->-          patternMatch flag $ (MState (((name, nums), tgtObjRef):frame)-                                      (map (\(MAtom (PClosure bf2 pat2) tgt2 typ2) ->-                                             (MAtom (PClosure (((name, nums), tgtObjRef):bf2) pat2) tgt2 typ2))-                                           atoms)):states-        _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"-    Value (ValuePat _) -> do -- same with Inductive Pattern-      typObj <- cRefEval1 typObjRef-      case typObj of-        Value (Type deconsInfo) -> do-          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef-          case indRet of-            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                      inTgtObjRefss) ++ states)-        Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"-        _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"-    Value (InductiveData _ _) -> do -- same with ValuePat-      typObj <- cRefEval1 typObjRef-      case typObj of-        Value (Type deconsInfo) -> do-          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef-          case indRet of-            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                      inTgtObjRefss) ++ states)-        Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"-        _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"-    Intermidiate (IInductiveData _ _) -> do -- same with ValuePat-      typObj <- cRefEval1 typObjRef-      case typObj of-        Value (Type deconsInfo) -> do-          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef-          case indRet of-            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                      inTgtObjRefss) ++ states)-        Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"-        _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"-    Intermidiate (ITuple patObjRefs) -> do-      typObjRefs <- tupleToObjRefs typObjRef-      if length typObjRefs == 1-        then do-          let tgtObjRefs = [tgtObjRef]-          if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs)-            then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states-            else throwError $ Default "patternMatch(ITuple-1): number of types, patterns and targets are different"-        else do-          tgtObjRefs <- tupleToObjRefs tgtObjRef-          if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs)-            then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states-            else throwError $ Default "patternMatch(ITuple): number of types, patterns and targets are different"-    Value (Tuple pats) -> do-      patObjRefs <- liftIO $ mapM (newIORef . Value) pats-      typObjRefs <- tupleToObjRefs typObjRef-      if length typObjRefs == 1-        then do-          let tgtObjRefs = [tgtObjRef]-          if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs)-            then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states-            else throwError $ Default "patternMatch(Tuple-1): number of types, patterns and targets are different"-        else do-          tgtObjRefs <- tupleToObjRefs tgtObjRef-          if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs)-            then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states-            else throwError $ Default "patternMatch(Tuple): number of types, patterns and targets are different"-    Value (PredPat predObjRef patObjRefs) -> do-      argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ patObjRefs ++ [tgtObjRef]-      ret <- cApply1 predObjRef argsObjRef-      case ret of-        Value (Bool True) -> patternMatch flag ((MState frame atoms):states)-        Value (Bool False) -> patternMatch flag states-        _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean value")-    Value (NotPat patObjRef2) -> do-      retFrames <- patternMatch MOne [(MState frame [(MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef)])]-      case retFrames of-        [] -> patternMatch flag ((MState frame atoms):states)-        _ -> patternMatch flag states-    Value (AndPat patObjRefs) ->-      patternMatch flag ((MState frame ((map (\patObjRef2 -> (MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef)) patObjRefs) ++ atoms)):states)-    Value (OrPat patObjRefs) ->-      patternMatch flag ((map (\patObjRef2 -> (MState frame ((MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef):atoms)))-                              patObjRefs) ++ states)-    Value (CutPat patObjRef2) -> do-      retFrames <- patternMatch flag [(MState frame ((MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef):atoms))]-      case retFrames of-        [] -> return []-        _ -> case flag of-               MAll -> do restFrames <- patternMatch flag states-                          return (retFrames ++ restFrames)-               MOne -> return retFrames-    _ -> throwError $ Default $ "invalid pattern: " ++ show patObj-        -inductiveMatch :: DestructInfo -> ObjectRef -> ObjectRef -> IOThrowsError ([ObjectRef], [ObjectRef], [[ObjectRef]])-inductiveMatch [] _ _ = throwError $ Default "inductiveMatch: not matched any primitive pattern clauses"-inductiveMatch ((pppat, typObjRef, pclss):rest) patObjRef tgtObjRef = do-  mRet <- primitivePatPatternMatch pppat patObjRef-  case mRet of-    Nothing -> inductiveMatch rest patObjRef tgtObjRef-    Just (patObjRefs, frame) -> do-      mPpmRet <- helper pclss-      case mPpmRet of-        Nothing -> throwError $ Default "inductiveMatch: not matched any primitive clauses"-        Just tgtObjRefs -> do-          typObjRefs <- tupleToObjRefs typObjRef-          if length typObjRefs == 1-            then do let tgtObjRefss = map (\x -> [x]) tgtObjRefs-                    return (typObjRefs, patObjRefs, tgtObjRefss)-            else do tgtObjRefss <- mapM tupleToObjRefs tgtObjRefs-                    return (typObjRefs, patObjRefs, tgtObjRefss)-     where helper [] = return Nothing-           helper ((env, ppat, expr):pclss2) = do-             mPpmRet <- primitivePatternMatch ppat tgtObjRef-             case mPpmRet of-               Nothing -> helper pclss2-               Just ppmRet -> do-                 newEnv <- liftIO $ extendEnv env (ppmRet ++ frame)-                 retObjRef <- liftIO $ makeClosure newEnv expr-                 tgtObjRefs <- collectionToObjRefs retObjRef-                 return $ Just tgtObjRefs--primitivePatPatternMatch :: PrimitivePatPattern -> ObjectRef -> IOThrowsError (Maybe ([ObjectRef], FrameList))-primitivePatPatternMatch PPWildCard patObjRef = return $ Just ([patObjRef], [])-primitivePatPatternMatch (PPValuePat name) patObjRef = do-  patObj <- cRefEval1 patObjRef-  case patObj of-    Value (ValuePat objRef) -> return $ Just ([], [((name, []), objRef)])-    _ -> return $ Nothing-primitivePatPatternMatch (PPInductivePat ppcons pppats) patObjRef = do-  patObj <- cRefEval1 patObjRef-  case patObj of-    Intermidiate (IInductiveData pcon patObjRefs) ->-      if ppcons == pcon-        then primitivePatPatternMatchList pppats patObjRefs-        else return Nothing-    Value (InductiveData pcon patVals) -> do-      patObjRefs <- liftIO $ mapM (newIORef . Value) patVals-      if ppcons == pcon-        then primitivePatPatternMatchList pppats patObjRefs-        else return Nothing-    _ -> return $ Nothing--primitivePatPatternMatchList :: [PrimitivePatPattern] -> [ObjectRef] -> IOThrowsError (Maybe ([ObjectRef], FrameList))-primitivePatPatternMatchList [] [] = return $ Just ([], [])-primitivePatPatternMatchList (pppat:pppats) (patObjRef:patObjRefs) = do-  mRet <- primitivePatPatternMatch pppat patObjRef-  case mRet of-    Nothing -> return Nothing-    Just (retPatObjRefs, retFrame) -> do-      mRetRest <- primitivePatPatternMatchList pppats patObjRefs-      case mRetRest of-        Nothing -> return Nothing-        Just (retRestPatObjRefs, retRestFrame) -> return $ Just (retPatObjRefs ++ retRestPatObjRefs, retFrame ++ retRestFrame)-primitivePatPatternMatchList pppats _ = throwError $ Default $ "primitivePatPatternMatch: number of pppat and pat are different: " ++ show pppats-    -primitivePatternMatch :: PrimitivePattern -> ObjectRef -> IOThrowsError (Maybe FrameList)-primitivePatternMatch (PPatBool bool) objRef = do-  val <- cRefEval objRef-  case val of-    Bool bool2 -> if bool == bool2-                   then return (Just [])-                   else return Nothing-    _ -> return Nothing-primitivePatternMatch (PPatChar chr) objRef = do-  val <- cRefEval objRef-  case val of-    Char chr2 -> if chr == chr2-                   then return (Just [])-                   else return Nothing-    _ -> return Nothing-primitivePatternMatch (PPatNumber num) objRef = do-  val <- cRefEval objRef-  case val of-    Number num2 -> if num == num2-                     then return (Just [])-                     else return Nothing-    _ -> return Nothing-primitivePatternMatch (PPatFloat d) objRef = do-  val <- cRefEval objRef-  case val of-    Float d2 -> if d == d2-                  then return (Just [])-                  else return Nothing-    _ -> return Nothing-primitivePatternMatch PWildCard _ = return $ Just []-primitivePatternMatch (PPatVar name) objRef = return (Just [((name,[]), objRef)])-primitivePatternMatch (PInductivePat pCons pPats) objRef =  do-  obj <- cRefEval1 objRef-  case obj of-    Intermidiate (IInductiveData cons objRefs) ->-      if pCons == cons-        then primitivePatternMatchList pPats objRefs-        else return Nothing-    Value (InductiveData cons vals) ->-      if pCons == cons-        then do objRefs <- liftIO $ mapM (newIORef . Value) vals-                primitivePatternMatchList pPats objRefs-        else return Nothing-    _ -> return Nothing-primitivePatternMatch PEmptyPat objRef = do-  cRefEval1 objRef-  b <- isEmptyCollection objRef-  if b-    then return (Just [])-    else return Nothing-primitivePatternMatch (PConsPat carPat cdrPat) objRef = do-  cRefEval1 objRef-  b <- isEmptyCollection objRef-  if b-    then return Nothing-    else do (carObjRef, cdrObjRef) <- consDestruct objRef-            mCarFrame <- primitivePatternMatch carPat carObjRef-            case mCarFrame of-              Nothing -> return Nothing-              Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrObjRef-                                  case mCdrFrame of-                                    Nothing -> return Nothing-                                    Just cdrFrame -> return (Just (carFrame ++ cdrFrame))-primitivePatternMatch (PSnocPat rdcPat racPat) objRef = do-  cRefEval1 objRef-  b <- isEmptyCollectionForSnoc objRef-  if b-    then return Nothing-    else do (racObjRef, rdcObjRef) <- snocDestruct objRef-            mRacFrame <- primitivePatternMatch racPat racObjRef-            case mRacFrame of-              Nothing -> return Nothing-              Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcObjRef-                                  case mRdcFrame of-                                    Just rdcFrame -> return (Just (racFrame ++ rdcFrame))-                                    Nothing -> return Nothing-            -primitivePatternMatchList :: [PrimitivePattern] -> [ObjectRef] -> IOThrowsError (Maybe FrameList)-primitivePatternMatchList [] [] = return (Just [])-primitivePatternMatchList (pat:pats) (objRef:objRefs) = do-  mFrame <- primitivePatternMatch pat objRef-  case mFrame of-    Nothing -> return Nothing-    Just frame -> do mRestFrame <- primitivePatternMatchList pats objRefs-                     case mRestFrame of-                       Nothing -> return Nothing-                       Just restFrame -> return (Just (frame ++ restFrame))-primitivePatternMatchList _ _ = throwError $ Default "primitivePatternMatchList : number of patterns and targets are different"---objectRefToInnerRefs :: ObjectRef -> IOThrowsError [InnerValRef]-objectRefToInnerRefs objRef = do-  obj <- cRefEval1 objRef-  case obj of-    Intermidiate (ICollection innerRefs) -> return innerRefs-    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-  obj <- liftIO $ readIORef objRef-  case obj of-    Intermidiate (ICollection []) -> return True-    Intermidiate (ICollection ((IElement _):_)) -> return False-    Intermidiate (ICollection ((ISubCollection subObjRef):rest)) -> do-      innerRefs <- objectRefToInnerRefs subObjRef-      liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ innerRefs ++ rest-      isEmptyCollection objRef-    Value (Collection []) -> return True-    Value (Collection _) -> return False-    _ -> throwError $ Default $ "isEmptyCollection: not collection:" ++ show obj--isEmptyCollectionForSnoc :: ObjectRef -> IOThrowsError Bool-isEmptyCollectionForSnoc objRef = do-  obj <- liftIO $ readIORef objRef-  case obj of-    Intermidiate (ICollection innerRefs) -> do-      case reverse innerRefs of-        [] -> return True-        ((IElement _):_) -> return False-        ((ISubCollection subObjRef):rest) -> do-          subInnerRefs <- objectRefToInnerRefs subObjRef-          liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ subInnerRefs-          isEmptyCollectionForSnoc objRef-    Value (Collection []) -> return True-    Value (Collection _) -> return False-    _ -> throwError $ Default $ "isEmptyCollectionForSnoc: not collection:" ++ show obj--consDestruct :: ObjectRef -> IOThrowsError (ObjectRef, ObjectRef)-consDestruct objRef = do-  obj <- liftIO $ readIORef objRef-  case obj of-    Intermidiate (ICollection []) -> throwError $ Default "consDestructInnerRefs: empty collection"-    Intermidiate (ICollection ((IElement carObjRef):rest)) -> do-      cdrObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection rest-      return (carObjRef, cdrObjRef)-    Intermidiate (ICollection ((ISubCollection subObjRef):rest)) -> do-      innerRefs <- objectRefToInnerRefs subObjRef-      liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ innerRefs ++ rest-      consDestruct objRef-    Value (Collection (val:vals)) -> do-      carObjRef <- liftIO $ newIORef $ Value val-      cdrObjRef <- liftIO $ newIORef $ Value $ Collection vals-      return (carObjRef, cdrObjRef)-    _ -> throwError $ Default "consDestruct: not collection"--snocDestruct :: ObjectRef -> IOThrowsError (ObjectRef, ObjectRef)-snocDestruct objRef = do-  obj <- liftIO $ readIORef objRef-  case obj of-    Intermidiate (ICollection innerRefs) -> do-      case reverse innerRefs of-        [] -> throwError $ Default "snocDestructInnerRefs: empty collection"-        ((IElement racObjRef):rest) -> do-          rdcObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection $ reverse rest-          return (racObjRef, rdcObjRef)-        ((ISubCollection subObjRef):rest) -> do-          subInnerRefs <- objectRefToInnerRefs subObjRef-          liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ subInnerRefs-          snocDestruct objRef-    Value (Collection vals) -> do-      case reverse vals of-        (val:rest) -> do-          racObjRef <- liftIO $ newIORef $ Value val-          rdcObjRef <- liftIO $ newIORef $ Value $ Collection rest-          return (racObjRef, rdcObjRef)-        _ -> throwError $ Default "snocDestruct: not collection"-    _ -> throwError $ Default "snocDestruct: not collection"-    -collectionToObjRefs :: ObjectRef -> IOThrowsError [ObjectRef]-collectionToObjRefs objRef = do-  obj <- cRefEval1 objRef-  case obj of-    Intermidiate (ICollection innerRefs) -> innerRefsToObjRefs innerRefs-    Value (Collection vals) -> liftIO $ mapM (newIORef . Value) vals-    _ -> throwError $ Default "collectionToObjRefs: not collection"--tupleToObjRefs :: ObjectRef -> IOThrowsError [ObjectRef]-tupleToObjRefs objRef = do-  obj <- cRefEval1 objRef-  case obj of-    Intermidiate (ITuple objRefs) -> return objRefs-    Value (Tuple vals) -> liftIO $ mapM (newIORef . Value) vals-    _ -> return [objRef]--innerRefsToObjRefs :: [InnerValRef] -> IOThrowsError [ObjectRef]-innerRefsToObjRefs [] = return []-innerRefsToObjRefs ((IElement objRef):rest) = do-  retRest <- innerRefsToObjRefs rest-  return $ objRef:retRest-innerRefsToObjRefs ((ISubCollection objRef):rest) = do-  retObj <- collectionToObjRefs objRef-  retRest <- innerRefsToObjRefs rest-  return $ retObj ++ retRest--  -primitiveBindings :: IO Env-primitiveBindings = do-  initEnv <- nullEnv-  constantsFrameList <- mapM domakeObjRef constants-  iOFuncs <- mapM (domakeFunc IOFunc) ioPrimitives-  primitiveFuncs <- mapM (domakeFunc PrimitiveFunc) primitives-  extendEnv initEnv (constantsFrameList ++ iOFuncs ++ primitiveFuncs)- where domakeFunc constructor (name, func) = do-         objRef <- newIORef $ Value $ constructor func-         return ((name, []), objRef)-       domakeObjRef (name, val) = do-         objRef <- newIORef $ Value val-         return ((name, []), objRef)---constants :: [(String, EgisonVal)]-constants = [("pi", Float 3.141592653589793)-             ]-         -{- I/O primitives -}-ioPrimitives :: [(String, [EgisonVal] -> IOThrowsError EgisonVal)]-ioPrimitives = [("get-lib-dir-name", getLibDirName),-                ("open-input-file", makePort ReadMode),-                ("open-output-file", makePort WriteMode),-                ("close-input-port", closePort),-                ("close-output-port", closePort),-                ("read-char", readChar),-                ("read-line", readLine),-                ("read", readFromStdin),-                ("write-char", writeChar),-                ("write-string", writeString),-                ("print", writeStringLine),-                ("write", write),-                ("flush", flushStdout),-                ("read-char-from-port", readCharFromPort),-                ("read-line-from-port", readLineFromPort),-                ("read-from-port", readFromPort),-                ("write-char-to-port", writeCharToPort),-                ("write-string-to-port", writeStringToPort),-                ("print-to-port", writeStringLineToPort),-                ("write-to-port", writeToPort),-                ("flush-port", flushPort)-                ]--{- "Pure" primitive functions -}-primitives :: [(String, [EgisonVal] -> ThrowsError EgisonVal)]-primitives = [("+", multiOp ((+) :: Integer -> Integer -> Integer)),-              ("-", multiOp ((-) :: Integer -> Integer -> Integer)),-              ("*", multiOp ((*) :: Integer -> Integer -> Integer)),---              ("/", multiOp ((/) :: Integer -> Integer -> Integer)),-              ("mod", multiOp (mod :: Integer -> Integer -> Integer)),-              ("quotient", multiOp (quot :: Integer -> Integer -> Integer)),-              ("remainder", multiOp (rem :: Integer -> Integer -> Integer)),--              ("+f", multiOp ((+) :: Double -> Double -> Double)),-              ("-f", multiOp ((-) :: Double -> Double -> Double)),-              ("*f", multiOp ((*) :: Double -> Double -> Double)),-              ("/f", multiOp ((/) :: Double -> Double -> Double)),--              ("round", singleOp (round :: Double -> Integer)),-              ("floor", singleOp (floor :: Double -> Integer)),-              ("ceiling", singleOp (ceiling :: Double -> Integer)),-              ("truncate", singleOp (truncate :: Double -> Integer)),--              ("exp", singleOp (exp :: Double -> Double)),-              ("log", singleOp (log :: Double -> Double)),--              ("sin", singleOp (sin :: Double -> Double)),-              ("cos", singleOp (cos :: Double -> Double)),-              ("tan", singleOp (tan :: Double -> Double)),-              ("asin", singleOp (asin :: Double -> Double)),-              ("acos", singleOp (acos :: Double -> Double)),-              ("atan", singleOp (atan :: Double -> Double)),-              ("sinh", singleOp (sinh :: Double -> Double)),-              ("cosh", singleOp (cosh :: Double -> Double)),-              ("tanh", singleOp (tanh :: Double -> Double)),-              ("asinh", singleOp (asinh :: Double -> Double)),-              ("acosh", singleOp (acosh :: Double -> Double)),-              ("atanh", singleOp (atanh :: Double -> Double)),--              ("sqrt", singleOp (sqrt :: Double -> Double)),-              ("expt", binaryOp ((^) :: Double -> Integer -> Double)),--              ("eq?", eqv),-              -              ("eq-n?", binaryOp ((==) :: Integer -> Integer -> Bool)),-              ("lt-n?", binaryOp ((<) :: Integer -> Integer -> Bool)),-              ("lte-n?", binaryOp ((<=) :: Integer -> Integer -> Bool)),-              ("gt-n?", binaryOp ((>) :: Integer -> Integer -> Bool)),-              ("gte-n?", binaryOp ((>=) :: Integer -> Integer -> Bool)),--              ("eq-f?", binaryOp ((==) :: Double -> Double -> Bool)),-              ("lt-f?", binaryOp ((<) :: Double -> Double -> Bool)),-              ("lte-f?", binaryOp ((<=) :: Double -> Double -> Bool)),-              ("gt-f?", binaryOp ((>) :: Double -> Double -> Bool)),-              ("gte-f?", binaryOp ((>=) :: Double -> Double -> Bool)),--              ("eq-c?", binaryOp ((==) :: Char -> Char -> Bool)),-              ("eq-s?", binaryOp ((==) :: String -> String -> Bool)),--              ("string-append", multiOp ((++) :: String -> String -> String)),-              -              ("string-to-chars", stringToChars),-              ("chars-to-string", charsToString),--              ("array-dimension", arrayDimension),-              ("array-range", arrayRange),-              ("array-size", arraySize),-              ("array-keys", arrayKeys),--              ("array-range?", arrayIsRange),--              ("array-ref", arrayRef),---              ("array-sub-ref", arrayRef),-              ---              ("array-to-collection", arrayToCollection),---              ("collection-to-array", collectionToArray),--              ("eof?", isEgisonEOF)--              ]++import Control.Arrow+import Control.Applicative+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Trans.Maybe++import Data.IORef+import Data.List+import Data.Maybe++import Text.Parsec.ByteString.Lazy (parseFromFile)+import System.Directory (doesFileExist)++import Language.Egison.Types+import Language.Egison.Parser+import Language.Egison.Desugar+import Paths_egison (getDataFileName)++--+-- Evaluator+--++evalTopExprs :: Env -> [EgisonTopExpr] -> EgisonM Env+evalTopExprs env exprs = do+  let (bindings, rest) = foldr collectDefs ([], []) exprs+  env <- recursiveBind env bindings+  forM_ rest $ evalTopExpr env+  return env+ where+  collectDefs (Define name expr) (bindings, rest) = ((name, expr) : bindings, rest)+  collectDefs expr (bindings, rest) = (bindings, expr : rest)  ++evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env+evalTopExpr env (Define name expr) = recursiveBind env [(name, expr)]+evalTopExpr env (Test expr) = do+  val <- evalExpr' env expr+  liftIO $ print val+  return env+evalTopExpr env (Execute argv) = do+  main <- refVar env ("main", []) >>= evalRef+  argv <- newEvaluatedThunk . Value . Collection $ map String argv+  world <- newEvaluatedThunk $ Value World+  applyFunc main [argv] >>= flip applyFunc [world]+  return env+evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env+evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env++loadFile :: FilePath -> EgisonM [EgisonTopExpr]+loadFile file = do+  doesExist <- liftIO $ doesFileExist file+  unless doesExist $ throwError $ strMsg ("file does not exist: " ++ file)+  input <- liftIO $ readFile file+  exprs <- liftError $ readTopExprs input+  concat <$> mapM recursiveLoad exprs+ where+  recursiveLoad (Load file) = loadFile file+  recursiveLoad (LoadFile file) = loadLibraryFile file+  recursiveLoad expr = return [expr]++loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile++evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData+evalExpr _ (CharExpr c) = return . Value $ Char c+evalExpr _ (StringExpr s) = return . Value $ String s +evalExpr _ (BoolExpr b) = return . Value $ Bool b+evalExpr _ (IntegerExpr i) = return . Value $ Integer i+evalExpr _ (FloatExpr d) = return . Value $ Float d++evalExpr env (VarExpr name nums) = do+  var <- (,) name <$> mapM (evalExpr env >=> liftError . fromIntegerValue) nums+  refVar env var >>= evalRef++evalExpr env (InductiveDataExpr name []) = return . Value $ InductiveData name []+evalExpr env (InductiveDataExpr name exprs) =+  Intermediate . IInductiveData name <$> mapM (newThunk env) exprs ++evalExpr _ (TupleExpr []) = return . Value $ Tuple []+evalExpr env (TupleExpr [expr]) = evalExpr env expr+evalExpr env (TupleExpr exprs) =+  Intermediate . ITuple <$> mapM (newThunk env) exprs ++evalExpr env (CollectionExpr []) = return . Value $ Collection []+evalExpr env (CollectionExpr inners) =+  Intermediate . ICollection <$> mapM fromInnerExpr inners+ where+  fromInnerExpr (ElementExpr expr) = IElement <$> newThunk env expr+  fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newThunk env expr++evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr ++evalExpr env (IfExpr test expr expr') = do+  test <- evalExpr env test >>= liftError . fromBoolValue+  evalExpr env $ if test then expr else expr'++evalExpr env (LetExpr bindings expr) =+  mapM extractBindings bindings >>= flip evalExpr expr . extendEnv env . concat+ where+  extractBindings :: BindingExpr -> EgisonM [Binding]+  extractBindings ([name], expr) =+    makeBindings [name] . (:[]) <$> newThunk env expr+  extractBindings (names, expr) =+    makeBindings names <$> (evalExpr env expr >>= fromTuple)++evalExpr env (LetRecExpr bindings expr) =+  let bindings' = evalState (concat <$> mapM extractBindings bindings) 0+  in recursiveBind env bindings' >>= flip evalExpr expr + where+  extractBindings :: BindingExpr -> State Int [(String, EgisonExpr)]+  extractBindings ([name], expr) = return [(name, expr)]+  extractBindings (names, expr) = do+    var <- genVar+    let k = length names+        target = VarExpr var []+        matcher = TupleExpr $ replicate k SomethingExpr+        nth n =+          let pattern = TupleExpr $ flip map [1..k] $ \i ->+                if i == n+                  then PatternExpr $ PatVar "#_" []+                  else PatternExpr WildCard+          in MatchExpr target matcher [(pattern, VarExpr "#_" [])]+    return ((var, expr) : map (second nth) (zip names [1..]))++  genVar :: State Int String+  genVar = modify (1+) >> gets (('#':) . show)++evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do+  target <- newThunk env target+  matcher <- evalExpr env matcher+  result <- patternMatch env pattern target matcher+  mmap (flip evalExpr expr . extendEnv env) result >>= fromMList+ where+  fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData+  fromMList MNil = return . Value $ Collection []+  fromMList (MCons val m) = do+    head <- IElement <$> newEvaluatedThunk val+    tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)+    return . Intermediate $ ICollection [head, tail]++evalExpr env (MatchExpr target matcher clauses) = do+  target <- newThunk env target+  matcher <- evalExpr env matcher+  let tryMatchClause (pattern, expr) cont = do+        result <- patternMatch env pattern target matcher+        case result of+          MCons bindings _ -> evalExpr (extendEnv env bindings) expr+          MNil -> cont+  foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses++evalExpr env (FunctionExpr matcher clauses) =+  return . Value $ Func env ["#_"] (MatchExpr (VarExpr "#_" []) matcher clauses)++evalExpr env (ApplyExpr func args) = do+  func <- evalExpr env func+  args <- evalExpr env args >>= fromTuple +  applyFunc func args++evalExpr env (MatcherExpr info) = return $ Value $ Matcher (env, info)++evalExpr _ (PatternExpr pattern) = return $ Value $ Pattern pattern++evalExpr _ SomethingExpr = return $ Value Something+evalExpr _ UndefinedExpr = throwError $ strMsg "undefined"+evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr)++evalExpr' :: Env -> EgisonExpr -> EgisonM EgisonValue+evalExpr' env expr = evalExpr env expr >>= evalDeep++evalRef :: ObjectRef -> EgisonM WHNFData+evalRef ref = do+  obj <- liftIO $ readIORef ref+  case obj of+    WHNF val -> return val+    Thunk thunk -> do+      val <- thunk+      writeThunk ref val+      return val++evalRef' :: ObjectRef -> EgisonM EgisonValue+evalRef' ref = do+  obj <- liftIO $ readIORef ref+  case obj of+    WHNF (Value val) -> return val+    WHNF val -> do+      val <- evalDeep val+      writeThunk ref $ Value val+      return val+    Thunk thunk -> do+      val <- thunk >>= evalDeep+      writeThunk ref $ Value val+      return val++evalDeep :: WHNFData -> EgisonM EgisonValue+evalDeep (Value val) = return val+evalDeep (Intermediate (IInductiveData name refs)) =+  InductiveData name <$> mapM evalRef' refs+evalDeep (Intermediate (ITuple refs)) = Tuple <$> mapM evalRef' refs+evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef')++applyFunc :: WHNFData -> [ObjectRef] -> EgisonM WHNFData+applyFunc (Value (Func env names body)) args+  | length names == length args =+    let env' = extendEnv env $ makeBindings names args+    in evalExpr env' body+  | otherwise = throwError $ ArgumentsNum (length names) (length args)+applyFunc (Value (PrimitiveFunc func)) args =+  mapM evalRef args >>= liftM Value . liftError . func+applyFunc (Value (IOFunc func)) args =+  mapM evalRef args >>= liftM Value . func+applyFunc val _ = throwError $ TypeMismatch "function" val++newThunk :: Env -> EgisonExpr -> EgisonM ObjectRef+newThunk env expr = liftIO . newIORef . Thunk $ evalExpr env expr++writeThunk :: ObjectRef -> WHNFData -> EgisonM ()+writeThunk ref val = liftIO . writeIORef ref $ WHNF val++newEvaluatedThunk :: WHNFData -> EgisonM ObjectRef+newEvaluatedThunk = liftIO . newIORef . WHNF++makeBindings :: [String] -> [ObjectRef] -> [Binding]+makeBindings = zip . map (flip (,) [])++recursiveBind :: Env -> [(String, EgisonExpr)] -> EgisonM Env+recursiveBind env bindings = do+  let (names, exprs) = unzip bindings+  refs <- replicateM (length bindings) $ newThunk nullEnv UndefinedExpr+  let env' = extendEnv env $ makeBindings names refs+  zipWithM_ (\ref expr -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) refs exprs+  return env'++fromTuple :: WHNFData -> EgisonM [ObjectRef]+fromTuple (Intermediate (ITuple refs)) = return refs+fromTuple (Value (Tuple vals)) = mapM (newEvaluatedThunk . Value) vals+fromTuple val = return <$> newEvaluatedThunk val++fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef)+fromCollection (Value (Collection [])) = return MNil+fromCollection (Value (Collection vals)) =+  fromList <$> mapM (newEvaluatedThunk . Value) vals+fromCollection coll@(Intermediate (ICollection _)) =+  newEvaluatedThunk coll >>= fromCollection'+ where+  fromCollection' ref = do+    isEmpty <- isEmptyCollection ref+    if isEmpty+      then return MNil+      else do+        (head, tail) <- fromJust <$> runMaybeT (unconsCollection ref)+        return $ MCons head (fromCollection' tail)+fromCollection val = throwError $ TypeMismatch "collection" val++--+-- Pattern Match+--++patternMatch :: Env -> EgisonExpr -> ObjectRef -> WHNFData ->+                EgisonM (MList EgisonM [Binding]) +patternMatch env pattern target matcher =+  processMState (MState env [] [MAtom pattern target matcher]) >>= processMStates . (:[])++processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM [Binding])+processMStates [] = return MNil+processMStates streams = do+  let (bindings, streams') = (catMaybes *** concat) . unzip $ map processMStates' streams+  mappend (fromList bindings) (sequence streams' >>= processMStates)+ where+  processMStates' :: MList EgisonM MatchingState ->+                     (Maybe [Binding], [EgisonM (MList EgisonM MatchingState)])+  processMStates' MNil = (Nothing, [])+  processMStates' (MCons (MState _ bindings []) states) = (Just bindings, [states])+  processMStates' (MCons state states) = (Nothing, [processMState state, states])++processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState)+processMState state@(MState env bindings []) = throwError $ strMsg "should not reach here"+processMState (MState env bindings ((MAtom pattern target matcher):trees)) = do+  let env' = extendEnv env bindings+  pattern <- evalPattern env' pattern+  case pattern of+    VarExpr _ _ -> throwError $ strMsg "cannot use variable in pattern"+    ApplyExpr func (TupleExpr args) -> do+      func <- evalExpr env' func+      case func of+        Value (Func env names expr) -> do+          penv <- zip (map (flip (,) []) names) <$> mapM (evalPattern env') args+          return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees)+        _ -> throwError $ TypeMismatch "pattern constructor" func+    TupleExpr patterns -> do+      matchers <- fromTuple matcher >>= mapM evalRef+      targets <- evalRef target >>= fromTuple+      let trees' = zipWith3 MAtom patterns targets matchers ++ trees+      return $ msingleton $ MState env bindings trees'+    PatternExpr WildCard -> return $ msingleton $ MState env bindings trees +    PatternExpr (AndPat patterns) ->+      let trees' = map (\pattern -> MAtom pattern target matcher) patterns ++ trees+      in return $ msingleton $ MState env bindings trees'+    PatternExpr (OrPat patterns) ->+      return $ fromList $ flip map patterns $ \pattern ->+        MState env bindings (MAtom pattern target matcher : trees)+    PatternExpr (NotPat pattern) -> do +      results <- processMState (MState env bindings [MAtom pattern target matcher])+      case results of+        MNil -> return $ msingleton $ MState env bindings trees+        _    -> return $ MNil+    PatternExpr (CutPat pattern) -> -- TEMPORARY ignoring cut patterns+      return $ msingleton (MState env bindings ((MAtom pattern target matcher):trees))+    PatternExpr (PredPat pred) -> do+      result <- evalExpr env' pred >>= flip applyFunc [target] >>= liftError . fromBoolValue+      if result then return $ msingleton $ (MState env bindings trees)+                else return MNil+    PatternExpr pattern' ->+      case matcher of+        Value Something -> +          case pattern' of+            PatVar name nums -> do+              var <- (,) name <$> mapM (evalExpr env' >=> liftError . fromIntegerValue) nums+              return $ msingleton $ MState env ((var, target):bindings) trees+            _ -> throwError $ strMsg "something can only match with a pattern variable"+        Value (Matcher matcher) -> do+          (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher+          mfor targetss $ \ref -> do+            targets <- evalRef ref >>= fromTuple+            let trees' = zipWith3 MAtom patterns targets matchers ++ trees+            return $ MState env bindings trees'+        _ -> throwError $ TypeMismatch "matcher" matcher+processMState (MState env bindings ((MNode penv (MState _ _ [])):trees)) =+  return $ msingleton $ MState env bindings trees+processMState (MState env bindings ((MNode penv state@(MState env' bindings' (tree:trees')):trees))) = do+  case tree of+    MAtom pattern target matcher -> do+      pattern <- evalPattern env' pattern+      case pattern of+        VarExpr name nums -> do+          var <- (,) name <$> mapM (evalExpr env' >=> liftError . fromIntegerValue) nums+          case lookup var penv of+            Just pattern -> do+              return $ msingleton $ MState env bindings (MAtom pattern target matcher:MNode penv (MState env' bindings' trees'):trees)+            Nothing -> throwError $ UnboundVariable var+        _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv)+    _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv)++evalPattern :: Env -> EgisonExpr -> EgisonM EgisonExpr+evalPattern _ expr@(TupleExpr _) = return expr+evalPattern _ expr@(PatternExpr _) = return expr+evalPattern _ expr@(VarExpr _ _) = return expr+evalPattern _ expr@(ApplyExpr _ _) = return expr+evalPattern env (IfExpr test expr expr') = do+  test <- evalExpr env test >>= liftError . fromBoolValue+  evalPattern env $ if test then expr else expr'  +evalPattern env (LetExpr _ _) = undefined+evalPattern env (LetRecExpr _ _) = undefined+evalPattern _ _ = throwError $ strMsg "pattern expression required"++inductiveMatch :: Env -> EgisonExpr -> ObjectRef -> Matcher ->+                  EgisonM ([EgisonExpr], MList EgisonM ObjectRef, [WHNFData])+inductiveMatch env pattern target (matcherEnv, clauses) = do+  foldr tryPPMatchClause failPPPatternMatch clauses+ where+  tryPPMatchClause (pat, matchers, clauses) cont = do+    result <- runMaybeT $ primitivePatPatternMatch env pat pattern+    case result of+      Just (patterns, bindings) -> do+        targetss <- foldr tryPDMatchClause failPDPatternMatch clauses+        matchers <- evalExpr matcherEnv matchers >>= fromTuple >>= mapM evalRef+        return (patterns, targetss, matchers)+       where+        tryPDMatchClause (pat, expr) cont = do+          result <- runMaybeT $ primitiveDataPatternMatch pat target+          case result of+            Just bindings' -> do+              let env = extendEnv matcherEnv $ bindings ++ bindings'+              evalExpr env expr >>= fromCollection+            _ -> cont+      _ -> cont+  failPPPatternMatch = throwError $ strMsg "failed primitive pattern pattern match"+  failPDPatternMatch = throwError $ strMsg "failed primitive data pattern match"++primitivePatPatternMatch :: Env -> PrimitivePatPattern -> EgisonExpr ->+                            MatchM ([EgisonExpr], [Binding])+primitivePatPatternMatch _ PPWildCard _ = return ([], [])+primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], [])+primitivePatPatternMatch env (PPValuePat name) pattern = do+  pattern <- lift $ evalExpr env pattern+  case pattern of+    Value (Pattern (ValuePat expr)) -> do+      ref <- lift $ newThunk env expr+      return ([], [((name, []), ref)])+    _ -> matchFail+primitivePatPatternMatch env (PPInductivePat name patterns) pattern = do+  pattern <- lift $ evalExpr env pattern+  case pattern of+    Value (Pattern (InductivePattern name' exprs)) | name == name' ->+      (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs+    _ -> matchFail++primitiveDataPatternMatch :: PrimitiveDataPattern -> ObjectRef -> MatchM [Binding]+primitiveDataPatternMatch PDWildCard _ = return []+primitiveDataPatternMatch (PDPatVar name) ref = return [((name, []), ref)]+primitiveDataPatternMatch (PDInductivePat name patterns) ref = do+  val <- lift $ evalRef ref+  case val of+    Intermediate (IInductiveData name' refs) | name == name' ->+      concat <$> zipWithM primitiveDataPatternMatch patterns refs+    Value (InductiveData name' vals) | name == name' -> do+      refs <- lift $ mapM (newEvaluatedThunk . Value) vals+      concat <$> zipWithM primitiveDataPatternMatch patterns refs+    _ -> matchFail+primitiveDataPatternMatch PDEmptyPat ref = do+  isEmpty <- lift $ isEmptyCollection ref+  if isEmpty then return [] else matchFail+primitiveDataPatternMatch (PDConsPat pattern pattern') ref = do+  (head, tail) <- unconsCollection ref+  (++) <$> primitiveDataPatternMatch pattern head+       <*> primitiveDataPatternMatch pattern' tail+primitiveDataPatternMatch (PDSnocPat pattern pattern') ref = do+  (init, last) <- unsnocCollection ref+  (++) <$> primitiveDataPatternMatch pattern init+       <*> primitiveDataPatternMatch pattern' last+primitiveDataPatternMatch (PDConstantPat expr) ref = do+  target <- lift (evalRef ref) >>= either (const matchFail) return . fromPrimitiveValue+  isEqual <- lift $ (==) <$> evalExpr' nullEnv expr <*> pure target+  if isEqual then return [] else matchFail++expandCollection :: WHNFData -> EgisonM [Inner]+expandCollection (Value (Collection vals)) =+  mapM (liftM IElement . newEvaluatedThunk . Value) vals+expandCollection (Intermediate (ICollection inners)) = return inners+expandCollection val = throwError $ TypeMismatch "collection" val++isEmptyCollection :: ObjectRef -> EgisonM Bool+isEmptyCollection ref = evalRef ref >>= isEmptyCollection'+ where+  isEmptyCollection' :: WHNFData -> EgisonM Bool+  isEmptyCollection' (Value (Collection [])) = return True+  isEmptyCollection' (Intermediate (ICollection [])) = return True+  isEmptyCollection' (Intermediate (ICollection ((ISubCollection ref'):inners))) = do+    inners' <- evalRef ref' >>= expandCollection+    let coll = Intermediate (ICollection (inners' ++ inners))+    writeThunk ref coll+    isEmptyCollection' coll+  isEmptyCollection' _ = return False++unconsCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef)+unconsCollection ref = lift (evalRef ref) >>= unconsCollection'+ where+  unconsCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef)+  unconsCollection' (Value (Collection (val:vals))) =+    lift $ (,) <$> newEvaluatedThunk (Value val)+               <*> newEvaluatedThunk (Value $ Collection vals)+  unconsCollection' (Intermediate (ICollection ((IElement ref):inners))) =+    lift $ (,) ref <$> newEvaluatedThunk (Intermediate $ ICollection inners)+  unconsCollection' (Intermediate (ICollection ((ISubCollection ref'):inners))) = do+    inners' <- lift $ evalRef ref' >>= expandCollection+    let coll = Intermediate (ICollection (inners' ++ inners))+    lift $ writeThunk ref coll+    unconsCollection' coll+  unconsCollection' _ = matchFail+  +unsnocCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef)+unsnocCollection ref = lift (evalRef ref) >>= unsnocCollection'+  where+    unsnocCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef)+    unsnocCollection' (Value (Collection [])) = matchFail+    unsnocCollection' (Value (Collection vals)) =+      lift $ (,) <$> newEvaluatedThunk (Value . Collection $ init vals)+                 <*> newEvaluatedThunk (Value $ last vals)+    unsnocCollection' (Intermediate (ICollection [])) = matchFail+    unsnocCollection' (Intermediate (ICollection inners)) =+      case last inners of+        IElement ref ->+          lift $ (,) <$> newEvaluatedThunk (Intermediate . ICollection $ init inners)+                     <*> pure ref+        ISubCollection ref -> do+          inners' <- lift $ evalRef ref >>= expandCollection+          let coll = Intermediate (ICollection (init inners ++ inners'))+          lift $ writeThunk ref coll+          unsnocCollection' coll

@@ -0,0 +1,203 @@+{-# Language FlexibleInstances, GeneralizedNewtypeDeriving #-}+module Language.Egison.Desugar where+import Control.Applicative (Applicative)+import Control.Applicative ((<$>), (<*>), (<*), (*>), pure)+import Data.Char (toUpper)+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Identity+import Language.Egison.Types++newtype DesugarM a = DesugarM { unDesugarM :: StateT Int (ErrorT EgisonError Identity) a }+  deriving (Functor, Applicative, Monad, MonadState Int, MonadError EgisonError)+           +class (Applicative m, Monad m) => MonadFresh m where+  fresh :: m String+           +instance MonadFresh DesugarM where+  fresh = do counter <- get; modify (+ 1) +             return $ genFreshName counter+    where+      genFreshName :: Int -> String+      genFreshName n = "$_" ++ show n++runDesugarM :: DesugarM a -> Either EgisonError a+runDesugarM d =runIdentity $ runErrorT $ flip evalStateT 0 $ unDesugarM d++desugar :: EgisonExpr -> DesugarM EgisonExpr+desugar (AlgebraicDataMatcher patterns) = do+  matcherName <- fresh+  matcherRef <- return $ VarExpr matcherName []+  matcher <- genMatcherClauses patterns matcherRef+  return $ LetRecExpr [([matcherName], matcher)] matcherRef+    where+      genMatcherClauses :: [EgisonExpr] ->  EgisonExpr -> DesugarM EgisonExpr+      genMatcherClauses patterns matcher = do+        main <- genMainClause patterns matcher+        body <- mapM genMatcherClause patterns+        footer <- genSomethingClause+        clauses <- return $ [main] ++ body ++ [footer]+        return $ MatcherExpr clauses+        +      genMainClause :: [EgisonExpr] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genMainClause patterns matcher = do+        clauses <- genClauses patterns+        return (PPValuePat "val", TupleExpr [],+                 [(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr "val" []), (VarExpr "tgt" [])]) +                                              (TupleExpr [matcher, matcher]) +                                              clauses))])+        where+          genClauses :: [EgisonExpr] -> DesugarM [MatchClause]+          genClauses patterns = (++) <$> mapM genClause patterns+                                     <*> pure [(PatternExpr WildCard, matchingFailure)]+          +          genClause :: EgisonExpr -> DesugarM MatchClause+          genClause pattern = do+            (pat0, pat1) <- genMatchingPattern pattern+            return (TupleExpr [pat0, pat1], matchingSuccess)+        +          genMatchingPattern :: EgisonExpr -> DesugarM (EgisonExpr, EgisonExpr)+          genMatchingPattern (PatternExpr (InductivePattern name patterns)) = do+            names <- mapM (const fresh) patterns+            return $ ((PatternExpr $ InductivePattern name (map (PatternExpr . flip PatVar []) names))  +                     ,(PatternExpr $ InductivePattern name (map (PatternExpr . ValuePat . (flip VarExpr [])) names)))+          +      genMatcherClause :: EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genMatcherClause pattern = do+        (ppat, matchers) <- genPrimitivePatPat pattern+        (dpat, body)     <- genPrimitiveDataPat pattern+        return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)])+        +        where+          genPrimitivePatPat :: EgisonExpr -> DesugarM (PrimitivePatPattern, [EgisonExpr])+          genPrimitivePatPat (PatternExpr (InductivePattern name matchers)) = do+            patterns' <- mapM (const $ return PPPatVar) matchers+            return (PPInductivePat name patterns', matchers)+          genPrimitivePatPat _ = throwError $ Desugar "invalid algebraic-data-matcher"+          +          genPrimitiveDataPat :: EgisonExpr -> DesugarM (PrimitiveDataPattern, [EgisonExpr])+          genPrimitiveDataPat (PatternExpr (InductivePattern name patterns)) = do+            patterns' <- mapM (const fresh) patterns +            return (PDInductivePat (capitalize name) $ map PDPatVar patterns', map (flip VarExpr []) patterns')+          genPrimitiveDataPatr _ = throwError $ Desugar "invalid algebraic-data-matcher"++          capitalize :: String -> String+          capitalize (x:xs) = toUpper x : xs+                                            +      +      genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genSomethingClause = +        return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr $ [ElementExpr (VarExpr "tgt" [])])])+    +      matchingSuccess :: EgisonExpr+      matchingSuccess = CollectionExpr $ [ElementExpr $ TupleExpr []]++      matchingFailure :: EgisonExpr+      matchingFailure = CollectionExpr []++desugar (FunctionExpr matcher clauses) = do+  name <- fresh+  matcher' <- desugar matcher+  clauses' <- desugarMatchClauses clauses+  desugar (LambdaExpr [name] (MatchExpr (VarExpr name []) matcher' clauses'))++desugar (VarExpr name exprs) = do+  exprs' <- mapM desugar exprs+  return $ VarExpr name exprs'++desugar (InductiveDataExpr name exprs) = do +  exprs' <- mapM desugar exprs+  return $ InductiveDataExpr name exprs'++desugar (TupleExpr exprs) = do+  exprs' <- mapM desugar exprs+  return $ TupleExpr exprs'++desugar (CollectionExpr ((ElementExpr expr):rest)) = do+  expr' <- desugar expr+  (CollectionExpr rest') <- desugar (CollectionExpr rest)+  return $ CollectionExpr ((ElementExpr expr'):rest')++desugar (CollectionExpr ((SubCollectionExpr expr):rest)) = do+  expr' <- desugar expr+  (CollectionExpr rest') <- desugar (CollectionExpr rest)+  return $ CollectionExpr ((SubCollectionExpr expr'):rest')++desugar expr@(CollectionExpr []) = return expr++desugar (LambdaExpr names expr) = do+  expr' <- desugar expr+  return $ LambdaExpr names expr'++desugar (IfExpr expr0 expr1 expr2) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  expr2' <- desugar expr2+  return $ IfExpr expr0' expr1' expr2'+  +desugar (LetExpr binds expr) = do+  binds' <- desugarBindings binds+  expr' <- desugar expr+  return $ LetExpr binds' expr'++desugar (LetRecExpr binds expr) = do+  binds' <- desugarBindings binds+  expr' <- desugar expr+  return $ LetRecExpr binds' expr'+  +desugar (LoopExpr s0 s1 expr0 expr1 expr2) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  expr2' <- desugar expr2+  return $ LoopExpr s0 s1 expr0' expr1' expr2'+  +desugar (MatchExpr expr0 expr1 clauses) = do  +  expr0' <- desugar expr0+  expr1' <- desugar expr1+  clauses' <- desugarMatchClauses clauses+  return (MatchExpr expr0' expr1' clauses')++desugar (MatchAllExpr expr0 expr1 clause) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  clause' <- desugarMatchClause clause+  return $ MatchAllExpr expr0' expr1' clause'+  +desugar (DoExpr binds expr) = do+  binds' <- desugarBindings binds+  expr' <- desugar expr+  return $ DoExpr binds' expr'+  +desugar (ApplyExpr expr0 expr1) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  return $ ApplyExpr expr0' expr1'+  +desugar expr = return expr++desugarBinding :: BindingExpr -> DesugarM BindingExpr+desugarBinding (name, expr) = do+  expr' <- desugar expr+  return $ (name, expr')++desugarBindings :: [BindingExpr] -> DesugarM [BindingExpr]+desugarBindings (bind:rest) = do+  bind' <- desugarBinding bind+  rest' <- desugarBindings rest+  return $ bind' : rest'+  +desugarBindings [] = return []++desugarMatchClause :: MatchClause -> DesugarM MatchClause+desugarMatchClause (expr0, expr1) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  return $ (expr0', expr1')++desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause]+desugarMatchClauses (clause:rest) = do+  clause' <- desugarMatchClause clause+  rest'   <- desugarMatchClauses rest+  return $ clause : rest'+  +desugarMatchClauses [] = return []

@@ -1,97 +0,0 @@-module Language.Egison.Macro where-import Language.Egison.Types-import Control.Monad.Error-import qualified Data.Map--type MacroFrame = Data.Map.Map String EgisonExpr--getExpr :: MacroFrame -> String -> Maybe EgisonExpr-getExpr frame name = Data.Map.lookup name frame--expandMacro :: MacroFrame -> EgisonExpr -> IOThrowsError EgisonExpr-expandMacro frame (VarExpr name []) =-  case getExpr frame name of-    Nothing -> return $ VarExpr name []-    Just expr -> return expr-expandMacro frame (PatVarOmitExpr name nums) = do-  case getExpr frame name of-    Nothing -> throwError $ Default $ "no macro var: " ++ name-    Just (MacroVarExpr name2) -> return $ PatVarExpr name2 nums-    expr -> throwError $ Default $ "not macro var: " ++ show expr-expandMacro frame (VarOmitExpr name nums) = do-  case getExpr frame name of-    Nothing -> throwError $ Default $ "no macro var: " ++ name-    Just (MacroVarExpr name2) -> return $ VarExpr name2 nums-    expr -> throwError $ Default $ "not macro var: " ++ show expr-expandMacro frame (InductiveDataExpr cons exprs) = do-  newExprs <- mapM (expandMacro frame) exprs-  return $ InductiveDataExpr cons newExprs-expandMacro frame (TupleExpr exprs) = do-  newExprs <- mapM (expandMacro frame) exprs-  return $ TupleExpr newExprs-expandMacro frame (CollectionExpr innerExprs) = do-  newInnerExprs <- mapM (expandMacroInnerExpr frame) innerExprs-  return $ CollectionExpr newInnerExprs-expandMacro frame (PredPatExpr predExpr argExprs) = do-  newPredExpr <- expandMacro frame predExpr-  newArgExprs <- mapM (expandMacro frame) argExprs-  return $ PredPatExpr newPredExpr newArgExprs-expandMacro frame (CutPatExpr patExpr) = do-  newPatExpr <- expandMacro frame patExpr-  return $ CutPatExpr newPatExpr-expandMacro frame (NotPatExpr patExpr) = do-  newPatExpr <- expandMacro frame patExpr-  return $ CutPatExpr newPatExpr-expandMacro frame (OrPatExpr patExprs) = do-  newPatExprs <- mapM (expandMacro frame) patExprs-  return $ OrPatExpr newPatExprs-expandMacro frame (AndPatExpr patExprs) = do-  newPatExprs <- mapM (expandMacro frame) patExprs-  return $ AndPatExpr newPatExprs-expandMacro frame (FuncExpr args body) = do-  newBody <- expandMacro frame body-  return $ FuncExpr args newBody-expandMacro frame (IfExpr condExpr expr1 expr2) = do-  newCondExpr <- expandMacro frame condExpr-  newExpr1 <- expandMacro frame expr1-  newExpr2 <- expandMacro frame expr2-  return $ IfExpr newCondExpr newExpr1 newExpr2-expandMacro frame (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr) = do-  newRangeExpr <- expandMacro frame rangeExpr-  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-  newTgtExpr <- expandMacro frame tgtExpr-  newTypExpr <- expandMacro frame typExpr-  newMcs <- mapM (expandMacroMatchClause frame) mcs-  return $ MatchExpr newTgtExpr newTypExpr newMcs-expandMacro frame (MatchAllExpr tgtExpr typExpr mc) = do-  newTgtExpr <- expandMacro frame tgtExpr-  newTypExpr <- expandMacro frame typExpr-  newMc <- expandMacroMatchClause frame mc-  return $ MatchAllExpr newTgtExpr newTypExpr newMc-expandMacro frame (ApplyExpr opExpr argExpr) = do-  newOpExpr <- expandMacro frame opExpr-  newArgExpr <- expandMacro frame argExpr-  return $ ApplyExpr newOpExpr newArgExpr-expandMacro _ expr = return expr--expandMacroMatchClause :: MacroFrame -> MatchClause -> IOThrowsError MatchClause-expandMacroMatchClause frame (patExpr, body) = do-  newPatExpr <- expandMacro frame patExpr-  newBody <- expandMacro frame body-  return (newPatExpr, newBody)--expandMacroInnerExpr :: MacroFrame -> InnerExpr -> IOThrowsError InnerExpr-expandMacroInnerExpr frame (ElementExpr expr) = do-  newExpr <- expandMacro frame expr-  return $ ElementExpr newExpr-expandMacroInnerExpr frame (SubCollectionExpr expr) = do-  newExpr <- expandMacro frame expr-  return $ SubCollectionExpr newExpr

@@ -1,70 +0,0 @@-module Language.Egison.Numerical where-import Language.Egison.Types-import Control.Applicative-import Control.Monad.Error-import Data.Array--singleOp :: (PrimitiveVal a, PrimitiveVal b) => (a -> b) -> [EgisonVal] -> ThrowsError EgisonVal-singleOp op [x] = toEgisonVal . op <$> fromEgisonVal x-singleOp _ params = throwError $ NumArgs 1 params--multiOp :: PrimitiveVal a => (a -> a -> a) -> [EgisonVal] -> ThrowsError EgisonVal-multiOp _ emptyList@[] = throwError $ NumArgs 2 emptyList-multiOp _ singleVal@[_] = throwError $ NumArgs 2 singleVal-multiOp op aparams = toEgisonVal . foldl1 op <$> mapM fromEgisonVal aparams--binaryOp :: (PrimitiveVal a, PrimitiveVal b, PrimitiveVal c) => (a -> b -> c) -> [EgisonVal] -> ThrowsError EgisonVal-binaryOp _ emptyList@[] = throwError $ NumArgs 2 emptyList-binaryOp _ singleVal@[_] = throwError $ NumArgs 2 singleVal-binaryOp op [a, b] = toEgisonVal <$> liftM2 op (fromEgisonVal a) (fromEgisonVal b)--isEgisonEOF :: [EgisonVal] -> ThrowsError EgisonVal-isEgisonEOF [EOF] = return $ Bool True-isEgisonEOF [_] = return $ Bool False-isEgisonEOF badArgList = throwError $ NumArgs 1 badArgList--stringToChars :: [EgisonVal] -> ThrowsError EgisonVal-stringToChars [(String str)] = return $ Collection $ map Char str-stringToChars [x] = throwError $ TypeMismatch "string" [x]-stringToChars badArgList = throwError $ NumArgs 1 badArgList--charsToString :: [EgisonVal] -> ThrowsError EgisonVal-charsToString [(Collection chars)] = String <$> mapM fromEgisonVal chars-charsToString [x] = throwError $ TypeMismatch "collection of chars" [x]-charsToString badArgList = throwError $ NumArgs 1 badArgList-------------------------------------------------------- Array------------------------------------------------------arrayDimension :: [EgisonVal] -> ThrowsError EgisonVal-arrayDimension [(Array d _ _)] = return $ Number d-arrayDimension [x] = throwError $ TypeMismatch "array" [x]-arrayDimension badArgList = throwError $ NumArgs 1 badArgList--arrayRange :: [EgisonVal] -> ThrowsError EgisonVal-arrayRange [(Array _ ns _)] = return $ Tuple $ map Number ns-arrayRange [x] = throwError $ TypeMismatch "array" [x]-arrayRange badArgList = throwError $ NumArgs 1 badArgList--arraySize :: [EgisonVal] -> ThrowsError EgisonVal-arraySize [(Number m), (Array _ ns _)] = return $ Number $ nth m ns-arraySize [x, y] = throwError $ TypeMismatch "number, array" [x, y]-arraySize badArgList = throwError $ NumArgs 2 badArgList--arrayKeys :: [EgisonVal] -> ThrowsError EgisonVal-arrayKeys [(Array _ ms _)] = return $ Collection $ map (Tuple . map Number) $ indexList ms-arrayKeys [x] = throwError $ TypeMismatch "array" [x]-arrayKeys badArgList = throwError $ NumArgs 1 badArgList--arrayIsRange :: [EgisonVal] -> ThrowsError EgisonVal-arrayIsRange [(Tuple key), (Array _ ms _)] = Bool . and . zipWith (\m n -> n > 0 && n <= m) ms <$> mapM fromEgisonVal key-arrayIsRange [x, y] = throwError $ TypeMismatch "key, array" [x, y]-arrayIsRange badArgList = throwError $ NumArgs 2 badArgList--arrayRef :: [EgisonVal] -> ThrowsError EgisonVal-arrayRef [(Tuple nums), (Array _ ms arr)] = do-  i <- integersToInteger ms <$> mapM fromEgisonVal nums-  return $ (arr ! i)-arrayRef [x, y] = throwError $ TypeMismatch "tuple of number, array" [x, y]-arrayRef badArgList = throwError $ NumArgs 2 badArgList

@@ -1,440 +1,480 @@-module Language.Egison.Parser where-import Language.Egison.Types+module Language.Egison.Parser +       ( readTopExprs+       , readTopExpr+       , readExprs+       , readExpr ) where++import Control.Monad.Identity import Control.Monad.Error-import qualified Data.Char as Char-import Numeric-import Text.ParserCombinators.Parsec hiding (spaces)-import Text.Parsec.Language+import Control.Monad.State+import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)++import Data.Either+import Data.Set (Set)+import Data.Char (isLower, isUpper)+import qualified Data.Set as Set++import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.Char8 ()+import qualified Data.ByteString.Lazy.Char8 as B+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import Text.Parsec.Combinator import qualified Text.Parsec.Token as P -egisonDef :: LanguageDef ()-egisonDef -  = emptyDef    -  { P.commentStart   = "#|"-  , P.commentEnd     = "|#"-  , P.commentLine    = ";"-  , P.nestedComments = True-  , P.identStart     = letter <|> symbol-  , P.identLetter    = letter <|> digit <|> symbol <|> symbol2-  , P.reservedNames  = []-  , P.caseSensitive  = True-  } +import Language.Egison.Types+import Language.Egison.Desugar+  +runParser' :: Parser a -> String -> Either EgisonError a+runParser' parser input = either (throwError . Parser) return $ parse parser "egison" (B.pack input)+  +readTopExprs :: String -> Either EgisonError [EgisonTopExpr]+readTopExprs input = either throwError (mapM desugarTopExpr) $ runParser' (whiteSpace >> parseTopExprs) input ---lexer :: P.GenTokenParser String () Identity-lexer = P.makeTokenParser egisonDef+readTopExpr :: String -> Either EgisonError EgisonTopExpr+readTopExpr input = either throwError desugarTopExpr $ runParser' (whiteSpace >> parseTopExpr) input ---dot :: ParsecT String () Identity String-dot = P.dot lexer+readExprs :: String -> Either EgisonError [EgisonExpr]+readExprs input = either throwError (mapM desugarExpr) $ runParser' (whiteSpace >> parseExprs) input ---parens :: ParsecT String () Identity a -> ParsecT String () Identity a-parens = P.parens lexer+readExpr :: String -> Either EgisonError EgisonExpr+readExpr input = either throwError desugarExpr $ runParser' (whiteSpace >> parseExpr) input -brackets = P.brackets lexer+desugarTopExpr :: EgisonTopExpr -> Either EgisonError EgisonTopExpr+desugarTopExpr (Define name expr) = do+  expr' <- desugarExpr expr+  return (Define name expr')+  +desugarTopExpr (Test expr) = do+  expr' <- desugarExpr expr+  return (Test expr') -braces = P.braces lexer+desugarTopExpr expr = return expr -angles = P.angles lexer+desugarExpr :: EgisonExpr -> Either EgisonError EgisonExpr+desugarExpr expr = either throwError return $ runDesugarM $ desugar expr ---identifier :: ParsecT String () Identity String-identifier = P.identifier lexer+-- Expressions --- TODO: typedef. starting point was: whiteSpace :: CharParser ()---whiteSpace :: ParsecT String () Identity ()-whiteSpace = P.whiteSpace lexer+parseTopExprs :: Parser [EgisonTopExpr]+parseTopExprs = endBy parseTopExpr whiteSpace ---lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a-lexeme = P.lexeme lexer+parseTopExpr :: Parser EgisonTopExpr+parseTopExpr = parens (parseDefineExpr+                       <|> parseTestExpr+                       <|> parseExecuteExpr+                       <|> parseLoadFileExpr+                       <|> parseLoadExpr+                       <?> "top-level expression") -symbol :: Parser Char---symbol = oneOf "!$%&|*+-/<=>?@^_~."-symbol = oneOf "&*+-/:="+parseDefineExpr :: Parser EgisonTopExpr+parseDefineExpr = keywordDefine >> Define <$> parseVarName <*> parseExpr -symbol2 :: Parser Char---symbol = oneOf "!$%&|*+-/<=>?@^_~."-symbol2 = oneOf "!?"+parseTestExpr :: Parser EgisonTopExpr+parseTestExpr = keywordTest >> Test <$> parseExpr -parseBool :: Parser EgisonExpr-parseBool = do _ <- string "#"-               x <- oneOf "tf"-               return $ case x of-                          't' -> BoolExpr True-                          'f' -> BoolExpr False-                          _ -> BoolExpr False+parseExecuteExpr :: Parser EgisonTopExpr+parseExecuteExpr = keywordExecute >> Execute <$> sepEndBy stringLiteral whiteSpace -parseBool2 :: Parser Bool-parseBool2 = do-  boolExpr <- parseBool-  case boolExpr of-    BoolExpr True -> return True-    BoolExpr False -> return False-                          -parseChar :: Parser EgisonExpr-parseChar = do-  _ <- char '\''-  x <- parseEscapedChar <|> noneOf ("'")-  _ <- char '\''-  return $ CharExpr x+parseLoadFileExpr :: Parser EgisonTopExpr+parseLoadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral++parseLoadExpr :: Parser EgisonTopExpr+parseLoadExpr = keywordLoad >> Load <$> stringLiteral++parseExprs :: Parser [EgisonExpr]+parseExprs = endBy parseExpr whiteSpace++parseExpr :: Parser EgisonExpr+parseExpr = (try parseConstantExpr+             <|> try parseVarExpr+--           <|> parseOmitExpr+             <|> try parsePatVarExpr+--           <|> parsePatVarOmitExpr+                       +             <|> parseWildCardExpr+             <|> parseCutPatExpr+             <|> parseNotPatExpr+             <|> parseValuePatExpr+             <|> parsePredPatExpr +                        +             <|> try parseInductiveDataExpr+             <|> parseInductivePatternExpr+             <|> parseTupleExpr+             <|> parseCollectionExpr+             <|> parens (parseAndPatExpr +                         <|> parseOrPatExpr+                         <|> parseIfExpr+                         <|> parseLambdaExpr+                         <|> parseFunctionExpr+                         <|> parseLetRecExpr+                         <|> parseLetExpr+                         <|> parseLoopExpr+                         <|> parseDoExpr+                         <|> parseMatchAllExpr+                         <|> parseMatchExpr+                         <|> parseMatcherExpr+                         <|> parseApplyExpr+                         <|> parseAlgebraicDataMatcherExpr)+                         <?> "expression")++parseVarExpr :: Parser EgisonExpr+parseVarExpr = VarExpr <$> ident <*> parseIndexNums++parseIndexNums :: Parser [EgisonExpr]+parseIndexNums = ((:) <$> try (prefix >> parseExpr) <*> parseIndexNums)+              <|> pure []+  where+    prefix :: Parser Char+    prefix = do result <- char '_' >> isConsumed whiteSpace+                if result then parserFail "unexpected whiteSpace"+                          else return '_'     -parseChar2 :: Parser Char-parseChar2 = do chrExpr <- parseChar-                case chrExpr of-                  CharExpr chr -> return chr+    isConsumed :: Parser a -> Parser Bool+    isConsumed p = (/=) <$> getPosition <*> (p >> getPosition) -parseDecimalNumber :: Parser EgisonExpr-parseDecimalNumber = do-  sign <- many (oneOf "-")-  num <- many1 (digit)-  if (length sign) > 1-     then pzero-     else return $ (NumberExpr . read) $ sign ++ num+parseInductiveDataExpr :: Parser EgisonExpr+parseInductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy parseExpr whiteSpace -parseNumber :: Parser EgisonExpr-parseNumber = parseDecimalNumber+parseInductivePatternExpr :: Parser EgisonExpr+parseInductivePatternExpr = angles $ (PatternExpr .) . InductivePattern <$> lowerName <*> sepEndBy parseExpr whiteSpace -parseNumber2 :: Parser Integer-parseNumber2 = do numExpr <- parseNumber-                  case numExpr of-                    NumberExpr n -> return n-              -parseEscapedChar :: GenParser Char st Char-parseEscapedChar = do-  _ <- char '\\'-  c <- anyChar-  return $ case c of-    'n' -> '\n'-    't' -> '\t'-    'r' -> '\r'-    _ -> c+parseTupleExpr :: Parser EgisonExpr+parseTupleExpr = brackets $ TupleExpr <$> sepEndBy parseExpr whiteSpace -parseString2 :: Parser String-parseString2 = do-  _ <- char '"'-  x <- many (parseEscapedChar <|> noneOf ("\""))-  _ <- char '"'-  return $ x+parseCollectionExpr :: Parser EgisonExpr+parseCollectionExpr = braces $ CollectionExpr <$> sepEndBy parseInnerExpr whiteSpace+ where+  parseInnerExpr :: Parser InnerExpr+  parseInnerExpr = (char '@' >> SubCollectionExpr <$> parseExpr)+               <|> ElementExpr <$> parseExpr -parseString :: Parser EgisonExpr-parseString = do-  x <- parseString2-  return $ StringExpr x+parseMatchAllExpr :: Parser EgisonExpr+parseMatchAllExpr = keywordMatchAll >> MatchAllExpr <$> parseExpr <*> parseExpr <*> parseMatchClause -parseIndexNums :: Parser [EgisonExpr]-parseIndexNums = do try (do char '_'-                            n <- parseExpr-                            ns <- parseIndexNums-                            return (n:ns))-             <|> do return []+parseMatchExpr :: Parser EgisonExpr+parseMatchExpr = keywordMatch >> MatchExpr <$> parseExpr <*> parseExpr <*> parseMatchClauses -parseInnerExp :: Parser InnerExpr-parseInnerExp =  do v <- lexeme parseExpr-                    return $ ElementExpr v-             <|> do char '@'-                    v <- lexeme parseExpr-                    return $ SubCollectionExpr v+parseFunctionExpr :: Parser EgisonExpr+parseFunctionExpr = keywordFunction >> FunctionExpr <$> parseExpr <*> parseMatchClauses -parsePatVar2 :: Parser VarExpr-parsePatVar2 = do char '$'-                  name <- identifier-                  nums <- parseIndexNums-                  return (name, nums)+parseMatchClauses :: Parser [MatchClause]+parseMatchClauses = braces $ sepEndBy parseMatchClause whiteSpace -parsePatVar :: Parser EgisonExpr-parsePatVar = do (name, nums) <- parsePatVar2-                 return $ PatVarExpr name nums-                    -parseMacroVarExpr :: Parser EgisonExpr-parseMacroVarExpr = do-  char '%'-  name <- identifier-  return $ MacroVarExpr name+parseMatchClause :: Parser MatchClause+parseMatchClause = brackets $ (,) <$> parseExpr <*> parseExpr -parsePatVarOmitExpr :: Parser EgisonExpr-parsePatVarOmitExpr = do-  string "$`"-  name <- identifier-  nums <- lexeme parseIndexNums-  return $ PatVarOmitExpr name nums+parseMatcherExpr :: Parser EgisonExpr+parseMatcherExpr = keywordMatcher >> MatcherExpr <$> parsePPMatchClauses -parseVarOmitExpr :: Parser EgisonExpr-parseVarOmitExpr = do-  char '`'-  name <- identifier-  nums <- lexeme parseIndexNums-  return $ VarOmitExpr name nums+parsePPMatchClauses :: Parser MatcherInfo+parsePPMatchClauses = braces $ sepEndBy parsePPMatchClause whiteSpace -parseArgs :: Parser ArgsExpr-parseArgs = do-      try (do (name, _) <- lexeme parsePatVar2-              return $ AVar name)-  <|> try (lexeme (brackets (do args <- sepEndBy parseArgs whiteSpace-                                return $ ATuple args)))-                    -parseBindings :: Parser Bindings-parseBindings = do-  braces (do sepEndBy (brackets (do args <- lexeme parseExpr-                                    expr <- lexeme parseExpr-                                    return (args, expr)))-                      whiteSpace)+parsePPMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+parsePPMatchClause = brackets $ (,,) <$> parsePPPattern <*> parseExpr <*> parsePDMatchClauses -parseRecursiveBindings :: Parser RecursiveBindings-parseRecursiveBindings = do-  braces (do sepEndBy (brackets (do char '$'-                                    name <- lexeme identifier-                                    expr <- lexeme parseExpr-                                    return (name, expr)))-                      whiteSpace)+parsePDMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]+parsePDMatchClauses = braces $ sepEndBy parsePDMatchClause whiteSpace -parseVar :: Parser EgisonExpr-parseVar = do name <- identifier-              nums <- lexeme parseIndexNums-              return $ VarExpr name nums+parsePDMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)+parsePDMatchClause = brackets $ (,) <$> parsePDPattern <*> parseExpr -parseWildCard :: Parser EgisonExpr-parseWildCard = do char '_'-                   return WildCardExpr+parsePPPattern :: Parser PrimitivePatPattern+parsePPPattern = parsePPWildCard+                 <|> parsePPPatVar+                 <|> parsePPValuePat+                 <|> parsePPInductivePat+                 <?> "primitive-pattren-pattern"+                       +parsePPWildCard :: Parser PrimitivePatPattern+parsePPWildCard = reservedOp "_" *> pure PPWildCard -parseCutPat :: Parser EgisonExpr-parseCutPat = do char '!'-                 expr <- parseExpr-                 return $ CutPatExpr expr+parsePPPatVar :: Parser PrimitivePatPattern+parsePPPatVar = reservedOp "$" *> pure PPPatVar -parseNotPat :: Parser EgisonExpr-parseNotPat = do char '^'-                 expr <- parseExpr-                 return $ NotPatExpr expr+parsePPValuePat :: Parser PrimitivePatPattern+parsePPValuePat = string ",$" >> PPValuePat <$> ident -parseValuePat :: Parser EgisonExpr-parseValuePat = do char ','-                   expr <- parseExpr-                   return $ ValuePatExpr expr+parsePPInductivePat :: Parser PrimitivePatPattern+parsePPInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy parsePPPattern whiteSpace) -parseInnerExpr :: Parser InnerExpr-parseInnerExpr = do expr <- parseExpr-                    return $ ElementExpr expr-             <|> do char '@'-                    expr <- parseExpr-                    return $ SubCollectionExpr expr+parsePDPattern :: Parser PrimitiveDataPattern+parsePDPattern = reservedOp "_" *> pure PDWildCard+                    <|> (char '$' >> PDPatVar <$> ident)+                    <|> braces ((PDConsPat <$> parsePDPattern <*> (char '@' *> parsePDPattern))+                            <|> (PDSnocPat <$> (char '@' *> parsePDPattern) <*> parsePDPattern) +                            <|> pure PDEmptyPat)+                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy parsePDPattern whiteSpace)+                    <|> PDConstantPat <$> parseConstantExpr+                    <?> "primitive-data-pattern" -parsePattern :: Parser EgisonExpr-parsePattern =-      parseWildCard-  <|> parsePatVar-  <|> parseCutPat-  <|> parseNotPat-  <|> parseValuePat-  <|> parens (do try (char '?' >> many1 space)-                 predExpr <- lexeme parseExpr-                 argExprs <- sepEndBy parseExpr whiteSpace-                 return (PredPatExpr predExpr argExprs)-          <|> do try (char '|' >> many1 space)-                 pats <- sepEndBy parseExpr whiteSpace-                 return (OrPatExpr pats)-          <|> do try (char '&' >> many1 space)-                 pats <- sepEndBy parseExpr whiteSpace-                 return (AndPatExpr pats))+parseIfExpr :: Parser EgisonExpr+parseIfExpr = keywordIf >> IfExpr <$> parseExpr <*> parseExpr <*> parseExpr +parseLambdaExpr :: Parser EgisonExpr+parseLambdaExpr = (keywordLambda <|> keywordPatternConstructor) >> LambdaExpr <$> parseVarNames <*> parseExpr -parseDestructInfoExpr :: Parser DestructInfoExpr-parseDestructInfoExpr = braces (sepEndBy parseDestructClause whiteSpace)+parseLetRecExpr :: Parser EgisonExpr+parseLetRecExpr =  keywordLetRec >> LetRecExpr <$> parseBindings <*> parseExpr -parseDestructClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])-parseDestructClause = brackets (do pppat <- lexeme parsePrimitivePatPattern-                                   typExpr <- lexeme parseExpr-                                   dc2s <- lexeme (braces (sepEndBy parseDestructClause2 whiteSpace))-                                   return (pppat, typExpr, dc2s))+parseLetExpr :: Parser EgisonExpr+parseLetExpr = keywordLet >> LetExpr <$> parseBindings <*> parseExpr -parseDestructClause2 :: Parser (PrimitivePattern, EgisonExpr)-parseDestructClause2 = brackets (do datPat <- lexeme parsePrimitivePattern-                                    expr <- lexeme parseExpr-                                    return (datPat, expr))+parseDoExpr :: Parser EgisonExpr+parseDoExpr = keywordDo >> DoExpr <$> parseBindings <*> parseExpr -parsePrimitivePatPattern :: Parser PrimitivePatPattern-parsePrimitivePatPattern =-      do char '_'-         return PPWildCard-  <|> do char ','-         char '$'-         name <- lexeme identifier-         return (PPValuePat name)-  <|> angles (do c <- lexeme identifier-                 ps <- sepEndBy parsePrimitivePatPattern whiteSpace-                 return (PPInductivePat c ps))-                                    -parsePrimitivePattern :: Parser PrimitivePattern-parsePrimitivePattern =-      do char '_'-         return PWildCard-  <|> do char '$'-         name <- identifier-         return (PPatVar name)-  <|> angles (do c <- lexeme identifier-                 ps <- sepEndBy parsePrimitivePattern whiteSpace-                 return (PInductivePat c ps))-  <|> try (do string "{}"-              return PEmptyPat)-  <|> try (do lexeme $ char '{'-              a <- lexeme parsePrimitivePattern-              char '.'-              b <- lexeme parsePrimitivePattern-              char '}'-              return (PConsPat a b))-  <|> try (do lexeme $ char '{'-              char '.'-              a <- lexeme parsePrimitivePattern-              b <- lexeme parsePrimitivePattern-              char '}'-              return (PSnocPat a b))-  <|> do b <- try parseBool2-         return (PPatBool b)-  <|> do c <- try parseChar2-         return (PPatChar c)---  <|> do d <- try parseRealNumber2---         return (PPatFloat d)-  <|> do n <- try parseNumber2-         return (PPatNumber n)+parseBindings :: Parser [BindingExpr]+parseBindings = braces $ sepEndBy parseBinding whiteSpace -parseMatchClause :: Parser MatchClause-parseMatchClause = brackets (do pat <- lexeme parseExpr-                                body <- lexeme parseExpr-                                return (pat, body))+parseBinding :: Parser BindingExpr+parseBinding = brackets $ (,) <$> parseVarNames <*> parseExpr -parseArrayElementExpr :: Parser ArrayElementExpr-parseArrayElementExpr =-      do try (lexeme (string "[~"))-         exprs <- sepEndBy parseArrayElementExpr whiteSpace-         (lexeme (string "~]"))-         return (AInnerArrayExpr exprs)-  <|> do expr <- parseExpr-         return (AElementExpr expr)+parseVarNames :: Parser [String]+parseVarNames = return <$> parseVarName+            <|> brackets (sepEndBy parseVarName whiteSpace)  --- |Parse an expression-parseExpr :: Parser EgisonExpr-parseExpr =---      try (lexeme parseRealNumber)-      try (lexeme parseNumber)-  <|> lexeme parseChar-  <|> lexeme parseString-  <|> try (lexeme parseBool)-  <|> try (lexeme parsePattern)-  <|> lexeme parseMacroVarExpr-  <|> lexeme parsePatVarOmitExpr-  <|> lexeme parseVarOmitExpr-  <|> try (lexeme (do string "undefined"-                      return UndefinedExpr))-  <|> try (lexeme (do string "Something"-                      return SomethingExpr))-  <|> lexeme parseVar-  <|> do try (lexeme (string "[|"))-         exprs <- sepEndBy parseArrayElementExpr whiteSpace-         (lexeme (string "|]"))-         return (ArrayExpr exprs)-  <|> angles (do cons <- lexeme identifier-                 argExprs <- sepEndBy parseExpr whiteSpace-                 return $ InductiveDataExpr cons argExprs)-  <|> braces (do innerExprs <- sepEndBy parseInnerExpr whiteSpace-                 return $ CollectionExpr innerExprs)-  <|> brackets (do exprs <- sepEndBy parseExpr whiteSpace-                   return $ TupleExpr exprs)-  <|> parens (do try (string "lambda" >> many1 space)-                 args <- lexeme parseExpr-                 body <- lexeme parseExpr-                 return (FuncExpr args body)-          <|> do try (string "macro" >> many1 space)-                 args <- lexeme (brackets (sepEndBy (do (name, _) <- parsePatVar2-                                                        return name)-                                                    whiteSpace))-                 body <- lexeme parseExpr-                 return (MacroExpr args body)-          <|> do try (string "if" >> many1 space)-                 condExpr <- lexeme parseExpr-                 expr1 <- lexeme parseExpr-                 expr2 <- lexeme parseExpr-                 return (IfExpr condExpr expr1 expr2)-          <|> do try (string "letrec" >> many1 space)-                 bindings <- lexeme parseRecursiveBindings-                 body <- lexeme parseExpr-                 return (LetRecExpr bindings body)-          <|> do try (string "let" >> many1 space)-                 bindings <- lexeme parseBindings-                 body <- lexeme parseExpr-                 return (LetExpr bindings body)-          <|> do try (string "do" >> many1 space)-                 bindings <- lexeme parseBindings-                 body <- lexeme parseExpr-                 return (DoExpr bindings body)-          <|> do try (string "type" >> many1 space)-                 deconsInfo <- lexeme parseDestructInfoExpr-                 return (TypeExpr deconsInfo)-          <|> do try (string "match-all" >> many1 space)-                 tgtExpr <- lexeme parseExpr-                 typExpr <- lexeme parseExpr-                 mc <- lexeme parseMatchClause-                 return (MatchAllExpr tgtExpr typExpr mc)-          <|> do try (string "match" >> many1 space)-                 tgtExpr <- lexeme parseExpr-                 typExpr <- lexeme parseExpr-                 mcs <- braces (sepEndBy parseMatchClause whiteSpace)-                 return (MatchExpr tgtExpr typExpr mcs)-          <|> do try (string "loop" >> many1 space)-                 (loopVar, _) <- lexeme parsePatVar2-                 (indexVar, _) <- lexeme parsePatVar2-                 rangeExpr <- lexeme parseExpr-                 loopExpr <- lexeme parseExpr-                 tailExpr <- lexeme parseExpr-                 return (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr)-          <|> do try (string "generate-array" >> many1 space)-                 fnExpr <- lexeme parseExpr-                 arrExpr <- lexeme parseExpr-                 return (GenerateArrayExpr fnExpr arrExpr)-          <|> do opExpr <- lexeme parseExpr-                 argExprs <- sepEndBy parseExpr whiteSpace-                 return (ApplyExpr opExpr (TupleExpr argExprs)))-  <?> "Expression"+parseVarName :: Parser String+parseVarName = char '$' >> ident -parseTopExpr :: Parser TopExpr-parseTopExpr =-     do whiteSpace-        parens (do try $ lexeme $ string "define"-                   char '$'-                   name <- lexeme identifier-                   expr <- lexeme parseExpr-                   return (Define name expr)-            <|> do try $ lexeme $ string "test"-                   expr <- lexeme parseExpr-                   return (Test expr)-            <|> do try $ lexeme $ string "execute"-                   args <- sepEndBy parseString2 whiteSpace-                   return (Execute args)-            <|> do try $ string "load-file" >> many1 space-                   filename <- lexeme parseString2-                   return (LoadFile filename)-            <|> do try $ lexeme $ string "load"-                   filename <- lexeme parseString2-                   return (Load filename)-                ) <?> "top expression"+parseLoopExpr :: Parser EgisonExpr+parseLoopExpr = keywordLoop >> LoopExpr <$> parseVarName <*> parseVarName+                                        <*> parseExpr <*> parseExpr <*> parseExpr -mainParser :: Parser TopExpr-mainParser = do-    x <- parseTopExpr--- FUTURE? (seemed to break test cases, but is supposed to be best practice?)    eof-    return x+parseApplyExpr :: Parser EgisonExpr+parseApplyExpr = (keywordApply >> ApplyExpr <$> parseExpr <*> parseExpr) +             <|> parseApplyExpr' --- |Use a parser to parse the given text, throwing an error---  if there is a problem parsing the text.-readOrThrow :: Parser a -> String -> ThrowsError a-readOrThrow parser input = case parse parser "egison" input of-  Left err -> throwError $ Parser err-  Right val -> return val+parseApplyExpr' :: Parser EgisonExpr+parseApplyExpr' = do+  func <- parseExpr+  args <- parseArgs+  let vars = lefts args+  case vars of+    [] -> return . ApplyExpr func . TupleExpr $ rights args+    _ | all null vars ->+        let genVar = modify (1+) >> gets (flip VarExpr [] . ('#':) . show)+            args' = evalState (mapM (either (const genVar) return) args) 0+        in return . LambdaExpr (annonVars $ length vars) . ApplyExpr func $ TupleExpr args'+      | all (not . null) vars ->+        let ns = Set.fromList $ map read vars+            n = Set.size ns+        in if Set.findMin ns == 1 && Set.findMax ns == n+             then+               let args' = map (either (flip VarExpr [] . ('#':)) id) args+               in return . LambdaExpr (annonVars n) . ApplyExpr func $ TupleExpr args'+             else fail "invalid partial application"+      | otherwise -> fail "invalid partial application"+ where+  parseArgs = sepEndBy parseArg whiteSpace+  parseArg = try (Right <$> parseExpr)+         <|> char '$' *> (Left <$> option "" parseIndex)+  parseIndex = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit+  annonVars n = take n $ map (('#':) . show) [1..] --- |Parse an top expression from a string of text-readTopExpr :: String -> ThrowsError TopExpr-readTopExpr = readOrThrow mainParser+parseCutPatExpr :: Parser EgisonExpr+parseCutPatExpr = reservedOp "!" >> PatternExpr . CutPat <$> parseExpr --- |Parse an expression from a string of text-readExpr :: String -> ThrowsError EgisonExpr-readExpr = readOrThrow (whiteSpace >> parseExpr)+parseNotPatExpr :: Parser EgisonExpr+parseNotPatExpr = reservedOp "^" >> PatternExpr . NotPat <$> parseExpr --- |Parse many top expressions from a string of text-readTopExprList :: String -> ThrowsError [TopExpr]-readTopExprList = readOrThrow (endBy mainParser whiteSpace)+parseWildCardExpr :: Parser EgisonExpr+parseWildCardExpr = reservedOp "_" >> pure (PatternExpr WildCard) +parseValuePatExpr :: Parser EgisonExpr+parseValuePatExpr = reservedOp "," >> PatternExpr . ValuePat <$> parseExpr++parsePatVarExpr :: Parser EgisonExpr+parsePatVarExpr = P.lexeme lexer $ (PatternExpr .) . PatVar <$> parseVarName <*> parseIndexNums++parsePredPatExpr :: Parser EgisonExpr+parsePredPatExpr = reservedOp "?" >> PatternExpr . PredPat <$> parseExpr++parseAndPatExpr :: Parser EgisonExpr+parseAndPatExpr = reservedOp "&" >> PatternExpr . AndPat <$> sepEndBy parseExpr whiteSpace++parseOrPatExpr :: Parser EgisonExpr+parseOrPatExpr = reservedOp "|" >> PatternExpr . OrPat <$> sepEndBy parseExpr whiteSpace++parseAlgebraicDataMatcherExpr :: Parser EgisonExpr+parseAlgebraicDataMatcherExpr = keywordAlgebraicDataMatcher +                                >> (parens $ AlgebraicDataMatcher <$> parseAlgebraicDataMatcherBody)+  where+    parseAlgebraicDataMatcherBody :: Parser [EgisonExpr]+    parseAlgebraicDataMatcherBody = reservedOp "|" >> sepEndBy1 parseInductivePatternExpr whiteSpace++--parseOmitExpr :: Parser EgisonExpr+--parseOmitExpr = prefixChar '`' >> OmitExpr <$> ident <*> parseIndexNums++--parsePatVarOmitExpr :: Parser EgisonExpr+--parsePatVarOmitExpr = prefixString "$`" >> PatVarOmitExpr <$> ident <*> parseIndexNums++parseConstantExpr :: Parser EgisonExpr+parseConstantExpr =  parseCharExpr+                 <|> parseStringExpr+                 <|> parseBoolExpr+                 <|> try parseFloatExpr+                 <|> parseIntegerExpr+                 <|> (keywordSomething *> pure SomethingExpr)+                 <|> (keywordUndefined *> pure UndefinedExpr)+                 <?> "constant"++parseCharExpr :: Parser EgisonExpr+parseCharExpr = CharExpr <$> charLiteral++parseStringExpr :: Parser EgisonExpr+parseStringExpr = StringExpr <$> stringLiteral++parseBoolExpr :: Parser EgisonExpr+parseBoolExpr = BoolExpr <$> boolLiteral++parseIntegerExpr :: Parser EgisonExpr+parseIntegerExpr = IntegerExpr <$> integerLiteral++parseFloatExpr :: Parser EgisonExpr+parseFloatExpr = FloatExpr <$> floatLiteral++-- Tokens++egisonDef :: P.GenLanguageDef ByteString () Identity+egisonDef = +  P.LanguageDef { P.commentStart       = "#|"+                , P.commentEnd         = "|#"+                , P.commentLine        = ";"+                , P.identStart         = letter <|> symbol1+                , P.identLetter        = letter <|> digit <|> symbol2+                , P.opStart            = symbol1+                , P.opLetter           = symbol1+                , P.reservedNames      = reservedKeywords+                , P.reservedOpNames    = reservedOperators+                , P.nestedComments     = True+                , P.caseSensitive      = True }+ where+  symbol1 = oneOf "&*/:="+  symbol2 = symbol1 <|> oneOf "+-!?"++lexer :: P.GenTokenParser ByteString () Identity+lexer = P.makeTokenParser egisonDef++reservedKeywords :: [String]+reservedKeywords = +  [ "define"+  , "test"+  , "execute"+  , "load-file"+  , "load"+  , "if"+  , "apply"+  , "lambda"+  , "pattern-constructor"+  , "letrec"+  , "let"+  , "loop"+  , "match-all"+  , "match"+  , "matcher"+  , "do"+  , "function"+  , "algebraic-data-matcher"+  , "something"+  , "undefined"]+  +reservedOperators :: [String]+reservedOperators = +  [ "$"+  , "_"+  , "&"+  , "|"+  , "^"+  , "!"+  , ","+  , "@"]++reserved :: String -> Parser ()+reserved = P.reserved lexer++reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer++keywordDefine               = reserved "define"+keywordTest                 = reserved "test"+keywordExecute              = reserved "execute"+keywordLoadFile             = reserved "load-file"+keywordLoad                 = reserved "load"+keywordIf                   = reserved "if"+keywordThen                 = reserved "then"+keywordElse                 = reserved "else"+keywordApply                = reserved "apply"+keywordLambda               = reserved "lambda"+keywordPatternConstructor   = reserved "pattern-constructor"+keywordLetRec               = reserved "letrec"+keywordLet                  = reserved "let"+keywordLoop                 = reserved "loop"+keywordMatchAll             = reserved "match-all"+keywordMatch                = reserved "match"+keywordMatcher              = reserved "matcher"+keywordDo                   = reserved "do"+keywordFunction             = reserved "function"+keywordSomething            = reserved "something"+keywordUndefined            = reserved "undefined"+keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher"++sign :: Num a => Parser (a -> a)+sign = (char '-' >> return negate)+   <|> (char '+' >> return id)+   <|> return id++integerLiteral :: Parser Integer+integerLiteral = sign <*> P.natural lexer++floatLiteral :: Parser Double+floatLiteral = sign <*> P.float lexer++stringLiteral :: Parser String+stringLiteral = P.stringLiteral lexer++charLiteral :: Parser Char+charLiteral = P.charLiteral lexer++boolLiteral :: Parser Bool+boolLiteral = P.lexeme lexer $ char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)++whiteSpace :: Parser ()+whiteSpace = P.whiteSpace lexer++parens :: Parser a -> Parser a+parens = P.parens lexer++brackets :: Parser a -> Parser a+brackets = P.brackets lexer++braces :: Parser a -> Parser a+braces = P.braces lexer++angles :: Parser a -> Parser a+angles = P.angles lexer++colon :: Parser String+colon = P.colon lexer++comma :: Parser String+comma = P.comma lexer++dot :: Parser String+dot = P.dot lexer++ident :: Parser String+ident = P.identifier lexer+    <|> (P.lexeme lexer $ string "+")+    <|> (P.lexeme lexer $ string "-")++upperName :: Parser String+upperName = P.lexeme lexer $ (:) <$> upper <*> option "" ident+ where+  upper :: Parser Char +  upper = satisfy isUpper++lowerName :: Parser String+lowerName = P.lexeme lexer $ (:) <$> lower <*> option "" ident+ where+  lower :: Parser Char +  lower = satisfy isLower

@@ -1,255 +1,313 @@-module Language.Egison.Primitives where-import Language.Egison.Parser-import Language.Egison.Types+{-# Language FlexibleContexts #-}+module Language.Egison.Primitives (primitiveEnv) where++import Control.Arrow+import Control.Applicative 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 hiding (try) -import Paths_egison+import Data.IORef ------------------------------------------------------- I/O Primitives-----------------------------------------------------getLibDirName :: [EgisonVal] -> IOThrowsError EgisonVal-getLibDirName [] = liftIO $ (getDataFileName "") >>= return . String-getLibDirName _ = throwError $ Default $ "readCharFromPort: invalid arguments"+import System.IO -makePort :: IOMode -> [EgisonVal] -> IOThrowsError EgisonVal-makePort mode [(World actions), (String filename)] = do-  port <- liftM (Port filename) $ liftIO $ openFile filename mode-  let newWorld = case mode of-                   ReadMode -> World $ (OpenInputPort filename):actions-                   WriteMode -> World $ (OpenOutputPort filename):actions-  return $ Tuple [newWorld, port]-makePort _ [] = throwError $ NumArgs 2 []-makePort _ [arg] = throwError $ NumArgs 2 [arg]-makePort _ args@(_:_:_:_) = throwError $ NumArgs 2 args-makePort _ _ = throwError $ Default $ "closePort: invalid arguments"+import Language.Egison.Types+import Language.Egison.Core -closePort :: [EgisonVal] -> IOThrowsError EgisonVal-closePort [World actions, Port filename port] = do-  liftIO $ hClose port-  let newWorld = World $ (ClosePort filename):actions-  return newWorld-closePort _ = throwError $ Default $ "closePort: invalid arguments"+primitiveEnv :: IO Env+primitiveEnv = do+  let ops = map (second PrimitiveFunc) (primitives ++ ioPrimitives) +++            map (second IOFunc) assertions+  bindings <- forM (constants ++ ops) $ \(name, op) -> do+    ref <- newIORef . WHNF $ Value op+    return ((name, []), ref)+  return $ extendEnv nullEnv bindings -writeChar :: [EgisonVal] -> IOThrowsError EgisonVal-writeChar [World actions, Char c] = do-  liftIO $ putChar c-  let newWorld = World $ (WriteToPort "stdout" [c]):actions-  return newWorld-writeChar _ = throwError $ Default $ "writeChar: invalid arguments"+{-# INLINE noArg #-}+noArg :: (MonadError EgisonError m) =>+         m EgisonValue ->+         [WHNFData] -> m EgisonValue+noArg f = \vals -> case vals of +                     [] -> f+                     _ -> throwError $ ArgumentsNum 0 $ length vals -writeString :: [EgisonVal] -> IOThrowsError EgisonVal-writeString [World actions, String str] = do-  liftIO $ putStr str-  let newWorld = World $ (WriteToPort "stdout" str):actions-  return newWorld-writeString _ = throwError $ Default $ "writeString: invalid arguments"+{-# INLINE oneArg #-}+oneArg :: (MonadError EgisonError m) =>+          (WHNFData -> m EgisonValue) ->+          [WHNFData] -> m EgisonValue+oneArg f = \vals -> case vals of +                      [val] -> f val+                      _ -> throwError $ ArgumentsNum 1 $ length vals -writeStringLine :: [EgisonVal] -> IOThrowsError EgisonVal-writeStringLine [World actions, String str] = do-  liftIO $ putStrLn str-  let newWorld = World $ (WriteToPort "stdout" str):actions-  return newWorld-writeStringLine _ = throwError $ Default $ "writeStringLine: invalid arguments"+{-# INLINE twoArgs #-}+twoArgs :: (MonadError EgisonError m) =>+           (WHNFData -> WHNFData -> m EgisonValue) ->+           [WHNFData] -> m EgisonValue+twoArgs f = \vals -> case vals of +                       [val, val'] -> f val val'+                       _ -> throwError $ ArgumentsNum 2 $ length vals -write :: [EgisonVal] -> IOThrowsError EgisonVal-write [World actions, val] = do-  let str = show val-  liftIO $ putStr str-  let newWorld = World $ (WriteToPort "stdout" str):actions-  return newWorld-write _ = throwError $ Default $ "write: invalid arguments"+{-# INLINE threeArgs #-}+threeArgs :: (MonadError EgisonError m) =>+             (WHNFData -> WHNFData -> WHNFData -> m EgisonValue) ->+             [WHNFData] -> m EgisonValue+threeArgs f = \vals -> case vals of +                         [val, val', val''] -> f val val' val''+                         _ -> throwError $ ArgumentsNum 3 $ length vals -flushStdout :: [EgisonVal] -> IOThrowsError EgisonVal-flushStdout [World actions] = do-  liftIO $ hFlush stdout-  let newWorld = World $ (FlushPort "stdout"):actions-  return newWorld-flushStdout _ = throwError $ Default $ "flush: invalid arguments"+--+-- Constants+-- -readChar :: [EgisonVal] -> IOThrowsError EgisonVal-readChar [World actions] = do-  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 $ Tuple [newWorld, EOF]-                else throwError $ Default "I/O error read-char"-    Right inpChr -> do-      let newWorld = World $ (ReadFromPort "stdin" [inpChr]):actions-      return $ Tuple [newWorld, Char inpChr]-readChar _ = throwError $ Default $ "readChar: invalid arguments"+constants :: [(String, EgisonValue)]+constants = [ ("pi", Float 3.141592653589793) ] -readLine :: [EgisonVal] -> IOThrowsError EgisonVal-readLine [World actions] = do-  input <- liftIO $ try (liftIO getLine)-  case input of-    Left e -> if isEOFError e-                then do-                  let newWorld = World $ (ReadFromPort "stdin" "EOF"):actions-                  return $ Tuple [newWorld, EOF]-                else throwError $ Default "I/O error read-line"-    Right inpStr -> do-      let newWorld = World $ (ReadFromPort "stdin" inpStr):actions-      return $ Tuple [newWorld, String inpStr]-readLine _ = throwError $ Default $ "readLine: invalid arguments"+--+-- Primitives+-- -readFromStdin :: [EgisonVal] -> IOThrowsError EgisonVal-readFromStdin [World actions] = do-  str <- hGetExpr stdin-  let newWorld = World $ (ReadFromPort "stdin" str):actions-  expr <- liftThrows $ readExpr str-  val <- liftThrows $ exprToVal expr-  return $ Tuple [newWorld, val]-readFromStdin _ = throwError $ Default $ "read: invalid arguments"+primitives :: [(String, PrimitiveFunc)]+primitives = [ ("+", integerBinaryOp (+)) +             , ("-", integerBinaryOp (-))+             , ("*", integerBinaryOp (*))+             , ("modulo",    integerBinaryOp mod)+             , ("qutient",   integerBinaryOp quot)+             , ("remainder", integerBinaryOp rem)+             , ("eq-n?",  integerBinaryPred (==))+             , ("lt-n?",  integerBinaryPred (<))+             , ("lte-n?", integerBinaryPred (<=))+             , ("gt-n?",  integerBinaryPred (>))+             , ("gte-n?", integerBinaryPred (>=))+             , ("+f", floatBinaryOp (+))+             , ("-f", floatBinaryOp (-))+             , ("*f", floatBinaryOp (*))+             , ("/f", floatBinaryOp (/))+             , ("eq-f?",  floatBinaryPred (==))+             , ("lt-f?",  floatBinaryPred (<))+             , ("lte-f?", floatBinaryPred (<=))+             , ("gt-f?",  floatBinaryPred (>))+             , ("gte-f?", floatBinaryPred (>=))+             , ("neg", integerUnaryOp negate)+             , ("abs", integerUnaryOp abs)+             , ("sqrt", floatUnaryOp sqrt)+             , ("exp", floatUnaryOp exp)+             , ("log", floatUnaryOp log)+             , ("sin", floatUnaryOp sin)+             , ("cos", floatUnaryOp cos)+             , ("tan", floatUnaryOp tan)+             , ("asin", floatUnaryOp asin)+             , ("acos", floatUnaryOp acos)+             , ("atan", floatUnaryOp atan)+             , ("sinh", floatUnaryOp sinh)+             , ("cosh", floatUnaryOp cosh)+             , ("tanh", floatUnaryOp tanh)+             , ("asinh", floatUnaryOp asinh)+             , ("acosh", floatUnaryOp acosh)+             , ("atanh", floatUnaryOp atanh)+             , ("round",    floatToIntegerOp round)+             , ("floor",    floatToIntegerOp floor)+             , ("ceiling",  floatToIntegerOp ceiling)+             , ("truncate", floatToIntegerOp truncate)+             , ("eq?",  eq)+             , ("lt?",  lt)+             , ("lte?", lte)+             , ("gt?",  gt)+             , ("gte?", gte)+             , ("string-append", stringAppend) ]+             +integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc+integerUnaryOp op = oneArg $ \val ->+  Integer . op <$> fromIntegerValue val +integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc+integerBinaryOp op = twoArgs $ \val val' ->+  (Integer .) . op <$> fromIntegerValue val+                   <*> fromIntegerValue val' -writeCharToPort :: [EgisonVal] -> IOThrowsError EgisonVal-writeCharToPort [World actions, Port filename port, Char c] = do-  liftIO $ hPutChar port c-  let newWorld = World $ (WriteToPort filename [c]):actions-  return newWorld-writeCharToPort _ = throwError $ Default $ "writeCharToPort: invalid arguments"+integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc+integerBinaryPred pred = twoArgs $ \val val' ->+  (Bool .) . pred <$> fromIntegerValue val+                  <*> fromIntegerValue val' -writeStringToPort :: [EgisonVal] -> IOThrowsError EgisonVal-writeStringToPort [World actions, Port filename port, String str] = do-  liftIO $ hPutStr port str-  let newWorld = World $ (WriteToPort filename str):actions-  return newWorld-writeStringToPort _ = throwError $ Default $ "writeString: invalid arguments"+floatUnaryOp :: (Double -> Double) -> PrimitiveFunc+floatUnaryOp op = oneArg $ \val ->+  Float . op <$> fromFloatValue val -writeStringLineToPort :: [EgisonVal] -> IOThrowsError EgisonVal-writeStringLineToPort [World actions, Port filename port, String str] = do-  liftIO $ hPutStrLn port str-  let newWorld = World $ (WriteToPort filename str):actions-  return newWorld-writeStringLineToPort _ = throwError $ Default $ "writeStringLineToPort: invalid arguments"+floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc+floatBinaryOp op = twoArgs $ \val val' ->+  (Float .) . op <$> fromFloatValue val+                 <*> fromFloatValue val' -writeToPort :: [EgisonVal] -> IOThrowsError EgisonVal-writeToPort [World actions, Port filename port, val] = do-  let str = show val-  liftIO $ hPutStr port str-  let newWorld = World $ (WriteToPort filename str):actions-  return newWorld-writeToPort _ = throwError $ Default $ "writeToPort: invalid arguments"+floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc+floatBinaryPred pred = twoArgs $ \val val' ->+  (Bool .) . pred <$> fromFloatValue val+                  <*> fromFloatValue val' -flushPort :: [EgisonVal] -> IOThrowsError EgisonVal-flushPort [World actions, Port filename port] = do-  liftIO $ hFlush port-  let newWorld = World $ (FlushPort filename):actions-  return newWorld-flushPort _ = throwError $ Default $ "flush-port: invalid arguments"+floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc+floatToIntegerOp op = oneArg $ \val ->+  Integer . op <$> fromFloatValue val -readCharFromPort :: [EgisonVal] -> IOThrowsError EgisonVal-readCharFromPort [World actions, Port filename port] = do-  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 $ Tuple [newWorld, EOF]-                else throwError $ Default "I/O error read-char-from-port"-    Right inpChr -> do-      let newWorld = World $ (ReadFromPort filename [inpChr]):actions-      return $ Tuple [newWorld, Char inpChr]-readCharFromPort _ = throwError $ Default $ "readCharFromPort: invalid arguments"+eq :: PrimitiveFunc+eq = twoArgs $ \val val' ->+  (Bool .) . (==) <$> fromPrimitiveValue val+                  <*> fromPrimitiveValue val' -readLineFromPort :: [EgisonVal] -> IOThrowsError EgisonVal-readLineFromPort [World actions, Port filename port] = do-  input <- liftIO $ try (liftIO $ hGetLine port)-  case input of-    Left e -> if isEOFError e-                then do-                  let newWorld = World $ (ReadFromPort filename "EOF"):actions-                  return $ Tuple [newWorld, EOF]-                else throwError $ Default "I/O error read-line-from-port"-    Right inpStr -> do-      let newWorld = World $ (ReadFromPort filename inpStr):actions-      return $ Tuple [newWorld, String inpStr]-readLineFromPort _ = throwError $ Default $ "readLineFromPort: invalid arguments"+lt :: PrimitiveFunc+lt = twoArgs lt'+ where+  lt' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i < i'+  lt' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i < f+  lt' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f < fromInteger i+  lt' (Value (Float f)) (Value (Float f')) = return $ Bool $ f < f'+  lt' (Value (Integer _)) val = throwError $ TypeMismatch "number" val+  lt' (Value (Float _)) val = throwError $ TypeMismatch "number" val+  lt' val _ = throwError $ TypeMismatch "number" val -readFromPort :: [EgisonVal] -> IOThrowsError EgisonVal-readFromPort [World actions, Port filename port] = do-  str <- hGetExpr port-  let newWorld = World $ (ReadFromPort filename str):actions-  expr <- liftThrows $ readExpr str-  val <- liftThrows $ exprToVal expr-  return $ Tuple [newWorld, val]-readFromPort _ = throwError $ Default $ "read: invalid arguments"+lte :: PrimitiveFunc+lte = twoArgs lte'+ where+  lte' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i <= i'+  lte' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i <= f+  lte' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f <= fromInteger i+  lte' (Value (Float f)) (Value (Float f')) = return $ Bool $ f <= f'+  lte' (Value (Integer _)) val = throwError $ TypeMismatch "number" val+  lte' (Value (Float _)) val = throwError $ TypeMismatch "number" val+  lte' val _ = throwError $ TypeMismatch "number" val +gt :: PrimitiveFunc+gt = twoArgs gt'+ where+  gt' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i > i'+  gt' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i > f+  gt' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f > fromInteger i+  gt' (Value (Float f)) (Value (Float f')) = return $ Bool $ f > f'+  gt' (Value (Integer _)) val = throwError $ TypeMismatch "number" val+  gt' (Value (Float _)) val = throwError $ TypeMismatch "number" val+  gt' val _ = throwError $ TypeMismatch "number" val -hGetExpr :: Handle -> IOThrowsError String-hGetExpr h = do-  str <- loop ""-  return str+gte :: PrimitiveFunc+gte = twoArgs gte'  where-    loop :: String -> IOThrowsError String-    loop input0 = do-      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+  gte' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i >= i'+  gte' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i >= f+  gte' (Value (Float f)) (Value (Integer i)) = return $ Bool $ f >= fromInteger i+  gte' (Value (Float f)) (Value (Float f')) = return $ Bool $ f >= f'+  gte' (Value (Integer _)) val = throwError $ TypeMismatch "number" val+  gte' (Value (Float _)) val = throwError $ TypeMismatch "number" val+  gte' val _ = throwError $ TypeMismatch "number" val -countParens :: String -> Bool-countParens str = let countOpen = length $ filter (\c -> ('(' == c)-                                                      || ('{' == c)-                                                      || ('[' == c)-                                                      || ('<' == c))-                                                  str in-                  let countClose = length $ filter (\c -> (')' == c)-                                                       || ('}' == c)-                                                       || (']' == c)-                                                       || ('>' == c))-                                                  str in-                    (countOpen == countClose)+stringAppend :: PrimitiveFunc+stringAppend = twoArgs $ \val val' ->+  (String .) . (++) <$> fromStringValue val+                    <*> fromStringValue val' -exprToVal :: EgisonExpr -> ThrowsError EgisonVal-exprToVal (BoolExpr contents) = return $ Bool contents-exprToVal (CharExpr contents) = return $ Char contents-exprToVal (StringExpr contents) = return $ String contents-exprToVal (NumberExpr contents) = return $ Number contents-exprToVal (FloatExpr contents) = return $ Float contents-exprToVal (InductiveDataExpr cons argExprs) = do-  args <- mapM exprToVal argExprs-  return $ InductiveData cons args-exprToVal (CollectionExpr innerExprs) = do-  vals <- innerExprsToVals innerExprs-  return $ Collection vals-exprToVal (TupleExpr exprs) = do-  vals <- mapM exprToVal exprs-  return $ Tuple vals-exprToVal _ = throwError $ Default "read: invalid value"+--+-- IO Primitives+-- -innerExprsToVals :: [InnerExpr] -> ThrowsError [EgisonVal]-innerExprsToVals [] = return []-innerExprsToVals ((ElementExpr expr):rest) = do-  retRest <- innerExprsToVals rest-  val <- exprToVal expr-  return (val:retRest)-innerExprsToVals ((SubCollectionExpr expr):rest) = do-  val <- exprToVal expr+ioPrimitives :: [(String, PrimitiveFunc)]+ioPrimitives = [ ("open-input-file", makePort ReadMode)+               , ("open-output-file", makePort WriteMode)+               , ("close-input-port", closePort)+               , ("close-output-port", closePort)+               , ("read-char", readChar)+               , ("read-line", readLine)+--             , ("read", readFromStdin)+               , ("write-char", writeChar)+               , ("write-string", writeString)+               , ("write", write)+--             , ("print", writeStringLine)+               , ("flush", flushStdout)+               , ("read-char-from-port", readCharFromPort)+               , ("read-line-from-port", readLineFromPort)+--             , ("read-from-port", readFromPort)+               , ("write-char-to-port", writeCharToPort)+               , ("write-string-to-port", writeStringToPort)+               , ("write-to-port", writeToPort)+--             , ("print-to-port", writeStringLineToPort)+               , ("flush-port", flushPort) ]+--             , ("get-lib-dir-name", getLibDirName) ]++makeIO :: IO EgisonValue -> EgisonValue+makeIO io = IOFunc . oneArg $ \val ->   case val of-    Collection vals -> do-      retRest <- innerExprsToVals rest-      return $ vals ++ retRest-    _ -> throwError $ Default "innerExprToVals: not collection after @"+    Value World -> Tuple . (:) World . return <$> liftIO io+    _ -> throwError $ TypeMismatch "world" val +makeIO' :: IO () -> EgisonValue+makeIO' io = IOFunc . oneArg $ \val ->+  case val of+    Value World -> liftIO io >> return World+    _ -> throwError $ TypeMismatch "world" val++makePort :: IOMode -> PrimitiveFunc+makePort mode = oneArg $ \val -> do+  filename <- fromStringValue val +  return . makeIO $ Port <$> openFile filename mode++closePort :: PrimitiveFunc+closePort = oneArg $ \val -> makeIO' . hClose <$> fromPortValue val++writeChar :: PrimitiveFunc+writeChar = oneArg $ \val -> makeIO' . putChar <$> fromCharValue val++writeString :: PrimitiveFunc+writeString = oneArg $ \val -> makeIO' . putStr <$> fromStringValue val++write :: PrimitiveFunc+write = oneArg $ Right . makeIO' . putStr . show++readChar :: PrimitiveFunc+readChar = noArg $ Right $ makeIO (liftM Char getChar)++readLine :: PrimitiveFunc+readLine = noArg $ Right $ makeIO (liftM String getLine)++flushStdout :: PrimitiveFunc+flushStdout = noArg $ Right $ makeIO' $ hFlush stdout++writeCharToPort :: PrimitiveFunc+writeCharToPort = twoArgs $ \val val' ->+  (makeIO' .) . hPutChar <$> fromPortValue val <*> fromCharValue val'++writeStringToPort :: PrimitiveFunc+writeStringToPort = twoArgs $ \val val' ->+  (makeIO' .) . hPutStr <$> fromPortValue val <*> fromStringValue val'++writeToPort :: PrimitiveFunc+writeToPort = twoArgs $ \val val' ->+  makeIO' . flip hPutStr (show val') <$> fromPortValue val++readCharFromPort :: PrimitiveFunc+readCharFromPort = oneArg $ \val ->+  makeIO . liftM Char . hGetChar <$> fromPortValue val++readLineFromPort :: PrimitiveFunc+readLineFromPort = oneArg $ \val ->+  makeIO . liftM String . hGetLine <$> fromPortValue val++flushPort :: PrimitiveFunc+flushPort = oneArg $ \val ->+  makeIO' . hFlush <$> fromPortValue val++--+-- Assertions+--++assertions :: [(String, IOFunc)]+assertions = [ ("assert", assert)+             , ("assert-equal", assertEqual) ]++assert :: IOFunc +assert = twoArgs $ \label test -> do+  test <- liftError $ fromBoolValue test+  if test+    then return $ Bool True+    else throwError $ Assertion $ show label++assertEqual :: IOFunc +assertEqual = threeArgs $ \label actual expected -> do+  actual <- evalDeep actual+  expected <- evalDeep expected+  if actual == expected+    then return $ Bool True+    else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected +++                                  "\n but found: " ++ show actual

@@ -1,537 +1,343 @@-{-# Language TypeSynonymInstances, FlexibleInstances #-}+{-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} module Language.Egison.Types where +import Control.Applicative import Control.Monad.Error-import Data.Array+import Control.Monad.Trans.Maybe+ import Data.IORef-import qualified Data.Map+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+ import System.IO-import Text.ParserCombinators.Parsec hiding (spaces)+import Text.Parsec (ParseError)  ----- Error+-- Expressions ---data EgisonError = NumArgs Integer [EgisonVal]-  | TypeMismatch String [EgisonVal]-  | Parser ParseError-  | BadSpecialForm String [EgisonVal]-  | NotFunction String String-  | UnboundVar String String-  | DivideByZero-  | ReachToUndefined-  | NotImplemented String-  | InternalError String-  | Default String -showError :: EgisonError -> String-showError (NumArgs expected found) = "Expected " ++ show expected-                                  ++ " args; found values " ++ unwordsList found-showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected-                                  ++ ", found " ++ unwordsList found-showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr-showError (BadSpecialForm message args) = message ++ ": " ++ unwordsList args-showError (NotFunction message func) = message ++ ": " ++ show func-showError (UnboundVar message varname) = message ++ ": " ++ varname-showError DivideByZero = "Division by zero"-showError ReachToUndefined = "Reached to undefined"-showError (NotImplemented message) = "Not implemented: " ++ message-showError (InternalError message) = "An internal error occurred: " ++ message-showError (Default message) = "Error: " ++ message--instance Show EgisonError where show = showError-instance Error EgisonError where-  noMsg = Default "An error has occurred"-  strMsg = Default--type ThrowsError = Either EgisonError--trapError :: (MonadError e m, Show e) => m String -> m String-trapError action = catchError action (return . show)--extractValue :: ThrowsError a -> a-extractValue (Right val) = val-extractValue (Left _) = error "Unexpected error in extractValue; "--type IOThrowsError = ErrorT EgisonError IO--liftThrows :: ThrowsError a -> IOThrowsError a-liftThrows (Left err) = throwError err-liftThrows (Right val) = return val--runIOThrowsREPL :: IOThrowsError String -> IO String-runIOThrowsREPL action = runErrorT (trapError action) >>= return . extractValue--runIOThrows :: IOThrowsError String -> IO (Maybe String)-runIOThrows action = do-    runState <- runErrorT action-    case runState of-        Left err -> return $ Just (show err)-        Right _ -> return $ Nothing------- Expression----data TopExpr = Define String EgisonExpr+data EgisonTopExpr =+    Define String EgisonExpr   | Test EgisonExpr   | Execute [String]+    -- temporary : we will replace load to import and export   | LoadFile String   | Load String  deriving (Show)-        -data EgisonExpr = CharExpr Char++data EgisonExpr =+    CharExpr Char   | StringExpr String   | BoolExpr Bool-  | NumberExpr Integer+  | IntegerExpr Integer   | FloatExpr Double   | VarExpr String [EgisonExpr]-  | MacroVarExpr String-  | PatVarOmitExpr String [EgisonExpr]-  | VarOmitExpr String [EgisonExpr]-  | PatVarExpr String [EgisonExpr]-  | WildCardExpr-  | ValuePatExpr EgisonExpr-  | CutPatExpr EgisonExpr-  | NotPatExpr EgisonExpr-  | AndPatExpr [EgisonExpr]-  | OrPatExpr [EgisonExpr]-  | PredPatExpr EgisonExpr [EgisonExpr]+   | InductiveDataExpr String [EgisonExpr]   | TupleExpr [EgisonExpr]   | CollectionExpr [InnerExpr]-  | ArrayExpr [ArrayElementExpr]-  | FuncExpr EgisonExpr EgisonExpr-  | MacroExpr [String] EgisonExpr-  | LoopExpr String String EgisonExpr EgisonExpr EgisonExpr-  | ParamsExpr String EgisonExpr EgisonExpr++  | PatternExpr EgisonPattern++  | LambdaExpr [String] EgisonExpr+     | IfExpr EgisonExpr EgisonExpr EgisonExpr-  | LetExpr Bindings EgisonExpr-  | LetRecExpr RecursiveBindings EgisonExpr-  | DoExpr Bindings EgisonExpr-  | TypeExpr DestructInfoExpr+  | LetExpr [BindingExpr] EgisonExpr+  | LetRecExpr [BindingExpr] EgisonExpr++  | LoopExpr String String EgisonExpr EgisonExpr EgisonExpr+       | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause-  | GenerateArrayExpr EgisonExpr EgisonExpr++  | FunctionExpr EgisonExpr [MatchClause]++  | MatcherExpr MatcherInfo+  +  | DoExpr [BindingExpr] EgisonExpr+       | ApplyExpr EgisonExpr EgisonExpr++  | AlgebraicDataMatcher [EgisonExpr]+   | SomethingExpr   | UndefinedExpr  deriving (Show) -data ArrayElementExpr = AElementExpr EgisonExpr-  | AInnerArrayExpr [ArrayElementExpr]- deriving (Show)- -type ArgsExpr = Args-               +type BindingExpr = ([String], EgisonExpr) type MatchClause = (EgisonExpr, EgisonExpr)+type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])] -data PrimitivePatPattern = PPWildCard+data EgisonPattern =+    WildCard+  | PatVar String [EgisonExpr]+  | ValuePat EgisonExpr+  | PredPat EgisonExpr+  | CutPat EgisonExpr+  | NotPat EgisonExpr+  | AndPat [EgisonExpr]+  | OrPat [EgisonExpr]+  | InductivePattern String [EgisonExpr]+ deriving (Show)++data PrimitivePatPattern =+    PPWildCard+  | PPPatVar   | PPValuePat String   | PPInductivePat String [PrimitivePatPattern]  deriving (Show) -data PrimitivePattern = PWildCard-  | PPatVar String-  | PInductivePat String [PrimitivePattern]-  | PEmptyPat-  | PConsPat PrimitivePattern PrimitivePattern-  | PSnocPat PrimitivePattern PrimitivePattern-  | PPatBool Bool-  | PPatChar Char-  | PPatNumber Integer-  | PPatFloat Double+data PrimitiveDataPattern =+    PDWildCard+  | PDPatVar String+  | PDInductivePat String [PrimitiveDataPattern]+  | PDEmptyPat+  | PDConsPat PrimitiveDataPattern PrimitiveDataPattern+  | PDSnocPat PrimitiveDataPattern PrimitiveDataPattern+  | PDConstantPat EgisonExpr  deriving (Show) -data InnerExpr = ElementExpr EgisonExpr+data InnerExpr =+    ElementExpr EgisonExpr   | SubCollectionExpr EgisonExpr  deriving (Show) -type Bindings = [(EgisonExpr, EgisonExpr)]--type RecursiveBindings = [(String, EgisonExpr)]-  -type DestructInfoExpr = [(PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])]- ----- Value+-- Values ---type ObjectRef = IORef Object -data Object = Closure Env EgisonExpr-            | Value EgisonVal-            | Intermidiate IntermidiateVal-            | Loop String String ObjectRef EgisonExpr EgisonExpr-  -data EgisonVal = World [Action]+data EgisonValue =+    World   | Char Char   | String String   | Bool Bool-  | Number Integer+  | Integer Integer   | Float Double-  | WildCard-  | PatVar String [Integer]-  | ValuePat ObjectRef-  | PredPat ObjectRef [ObjectRef]-  | CutPat ObjectRef-  | NotPat ObjectRef-  | AndPat [ObjectRef]-  | OrPat [ObjectRef]-  | InductiveData String [EgisonVal]-  | Tuple [EgisonVal]-  | Collection [EgisonVal]-  | Array Integer [Integer] (Array Integer EgisonVal)-  | Type DestructInfo-  | Func ObjectRef EgisonExpr Env-  | Macro [String] EgisonExpr-  | PrimitiveFunc ([EgisonVal] -> ThrowsError EgisonVal)-  | IOFunc ([EgisonVal] -> IOThrowsError EgisonVal)-  | Port String Handle+  | InductiveData String [EgisonValue]+  | Tuple [EgisonValue]+  | Collection [EgisonValue]+  | Pattern EgisonPattern+  | Matcher Matcher+  | Func Env [String] EgisonExpr+  | PrimitiveFunc PrimitiveFunc+  | IOFunc IOFunc+  | Port Handle   | Something   | EOF -data IntermidiateVal = IInductiveData String [ObjectRef]-  | ITuple [ObjectRef]-  | ICollection [InnerValRef]-  -data Action = OpenInputPort String-  | OpenOutputPort String-  | ClosePort String-  | FlushPort String-  | ReadFromPort String String-  | WriteToPort String String--data Args = AVar String-  | ATuple [Args]- deriving (Show)-  -data InnerValRef = IElement ObjectRef-  | ISubCollection ObjectRef--type DestructInfo = [(PrimitivePatPattern, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]---- --- Class for primitive data----class PrimitiveVal a where-    fromEgisonVal :: EgisonVal -> ThrowsError a-    toEgisonVal :: a -> EgisonVal--instance PrimitiveVal Bool where-    fromEgisonVal (Bool b) = return b-    fromEgisonVal notBool = throwError $ TypeMismatch "bool" [notBool]-    toEgisonVal = Bool--instance PrimitiveVal Char where-    fromEgisonVal (Char c) = return c-    fromEgisonVal notChar = throwError $ TypeMismatch "char" [notChar]-    toEgisonVal = Char--instance PrimitiveVal String where-    fromEgisonVal (String str) = return str-    fromEgisonVal notString = throwError $ TypeMismatch "string" [notString]-    toEgisonVal = String+type Matcher = (Env, MatcherInfo)+type PrimitiveFunc = [WHNFData] -> Either EgisonError EgisonValue+type IOFunc = [WHNFData] -> EgisonM EgisonValue -instance PrimitiveVal Integer where-    fromEgisonVal (Number n) = return n-    fromEgisonVal notNum = throwError $ TypeMismatch "number" [notNum]-    toEgisonVal = Number+instance Show EgisonValue where+  show (Char c) = return c+  show (String s) = s+  show (Bool True) = "#t"+  show (Bool False) = "#f"+  show (Integer i) = show i+  show (Float f) = show f+  show (InductiveData name []) = "<" ++ name ++ ">"+  show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">"+  show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]"+  show (Collection vals) = "{" ++ unwords (map show vals) ++ "}"+  show (Pattern _) = "#<pattern>"+  show (Matcher _) = "#<matcher>"+  show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)"+  show (PrimitiveFunc _) = "#<primitive>"+  show (IOFunc _) = "#<io>"+  show (Port _) = "#<port>"+  show Something = "something"+  show World = "#<world>"+  show EOF = "#<eof>" -instance PrimitiveVal Double where-    fromEgisonVal (Float n) = return n-    fromEgisonVal (Number n) = return . fromInteger $ n-    fromEgisonVal notNum = throwError $ TypeMismatch "float" [notNum]-    toEgisonVal = Float+instance Eq EgisonValue where+ (Char c) == (Char c') = c == c'+ (String s) == (String s') = s == s'+ (Bool b) == (Bool b') = b == b'+ (Integer i) == (Integer i') = i == i'+ (Float f) == (Float f') = f == f'+ (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals'+ (Tuple vals) == (Tuple vals') = vals == vals'+ (Collection vals) == (Collection vals') = vals == vals'+ _ == _ = False  -- -- Internal Data ---type VarExpr = (String, [EgisonExpr]) -type Var = (String, [Integer])--type FrameList = [(Var, ObjectRef)]--type Frame = Data.Map.Map Var ObjectRef--type FrameRef = IORef Frame--data Env = Environment {-        parentEnv :: (Maybe Env), -        topFrameRef :: FrameRef-    }+data Object =+    Thunk (EgisonM WHNFData)+  | WHNF WHNFData -nullEnv :: IO Env-nullEnv = do nullBindings <- newIORef $ Data.Map.fromList []-             return $ Environment Nothing nullBindings+type ObjectRef = IORef Object -makeClosure :: Env -> EgisonExpr -> IO ObjectRef-makeClosure env expr = newIORef $ Closure env expr+data WHNFData =+    Intermediate Intermediate+  | Value EgisonValue -makeInnerValRef :: Env -> InnerExpr -> IO InnerValRef-makeInnerValRef env (ElementExpr expr) = do-  objRef <- makeClosure env expr-  return $ IElement objRef-makeInnerValRef env (SubCollectionExpr expr) = do-  objRef <- makeClosure env expr-  return $ ISubCollection objRef+data Intermediate =+    IInductiveData String [ObjectRef]+  | ITuple [ObjectRef]+  | ICollection [Inner] -data MatchFlag = MAll | MOne+data Inner =+    IElement ObjectRef+  | ISubCollection ObjectRef   -data PClosure = PClosure {pcFrame :: FrameList,-                          pcBody :: ObjectRef-                          }--data MAtom = MAtom {pClosure :: PClosure,-                    maTyp :: ObjectRef,-                    maTarget :: ObjectRef-                    }--data MState = MState {msFrame :: FrameList,-                      mAtoms :: [MAtom]-                      }+instance Show WHNFData where+  show (Value val) = show val +  show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"+  show (Intermediate (ITuple _)) = "[...]"+  show (Intermediate (ICollection _)) = "{...}" ------ Type Class------ |Convert a list of Egison objects into a space-separated string-unwordsList :: Show a => [a] -> String-unwordsList = unwords . map show+fromCharValue :: WHNFData -> Either EgisonError Char+fromCharValue (Value (Char c)) = return c+fromCharValue val = throwError $ TypeMismatch "char" val --- |Convert a list of Egison expressions into a space-separated string-unwordsExpr :: [EgisonExpr] -> String-unwordsExpr = unwords . map showExpr+fromStringValue :: WHNFData -> Either EgisonError String+fromStringValue (Value (String s)) = return s+fromStringValue val = throwError $ TypeMismatch "string" val --- |Convert a list of Egison expressions into a '_'-separated string-unwordsNumExprs :: [EgisonExpr] -> String-unwordsNumExprs [] = ""-unwordsNumExprs (n:ns) = "_" ++ showExpr n ++ unwordsNumExprs ns+fromBoolValue :: WHNFData -> Either EgisonError Bool+fromBoolValue (Value (Bool b)) = return b+fromBoolValue val = throwError $ TypeMismatch "bool" val --- |Convert a list of Egison objects into a '_'-separated string-unwordsNums :: Show a => [a] -> String-unwordsNums [] = ""-unwordsNums (n:ns) = "_" ++ show n ++ unwordsNums ns+fromIntegerValue :: WHNFData -> Either EgisonError Integer+fromIntegerValue (Value (Integer i)) = return i+fromIntegerValue val = throwError $ TypeMismatch "integer" val -showVar :: (String, [Integer]) -> String-showVar (name, nums) = name ++ unwordsNums nums+fromFloatValue :: WHNFData -> Either EgisonError Double+fromFloatValue (Value (Float f)) = return f+fromFloatValue val = throwError $ TypeMismatch "float" val -showBindings :: Bindings -> String-showBindings [] = "{}"-showBindings bindings = "{" ++ unwords (map showBinding bindings) ++ "}"- where showBinding (_,expr) = "[$" ++ "..." ++ " " ++ showExpr expr ++ "]" +fromPortValue :: WHNFData -> Either EgisonError Handle+fromPortValue (Value (Port handle)) = return handle+fromPortValue val = throwError $ TypeMismatch "port" val -showRecursiveBindings :: RecursiveBindings -> String-showRecursiveBindings [] = "{}"-showRecursiveBindings bind = "{" ++ unwords (map showBinding bind) ++ "}"- where showBinding (_,expr) = "[$" ++ "..." ++ " " ++ showExpr expr ++ "]" +fromPatternValue :: WHNFData -> Either EgisonError EgisonPattern+fromPatternValue (Value (Pattern pattern)) = return pattern+fromPatternValue val = throwError $ TypeMismatch "pattern" val -showExpr :: EgisonExpr -> String-showExpr (CharExpr chr) = [chr]-showExpr (StringExpr contents) = contents-showExpr (BoolExpr True) = "#t-expr"-showExpr (BoolExpr False) = "#f-expr"-showExpr (NumberExpr contents) = show contents-showExpr (FloatExpr contents) = show contents-showExpr (VarExpr name nums) = name ++ unwordsNumExprs nums-showExpr (MacroVarExpr name) = "%" ++ name-showExpr (PatVarExpr name nums) = "$" ++ name ++ unwordsNumExprs nums-showExpr WildCardExpr = "_"-showExpr (ValuePatExpr expr) = "," ++ showExpr expr-showExpr (PatVarOmitExpr name nums) = "$`" ++ name ++ unwordsNumExprs nums-showExpr (VarOmitExpr name nums) = "`" ++ name ++ unwordsNumExprs nums-showExpr (CutPatExpr _) = "#<cut-pat>"-showExpr (NotPatExpr _) = "#<not-pat>"-showExpr (AndPatExpr _) = "#<and-pat>"-showExpr (OrPatExpr _) = "#<or-pat>"-showExpr (PredPatExpr _ _) = "#<pred-pat>"-showExpr (InductiveDataExpr cons []) = "<" ++ cons ++ ">"-showExpr (InductiveDataExpr cons exprs) = "<" ++ cons ++ " " ++ unwordsExpr exprs ++ ">"-showExpr (TupleExpr _) = "[...]"-showExpr (CollectionExpr _) = "{...}"-showExpr (ArrayExpr _) = "[|...|]"-showExpr (FuncExpr _ _) =-  "(lambda [" ++ "..." ++ "] ...)"-showExpr (MacroExpr _ _) =-  "(macro [" ++ "..." ++ "] ...)"-showExpr (LoopExpr lVar iVar rExpr lExpr tExpr) =-  "(loop $" ++ lVar ++ " $" ++ iVar ++ " " ++ showExpr rExpr ++ " " ++  showExpr lExpr ++ " " ++ showExpr tExpr ++ ")"-showExpr (ParamsExpr pVar pExpr body) =-  "(loop $" ++ pVar ++ " " ++ showExpr pExpr ++ " " ++ showExpr body ++ ")"-showExpr (IfExpr condExpr expr1 expr2) =-  "(if " ++ showExpr condExpr ++ " " ++ showExpr expr1 ++ " " ++ showExpr expr2 ++ ")"-showExpr (LetExpr bindings body) =-  "(let " ++ showBindings bindings ++ " " ++ showExpr body ++ ")"-showExpr (LetRecExpr bindings body) =-  "(letrec " ++ showRecursiveBindings bindings ++ " " ++ showExpr body ++ ")"-showExpr (DoExpr bindings body) =-  "(do " ++ showBindings bindings ++ " " ++ showExpr body ++ ")"-showExpr (TypeExpr _) =-  "(type " ++ "..." ++ ")"-showExpr (MatchExpr tgtExpr typExpr _) =-  "(match " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)"-showExpr (MatchAllExpr tgtExpr typExpr _) =-  "(match-all " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)"-showExpr (GenerateArrayExpr fnExpr arrExpr) =-  "(generate-array " ++ showExpr fnExpr ++ " " ++ showExpr arrExpr ++ " )"-showExpr (ApplyExpr opExpr argExpr) =-  "(" ++ showExpr opExpr ++ " " ++ showExpr argExpr ++ ")"-showExpr SomethingExpr = "Something"-showExpr UndefinedExpr = "undefined"+fromMatcherValue :: WHNFData -> Either EgisonError Matcher+fromMatcherValue (Value (Matcher matcher)) = return matcher+fromMatcherValue val = throwError $ TypeMismatch "matcher" val ----- |Allow conversion of egisonexpr instances to strings---instance Show EgisonExpr where show = showExpr-                      -eqv :: [EgisonVal] -> ThrowsError EgisonVal-eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2-eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2-eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2-eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2-eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2-eqv [(InductiveData cons1 args1), (InductiveData cons2 args2)] =-  if (cons1 == cons2)-    then return $ Bool $ eqValList args1 args2-    else return $ Bool False-eqv [(Tuple vals1), (Tuple vals2)] = -- TODO use fold?-  return $ Bool $ eqValList vals1 vals2-eqv [(Collection vals1), (Collection vals2)] =-  return $ Bool $ eqValList vals1 vals2-eqv [_, _] = return $ Bool False-eqv badArgList = throwError $ NumArgs 2 badArgList+fromPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue+fromPrimitiveValue (Value val@(Char _)) = return val+fromPrimitiveValue (Value val@(String _)) = return val+fromPrimitiveValue (Value val@(Bool _)) = return val+fromPrimitiveValue (Value val@(Integer _)) = return val+fromPrimitiveValue (Value val@(Float _)) = return val+fromPrimitiveValue val = throwError $ TypeMismatch "primitive value" val  -eqValList :: [EgisonVal] -> [EgisonVal] -> Bool-eqValList [] [] = True-eqValList (val1:vals1) (val2:vals2) =-  if eqVal val1 val2-    then eqValList vals1 vals2-    else False-eqValList _ _ = False+--+-- Environment+-- -eqVal :: EgisonVal -> EgisonVal -> Bool-eqVal a b = do-  let result = eqv [a, b]-  case result of-    Left _ -> False-    Right (Bool val) -> val-    _ -> False -- Is this OK?+type Var = (String, [Integer])+type Env = [HashMap Var ObjectRef]+type Binding = (Var, ObjectRef) -instance Eq EgisonVal where-  x == y = eqVal x y+nullEnv :: Env+nullEnv = [] -showArray :: [Integer] -> [EgisonVal] -> String-showArray ns vals = "[|" ++ helper ns vals ++ "|]"- where helper [_] vals2 = unwordsList vals2-       helper (_:ns2) vals2 = let xss = divideList (multiplyList ns2) vals2 in-                                concat $ map (\xs -> "[~" ++ helper ns2 xs ++ "~]") xss-         where divideList :: Integer -> [a] -> [[a]]-               divideList n ls = helper2 n [] ls-                where helper2 _ ret [] = ret-                      helper2 n2 ret xs = let (hs, ts) = divideList2 n2 xs in-                                           helper2 n2 (ret ++ [hs]) ts-               divideList2 :: Integer -> [a] -> ([a], [a])-               divideList2 n xs = helper2 n [] xs-                where helper2 0 hs ts = (hs, ts)-                      helper2 n2 hs (x:ts) = helper2 (n2 - 1) (hs ++ [x]) ts+extendEnv :: Env -> [Binding] -> Env+extendEnv env = (: env) . HashMap.fromList +refVar :: Env -> Var -> EgisonM ObjectRef+refVar env var = maybe (throwError $ UnboundVariable var) return+                       (msum $ map (HashMap.lookup var) env) -showVal :: EgisonVal -> String-showVal (World _) = "#<world>"-showVal (Bool True) = "#t"-showVal (Bool False) = "#f"-showVal (Char chr) = "'" ++ [chr] ++ "'"-showVal (String str) = "\"" ++ str ++ "\""-showVal (Number contents) = show contents-showVal (Float contents) = show contents-showVal WildCard = "_"-showVal (PatVar name nums) =  "$" ++ name ++ unwordsNums nums-showVal (ValuePat _) = "#<value-pat>"-showVal (CutPat _) = "#<cut-pat>"-showVal (NotPat _) = "#<not-pat>"-showVal (AndPat _) = "#<and-pat>"-showVal (OrPat _) = "#<or-pat>"-showVal (PredPat _ _) = "#<pred-pat>"-showVal (InductiveData cons []) = "<" ++ cons ++ ">"-showVal (InductiveData cons args) = "<" ++ cons ++ " " ++ unwordsList args ++ ">"-showVal (Tuple vals) = "[" ++ unwordsList vals ++ "]"-showVal (Collection vals) = "{" ++ unwordsList vals ++ "}"-showVal (Array _ ns arr) = showArray ns $ elems arr-showVal (Type _) = "#<type>"-showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)"-showVal (Macro _ _ ) = "(macro [" ++ "..." ++ "] ...)"-showVal (PrimitiveFunc _) = "#<primitive>"-showVal (IOFunc _) = "#<IO primitive>"-showVal (Port _ _) = "#<IO port>"-showVal EOF = "#!EOF"-showVal Something = "Something"+--+-- Pattern Match+-- --- |Allow conversion of egisonval instances to strings-instance Show EgisonVal where show = showVal+data MatchingState = MState Env [Binding] [MatchingTree] ---showInnerVals :: [InnerVal] -> String---showInnerVals [] = ""---showInnerVals ((Element val):rest) = show val ++ showInnerVals' rest---showInnerVals ((SubCollection val):rest) = "@" ++ show val ++ showInnerVals' rest+data MatchingTree =+    MAtom EgisonExpr ObjectRef WHNFData+  | MNode [PatternBinding] MatchingState ---showInnerVals' :: [InnerVal] -> String---showInnerVals' [] = ""---showInnerVals' ((Element val):rest) = " " ++ show val ++ showInnerVals' rest---showInnerVals' ((SubCollection val):rest) = " @" ++ show val ++ showInnerVals' rest+type PatternBinding = (Var, EgisonExpr) -showIVal :: IntermidiateVal -> String-showIVal (IInductiveData cons []) = "<" ++ cons ++ ">"-showIVal (IInductiveData cons _) = "<" ++ cons ++ " " ++ "..." ++ ">"-showIVal (ITuple _) = "[" ++ "..." ++ "]"-showIVal (ICollection _) = "{" ++ "..." ++ "}"+--+-- Errors+-- --- |Allow conversion of egisonfixedval instances to strings-instance Show IntermidiateVal where show = showIVal+data EgisonError =+    Parser ParseError+  | UnboundVariable Var+  | TypeMismatch String WHNFData+  | ArgumentsNum Int Int+  | NotImplemented String+  | Assertion String+  | Match String+  | Desugar String+  | Default String+    +instance Show EgisonError where+  show (Parser error) = "Parse error at: " ++ show error+  show (UnboundVariable (var, nums)) = "Unbound variable: " ++ var +++                                      concatMap (('_':) . show) nums+  show (TypeMismatch expected found) = "Expected " ++  expected +++                                        ", but found: " ++ show found+  show (ArgumentsNum expected got) = "Wrong number of arguments: expected " +++                                     show expected ++ ", but got " ++  show got+  show (NotImplemented message) = "Not implemented: " ++ message+  show (Assertion message) = "Assertion failed: " ++ message+  show (Desugar message) = "Error: " ++ message+  show (Default message) = "Error: " ++ message -showObj :: Object -> String-showObj (Closure _ expr) = "(Closure env " ++  showExpr expr ++ ")"-showObj (Value val) = "(Value " ++ show val ++ ")"-showObj (Intermidiate val) = "(Intermidiate " ++ show val ++ ")"-showObj (Loop _ _ _ _ _) = "#<loop>"+instance Error EgisonError where+  noMsg = Default "An error has occurred"+  strMsg = Default --- |Allow conversion of egison object instances to strings-instance Show Object where show = showObj+liftError :: (MonadError e m) => Either e a -> m a+liftError = either throwError return -showFrameList :: FrameList -> String-showFrameList [] = "{}"-showFrameList (((name,nums),_):rest) = "{[" ++ name ++ unwordsNums nums ++ ": _]" ++ loop rest- where loop [] = "}"-       loop (((name2,nums2),_):rest2) = " [" ++ name2 ++ unwordsNums nums2 ++ ": _]" ++ loop rest2+--+-- Monads+-- --- - utility-stringToCharCollection :: String -> IO EgisonVal-stringToCharCollection = undefined+newtype EgisonM a = EgisonM {+    unEgisonM :: ErrorT EgisonError IO a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError) +runEgisonM :: EgisonM a -> IO (Either EgisonError a)+runEgisonM = runErrorT . unEgisonM +type MatchM = MaybeT EgisonM +matchFail :: MatchM a+matchFail = MaybeT $ return Nothing +data MList m a = MNil | MCons a (m (MList m a))   +fromList :: Monad m => [a] -> MList m a+fromList = foldr f MNil+ where f x xs = MCons x $ return xs ---- extra+fromMList :: Monad m => MList m a -> m [a]+fromMList = mfoldr f $ return []+ where f x xs = xs >>= return . (x:) -nth :: Integer -> [a] -> a-nth 1 (x:xs) = x-nth n (x:xs) = nth (n - 1) xs+msingleton :: Monad m => a -> MList m a+msingleton = flip MCons $ return MNil -integersToInteger :: [Integer] -> [Integer] -> Integer-integersToInteger [_] [n] = n-integersToInteger (_:ms) (n:ns) = (n - 1) * (multiplyList ms) + integersToInteger ms ns+mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b+mfoldr f init MNil = init+mfoldr f init (MCons x xs) = f x (xs >>= mfoldr f init) -multiplyList :: [Integer] -> Integer-multiplyList [n] = n-multiplyList (n:ns) = n * (multiplyList ns)+mappend :: Monad m => MList m a -> m (MList m a) -> m (MList m a)+mappend xs ys = mfoldr ((return .) . MCons) ys xs -indexList :: [Integer] -> [[Integer]]-indexList [m] = map (\i -> [i]) $ betweenNumbers 1 m-indexList (m:ms) = concat $ map (\n -> map (\is -> n:is) $ indexList ms)-                                (betweenNumbers 1 m)+mconcat :: Monad m => MList m (MList m a) -> m (MList m a)+mconcat = mfoldr mappend $ return MNil -betweenNumbers :: Integer -> Integer -> [Integer]-betweenNumbers m n = if m == n-                       then [n]-                       else (m:(betweenNumbers (m + 1) n))+mmap :: Monad m => (a -> m b) -> MList m a -> m (MList m b)+mmap f = mfoldr g $ return MNil+ where g x xs = f x >>= return . flip MCons xs +mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b)+mfor = flip mmap -tupleToList :: EgisonVal -> [EgisonVal]-tupleToList (Tuple vals) = vals-tupleToList val = [val]

@@ -1,126 +0,0 @@-module Language.Egison.Variables where-import Language.Egison.Types-import Control.Monad.Error-import Data.IORef-import qualified Data.Map---- |Show the contents of an environment-printEnv :: Env         -- ^Environment-         -> IO String   -- ^Contents of the env as a string-printEnv env = do-  bindings <- liftIO $ readIORef $ topFrameRef env-  l <- mapM showBind $ Data.Map.toList bindings -  return $ unlines l- where -  showBind ((name, nums), objRef) = do-    obj <- liftIO $ readIORef objRef-    return $ name ++ unwordsNums nums ++ ": " ++ show obj---- |Create a copy of an environment-copyEnv :: Env      -- ^ Source environment-        -> IO Env   -- ^ A copy of the source environment-copyEnv env = do-  bindings <- liftIO $ readIORef $ topFrameRef env-  bindingListT <- mapM addBinding $ Data.Map.toList bindings-  bindingList <- newIORef $ Data.Map.fromList bindingListT-  return $ Environment (parentEnv env) bindingList- where addBinding (var, val) = do --ref <- newIORef $ liftIO $ readIORef val-                                  x <- liftIO $ readIORef val-                                  ref <- newIORef x-                                  return (var, ref)---- |Extend given environment by binding a series of values to a new environment.-extendEnv :: Env -- ^ Environment-          -> [(Var, ObjectRef)] -- ^ Extensions to the environment-          -> IO Env -- ^ Extended environment-extendEnv env abindings = do bindinglist <- newIORef $ Data.Map.fromList abindings-                             return $ Environment (Just env) bindinglist--makeLetRecFrame :: Env-                -> [(String, EgisonExpr)]-                -> IO FrameRef-makeLetRecFrame env abindings = do-  newEnv <- extendLetRec env abindings-  return $ topFrameRef newEnv-                             --- |Extend given environment by binding a series of values to a new environment for letrec.-extendLetRec :: Env -- ^ Environment -             -> [(String, EgisonExpr)] -- ^ Extensions to the environment-             -> IO Env -- ^ Extended environment-extendLetRec env abindings = do-  bindinglistT <- (mapM addDummyBinding abindings) -- >>= newIORef-  bindinglist <- newIORef $ Data.Map.fromList $ map (\(name,objRef) -> ((name,[]),objRef)) bindinglistT-  let newEnv = Environment (Just env) bindinglist-  mapM (replaceWithNewEnv newEnv) bindinglistT-  return newEnv- where addDummyBinding (name, expr) = do dummy <- nullEnv-                                         objRef <- makeClosure dummy expr-                                         return (name, objRef)-       replaceWithNewEnv newEnv (_, objRef) = do obj <- readIORef objRef-                                                 case obj of-                                                   Closure _ cExpr -> writeIORef objRef (Closure newEnv cExpr)---- |Recursively search environments to find one that contains the given variable.-findEnv -    :: Env      -- ^Environment to begin the search; -                --  parent env's will be searched as well.-    -> Var      -- ^Variable-    -> IO (Maybe Env) -- ^Environment, or Nothing if there was no match.-findEnv envRef var = do-  found <- liftIO $ isBound envRef var-  if found-     then return (Just envRef)-     else case parentEnv envRef of-               (Just par) -> findEnv par var-               Nothing -> return Nothing---- |Determine if a variable is bound-isBound -    :: Env      -- ^ Environment-    -> Var   -- ^ Variable-    -> IO Bool  -- ^ True if the variable is bound-isBound envRef var = -    (readIORef $ topFrameRef envRef) >>= return . Data.Map.member var---- |Determine if a variable is bound---  or a parent of the given environment.-isRecBound -    :: Env      -- ^ Environment-    -> Var   -- ^ Variable-    -> IO Bool  -- ^ True if the variable is bound-isRecBound envRef var = do-  env <- findEnv envRef var-  case env of-    (Just e) -> isBound e var-    Nothing -> return False--getVarFromFrame :: Frame -> Var -> IOThrowsError ObjectRef-getVarFromFrame frame var = do-  case Data.Map.lookup var frame of-    (Just a) -> return a-    Nothing -> throwError $ UnboundVar "Getting an unbound variable" (showVar var)-    --- |Retrieve the value of a variable defined-getVar :: Env     -- ^ Environment-       -> Var  -- ^ Variable-       -> IOThrowsError ObjectRef -- ^ Contents of the variable-getVar envRef-       var = do binds <- liftIO $ readIORef $ topFrameRef envRef-                case Data.Map.lookup var binds of-                  (Just a) -> return a-                  Nothing -> case parentEnv envRef of-                               (Just par) -> getVar par var-                               Nothing -> (throwError $ UnboundVar "Getting an unbound variable" (showVar var))---- |Bind a variable-defineVar-    :: Env      -- ^ Environment -    -> Var   -- ^ Variable-    -> ObjectRef  -- ^ Value-    -> IOThrowsError ()   -- ^ Result-defineVar envRef-          var objRef = do-  liftIO $ do-    env <- readIORef $ topFrameRef envRef-    writeIORef (topFrameRef envRef) (Data.Map.insert var objRef env)-    return ()

@@ -1,55 +0,0 @@-(define $product-  (letrec -    {[$subproduct (lambda [$xs $ys]-                    (match xs (List Something)-                      {[<nil> {}]-                       [<cons $z $zs> {@(map (lambda [$y] {z @y}) ys) @(subproduct zs ys)}]}))]}-    (lambda [$xs]-      (match xs (List Something)-        {[<nil> {}]-         [<cons $y <nil>> (map (lambda [$z] {z}) y)]-         [<cons $y $ys> (subproduct y (product ys))]}))))--(define $COC-  (lambda [$a $b] ;; a : collection-type   b : contents-type   see. an example below-    (type-      {[,$val []-        {[$tgt (match tgt (List (a b))-                 {[,val {[]}]-                  [_ {}]})]}]-       [<nil> [] ;; nil when some contents is nil-        {[$tgt (letrec-                 {[$helper (lambda [$xs]-                             (match xs (List Something)-                               {[<nil> {}]-                                [<cons $y $ys> (match y [(a b)]-                                                 {[<nil> {[]}]-                                                  [_ (helper ys)]})]}))]}-                 (helper tgt))]}]-       [<cons ,$xs _> [(COC a b)]-        {[$tgt (letrec-                 {[$helper (lambda [$xs $ys]-                             (match [xs ys] [(List Something) (List Something)]-                               {[[<nil> <nil>] {}]-                                [[<cons $x $xs> <cons $y $ys>] {(match-all y [(a b)] [<cons ,x $xs> xs]) @(helper xs ys)}]}))]}-                 (product (helper xs tgt)))]}]-       [<cons _ _> [(List b) (COC a b)]-        {[$tgt (letrec-                 {[$helper (lambda [$xs]-                             (match xs (List Something)-                               {[<nil> {}]-                                [<cons $y $ys> {(match-all y [(a b)] [<cons $z $zs> [z zs]]) @(helper ys)}]}))]-                  [$lt2tl (lambda [$xs]-                            (match xs (List [Something Something])-                              {[<nil> [{} {}]]-                               [<cons [$y $z] $ys> (let {[[$p $q] (lt2tl ys)]} [{y @p} {z @q}])]}))]}-                 (map lt2tl (product (helper tgt))))]}]-       [_ [Something]-        {[$tgt {tgt}]}]})))---;; (define $n-queen-;;   (lambda [$n]-;;    (match-all {(between 1 n) (between 2 (* 2 n)) (between (- 1 n) (- n 1))} (COC Multiset Integer)-;;      [(loop $l $i (between 1 n) <cons <cons $a_i ,{(+ a_i i) (- a_i i)}> l> <nil>)-;;       (loop $l $i (between 1 n) {a_i @l} {})])))

@@ -1,88 +0,0 @@-;;-;; Array.egi-;;--(define $Array-  (lambda [$a]-    (type-      {[<cons ,$key ,$val> []-        {[$arr (if (and (array-range? key arr)-                        ((= a) (array-ref key arr) val))-                   {[]}-                   {})]}]-       [<cons ,$key _> [a]-        {[$arr (if (array-range? key arr)-                   {[(array-ref key arr)]}-                   {})]}]-       [_ [Something]-        {[$tgt {[tgt]}]}]-       })))--(define $range-to-keys-  (lambda $ms-    (letrec {[$range-to-keys2-              (lambda [$ms]-                (match ms (List Integer)-                  {[<nil> {{}}]-                   [<cons $n $ns>-                    (let {[$iss (range-to-keys2 ns)]}-                      (concat (map (lambda [$i]-                                     (map (lambda [$is] {i @is})-                                          iss))-                                   (between 1 n))))]}))]}-      (map collection-to-tuple (range-to-keys2 (tuple-to-collection ms))))))--(define $keys-for-display-  (lambda [$mx $my]-    (let {[$xs (between 1 mx)]-          [$ys (reverse (between 1 my))]}-      (map (lambda [$y]-             (map (lambda [$x] [x y])-                  xs))-           ys))))--(define $find-from-value-  (lambda [$a]-    (lambda [$val $arr]-      (let {[$keys (array-keys arr)]}-        (letrec {[$helper (lambda [$keys]-                            (if ((= a) (array-ref (car keys) arr) val)-                                (car key)-                                (helper (cdr keys))))]}-          (helper keys))))))--(define $find-all-from-value-  (lambda [$a]-    (lambda [$val $arr]-      (let {[$keys (array-keys arr)]}-        (letrec {[$helper (lambda [$keys $ret]-                            (match keys (List Something)-                              {[<nil> ret]-                               [<cons $key $rest>-                                (if ((= a) (array-ref key arr) val)-                                    (helper rest {@ret val})-                                    (helper rest ret))]}))]}-          (helper keys {}))))))--(define $find-from-value-with-pattern-  (lambda [$a]-    (lambda [$pat $arr]-      (let {[$keys (array-keys arr)]}-        (letrec {[$helper (lambda [$keys]-                            (match (array-ref (car keys) arr) a-                              {[pat (car keys)]-                               [_ (helper (cdr keys))]}))]}-          (helper keys))))))--(define $find-all-from-value-with-pattern-  (lambda [$a]-    (lambda [$pat $arr]-      (let {[$keys (array-keys arr)]}-        (letrec {[$helper (lambda [$keys $ret]-                            (match keys (List Something)-                              {[<nil> ret]-                               [<cons $key $rest>-                                (match (array-ref key arr) a-                                  {[pat (helper rest {@ret val})]-                                   [_ (helper rest ret)]})]}))]}-          (helper keys {}))))))

@@ -2,78 +2,70 @@ ;; Base.egi ;; -(define $Bool-  (type+(define $bool+  (matcher     {[,$val []-      {[$tgt (if (and (or (not val) tgt) (or val (not tgt)))+      {[$tgt (if (eq? val tgt)                  {[]}                  {})]}]-     [<true> []-      {[<true> {[]}]-       [#t {[]}]-       [_ {}]}]-     [<false> []-      {[<false> {[]}]-       [#f {[]}]-       [_ {}]}]-     [_ [Something]+     [$ [something]       {[$tgt {tgt}]}]      }))  (define $or   (lambda [$b1 $b2]-    (match b1 Bool-      {[<true> #t]-       [<false> b2]})))+    (if b1+        #t+        b2)))  (define $and   (lambda [$b1 $b2]-    (match b1 Bool-      {[<true> b2]-       [<false> #f]})))+    (if b1+        b2+        #f)))  (define $not   (lambda [$b]-    (match b Bool-      {[<true> #f]-       [<false> #t]})))+    (match b bool+      {[,#t #f]+       [,#f #t]}))) -(define $Char-  (type+(define $char+  (matcher     {[,$c []-      {[$tgt (if (eq-c? tgt c)+      {[$tgt (if (eq? tgt c)                  {[]}                  {})]}]-     [_ [Something]+     [_ [something]       {[$tgt {tgt}]}]      })) -(define $String-  (type+(define $string+  (matcher     {[,$s []-      {[$tgt (if (eq-s? tgt s)+      {[$tgt (if (eq? tgt s)                  {[]}                  {})]}]-     [_ [Something]+     [_ [something]       {[$tgt {tgt}]}]      })) -(define $Order-  (type+(define $ordering+  (matcher     {[,$val []       {[$tgt (if (eq? val tgt)                  {[]}                  {})]}]      [<less> []-      {[<less> {[]}]+      {[<Less> {[]}]        [_ {}]}]      [<equal> []-      {[<equal> {[]}]+      {[<Equal> {[]}]        [_ {}]}]      [<greater> []-      {[<greater> {[]}]+      {[<Greater> {[]}]        [_ {}]}]-     [_ [Something]+     [_ [something]       {[$tgt {tgt}]}]      })) @@ -83,8 +75,3 @@       (match x a         {[,y #t]          [_ #f]}))))--(define $=-  (lambda [$a]-    (lambda [$x $y]-      (and ((match? a) x y) ((match? a) y x)))))

@@ -2,85 +2,76 @@ ;; Collection.egi ;; -(define $List+(define $list   (lambda [$a]-    (type+    (matcher       {[,$val []-        {[$tgt (match [val tgt] [(List a) (List a)]+        {[$tgt (match [val tgt] [(list a) (list a)]                  {[[<nil> <nil>] {[]}]                   [[<cons $x $xs> <cons ,x ,xs>] {[]}]                   [[_ _] {}]})]}]        [<nil> []         {[{} {[]}]          [_ {}]}]-       [<cons _ _> [a (List a)]-        {[{$x .$xs} {[x xs]}]+       [<cons $ $> [a (list a)]+        {[{$x @$xs} {[x xs]}]          [_ {}]}]-       [<snoc _ _> [a (List a)]-        {[{.$xs $x} {[x xs]}]+       [<snoc $ $> [a (list a)]+        {[{@$xs $x} {[x xs]}]          [_ {}]}]-       [<join ,$pxs _> [(List a)]+       [<join ,$pxs $> [(list a)]         {[$tgt (letrec {[$helper (lambda [$pxs $tgt]-                                   (match [pxs tgt] [(List a) (List a)]+                                   (match [pxs tgt] [(list a) (list a)]                                      {[[<nil> _] {tgt}]                                       [[<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 {[$helper (lambda [$xs $ys]-				   (match ys (List a)-				     {[<nil> {[xs {}]}]-				      [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}-		 (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 {[$helper (lambda [$xs $ys]-				   (match ys (List a)-				     {[<nil> {[{} xs]}]-				      [<cons $z $zs> {[ys xs] @(helper {@xs z} zs)}]}))]}-		 (helper {} tgt))]}]-       [_ [Something]+       [<join $ $> [(list a) (list a)]+        {[$tgt (letrec {[$helper (lambda [$xs $ys]+                                   (match ys (list a)+                                     {[<nil> {[xs {}]}]+                                      [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}+                 (helper {} tgt))]}]+       [<nioj ,$pxs $> [(list a)]+        {[$tgt (match-all tgt (list a) [<join $ys ,pxs> ys])]}]+       [<nioj $ $> [(list a) (list a)]+        {[$tgt (letrec {[$helper (lambda [$xs $ys]+                                   (match ys (list a)+                                     {[<nil> {[{} xs]}]+                                      [<cons $z $zs> {[ys xs] @(helper {@xs z} zs)}]}))]}+                 (helper {} tgt))]}]+       [$ [something]         {[$tgt {tgt}]}]        })))  (define $map   (lambda [$fn $ls]-    (match ls (List Something)+    (match ls (list something)       {[<nil> {}]        [<cons $x $xs> {(fn x) @(map fn xs)}]}))) -(define $map&concat+(define $map-and-concat   (lambda [$fn $ls]-    (match ls (List Something)+    (match ls (list something)       {[<nil> {}]-       [<cons $x $xs> {@(fn x) @(map&concat fn xs)}]})))+       [<cons $x $xs> {@(fn x) @(map-and-concat fn xs)}]})))  (define $foldr   (lambda [$fn $init $ls]-    (match ls (List Something)+    (match ls (list something)       {[<nil> init]        [<cons $x $xs> (fn x (foldr fn init xs))]})))  (define $foldl   (lambda [$fn $init $ls]-    (match ls (List Something)+    (match ls (list something)       {[<nil> init]        [<cons $x $xs> (let {[$y (fn init x)]}                         (foldl fn y xs))]})))  (define $filter   (lambda [$pred $ls]-    (match ls (List Something)+    (match ls (list something)       {[<nil> {}]        [<cons $x $xs>         (if (pred x)@@ -90,7 +81,7 @@ (define $remove   (lambda [$a]     (lambda [$xs $x]-      (match xs (List a)+      (match xs (list a)         {[<nil> {}]          [<cons ,x $rs> rs]          [<cons $y $rs> {y @((remove a) rs x)}]}))))@@ -98,7 +89,7 @@ (define $remove-all   (lambda [$a]     (lambda [$xs $x]-      (match xs (List a)+      (match xs (list a)         {[<nil> {}]          [<cons ,x $rs> ((remove-all a) rs x)]          [<cons $y $rs> {y @((remove-all a) rs x)}]}))))@@ -106,222 +97,174 @@ (define $remove-collection   (lambda [$a]     (lambda [$xs $ys]-      (match ys (List a)+      (match ys (list a)         {[<nil> xs]          [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))  (define $add-  (lambda [$a]-    (lambda [$xs $x]-      (if ((member? Integer) x xs)-          xs-          {@xs x}))))+  (lambda [$xs $x]+    (if (member? x xs)+        xs+        {@xs x})))  (define $union-  (lambda [$a]-    (lambda [$xs $ys]-      (match ys (List a)-        {[<nil> xs]-         [<cons $y $rs> ((union a) ((add a) xs y) rs)]}))))+  (lambda [$xs $ys]+    (match ys (list something)+      {[<nil> xs]+       [<cons $y $rs> ((union a) ((add a) xs y) rs)]})))  (define $occurrence-  (lambda [$a]-    (lambda [$xs]-      (letrec-	{[$remove&count (lambda [$x $xs]-			  (match xs (List a)-			    {[<nil> [{} 1]]-			     [<cons ,x $ys> (let {[[$r $i] (remove&count x ys)]}-					      [r (+ i 1)])]-			     [<cons $y $ys> (let {[[$r $i] (remove&count x ys)]}-					      [{y @r} i])]}))]}-	(match xs (List Something)-	  {[<nil> {}]-	   [<cons $x $ys> (let {[[$rs $i] (remove&count x ys)]}-			    {[x i] @((occurrence a) rs)})]})))))+  (lambda [$xs]+    (letrec {[$remove-and-count+              (lambda [$x $xs]+                (match xs (list something)+                  {[<nil> [{} 1]]+                   [<cons ,x $ys> (let {[[$r $i] (remove-and-count x ys)]}+                                    [r (+ i 1)])]+                   [<cons $y $ys> (let {[[$r $i] (remove-and-count x ys)]}+                                    [{y @r} i])]}))]}+      (match xs (list something)+        {[<nil> {}]+         [<cons $x $ys> (let {[[$rs $i] (remove-and-count x ys)]}+                          {[x i] @(occurrence rs)})]}))))  (define $subcollections-  (lambda [$a]-    (lambda [$xs]-      (foldr-	     (lambda [$x $rs]-	       (let {[[$y $i] x]} -		 (map&concat (lambda [$sub] -			       (match-all (loop $l $j (between 1 i) {y @l} {}) (List a) [<join $ys _> {@ys @sub}]))-			     rs)))-	     {{}}-	     ((occurrence a) xs)))))-+  (lambda [$xs]+    (foldr (lambda [$x $rs]+             (let {[[$y $i] x]} +               (map-and-concat (lambda [$sub] +                                 (match-all (loop $l $j (between 1 i) {y @l} {}) (list something)+                                   [<join $ys _> {@ys @sub}]))+                               rs)))+           {{}}+           ((occurrence a) xs))))  (define $size   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<nil> 0]        [<cons _ $rs> (+ 1 (size rs))]})))  (define $car   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<cons $x _> x]})))  (define $cdr   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<cons _ $ys> ys]})))  (define $rac   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<snoc $x _> x]})))  (define $rdc   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<snoc _ $ys> ys]}))) -(define $nth (lambda [$i $l]-               (match l (List Something) {[<cons $x $xs> (if (eq? i 0) x (nth (- i 1) xs))]})))+(define $nth+  (lambda [$i $l]+    (match l (list something)+      {[<cons $x $xs> (if (eq? i 0) x (nth (- i 1) xs))]}))) +(define $take+  (lambda [$n $xs]+    (if (eq? n 0)+        {}+        (match xs (list something)+          {[<cons $x $xs> {x @(take (- n 1) xs)}]+           [<nil> {}]}))))++(define $drop+  (lambda [$n $xs]+    (if (eq? n 0)+        xs+        (match xs (list something)+          {[<cons _ $xs> (drop (- n 1) xs)]+           [<nil> {}]}))))+ (define $reverse   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<nil> {}]        [<cons $x $rs>         {@(reverse rs) x}]})))  (define $member?-  (lambda [$a]-    (lambda [$x $ys]-      (match ys (List a)-        {[<nil> #f]-         [<cons ,x $ys> #t]-         [<cons $y $ys> ((member? a) x ys)]}))))+  (lambda [$x $ys]+    (match ys (list something)+      {[<nil> #f]+       [<cons ,x $ys> #t]+       [<cons $y $ys> ((member? a) x ys)]})))  (define $unique-  (lambda [$a]-    (lambda [$xs]-      (letrec {[$loop-fn (lambda [$xs $ys]-                           (match xs (List a)-                             {[<nil> ys]-                              [<cons $x $rs>-                               (if ((member? a) x ys)-                                   (loop-fn rs ys)-                                   (loop-fn rs {@ys x}))]}))]}-        (loop-fn xs {})))))+  (lambda [$xs]+    (letrec {[$loop-fn+              (lambda [$xs $ys]+                (match xs (list something)+                  {[<nil> ys]+                   [<cons $x $rs>+                    (if (member? x ys)+                        (loop-fn rs ys)+                        (loop-fn rs {@ys x}))]}))]}+      (loop-fn xs {}))))  (define $subcollection?-  (lambda [$a]-    (lambda [$xs $ys]-      (match xs (List a)-        {[<nil> #t]-         [<cons $x $rest>-          (if ((member? a) x ys)-              ((subcollection? a) rest ys)-              #f)]}))))+  (lambda [$xs $ys]+    (match xs (list something)+      {[<nil> #t]+       [<cons $x $rest>+        (if (member? x ys)+            (subcollection? rest ys)+            #f)]})))  (define $concat   (lambda [$xs]-    (match xs (List Something)+    (match xs (list something)       {[<nil> {}]        [<cons $x $rs> {@x @(concat rs)}]}))) -(define $Multiset+(define $multiset   (lambda [$a]-    (type+    (matcher       {[,$val []-        {[$tgt (match [val tgt] [(List a) (Multiset a)]+        {[$tgt (match [val tgt] [(list a) (multiset a)]                  {[[<nil> <nil>] {[]}]-		  [[<cons $x $xs> <cons ,x ,xs>] {[]}]-		  [[_ _] {}]})]}]-       [<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons ,$px _> [(Multiset a)]-        {[$tgt (if ((member? a) px tgt)-		   {((remove a) tgt px)}-		   {})]}]-       [<cons _ _> [a (Multiset a)]-        {[$tgt (letrec {[$helper (lambda [$xs $ys]-				   (match ys (List a)-				     {[<nil> {}]-				      [<cons $z $zs> (if ((member? a) z xs)-							 (helper {@xs z} zs)-							 {[z {@xs @zs}] @(helper {@xs z} zs)})]}))]}-		 (helper {} tgt))]}]-       [<join ,$pxs _> [(Multiset a)]-        {[$tgt (letrec {[$helper (lambda [$xs $ys]-				   (match xs (List Something)-				     {[<nil> ys]-				      [<cons $z $zs> (if ((member? a) z ys)-							 (helper zs ((remove a) ys z))-							 {})]}))]}-		 {(helper pxs tgt)})]}]-;;	   [<join _ ,$pys> [(Multiset a)]-;;        {[$tgt (match-all tgt (Multiset a) [<join ,pys $xs> xs])]}]-       [<join _ _> [(Multiset a) (Multiset a)]-	{[$tgt-	  (foldr-		 (lambda [$xi $xs]-		   (let {[[$x $i] xi]}-		     (map&concat-				 (lambda [$sub] -				   (do {[[$ys $zs] sub]-					[$zs ((remove-all a) zs x)]}-				     (match-all (loop $l $j (between 1 i) {x @l} {}) (List a) [<join $us $vs> [{@us @ys} {@zs @vs}]])))-				 xs)))-		 {[{} tgt]}-		 ((occurrence a) tgt))]}]-       [_ [Something]-        {[$tgt {tgt}]}]-       })))--(define $Set-  (lambda [$a]-    (type-      {[,$val []-        {[$tgt (if ((= (Multiset a)) ((unique a) val) ((unique a) tgt))-                   {[]}-                   {})]}]+                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]+                  [[_ _] {}]})]}]        [<nil> []         {[{} {[]}]          [_ {}]}]-       [<cons ,$px _> [(Set2 a)]-        {[$tgt (let {[$tgt2 ((unique a) tgt)]}-                 (if ((member? a) px tgt)-		     {tgt}-		     {}))]}]-       [<cons _ _> [a (Set2 a)]-        {[$tgt (let {[$tgt2 ((unique a) tgt)]}-                 (match-all tgt2 (Multiset a)-                   [<cons $x _> [x tgt2]]))]}]-       [<join _ _> [(Set2 a) (Set2 a)]-        {[$tgt (let {[$tgt2 ((unique a) tgt)]}-                 (match-all tgt2 (Multiset a)-                   [<join $xs _> [xs tgt2]]))]}]-       [_ [Something]+       [<cons ,$px $> [(multiset a)]+        {[$tgt (match tgt (list a)+                 {[<join $hs <cons ,px $ts>> {{@hs @ts}}]+                  [_ {}]})]}]+       [<cons $ $> [a (multiset a)]+        {[$tgt (match-all tgt (list a)+                 [<join $hs <cons $x $ts>> [x {@hs @ts}]])]}]+       [<join ,$pxs $> [(multiset a)]+        {[$tgt {((remove-collection a) tgt pxs)}]}]+       [$ [something]         {[$tgt {tgt}]}]        }))) -(define $Set2 ; handle already uniqued target collection+(define $set   (lambda [$a]-    (type-      {[,$val []-        {[$tgt (if ((= (Multiset a)) ((unique a) val) tgt)-                   {[]}-                   {})]}]+    (matcher+      {        [<nil> []         {[{} {[]}]          [_ {}]}]-       [<cons ,$px _> [(Set a)]-        {[$tgt (if ((member? a) px tgt)-		   {tgt}-		   {})]}]-       [<cons _ _> [a (Set a)]-        {[$tgt (match-all tgt (Multiset a)-                 [<cons $x _> [x tgt]])]}]-       [<join _ _> [(Set a) (Set a)]-        {[$tgt (match-all tgt (Multiset a)-                 [<join $xs _> [xs tgt]])]}]-       [_ [Something]+       [<cons ,$px $> [(set a)]+        {[$tgt (match tgt (list a)+                 {[<join _ <cons ,px _>> {tgt}]+                  [_ {}]})]}]+       [<cons $ $> [a (set a)]+        {[$tgt (match-all tgt (list a)+                 [<join _ <cons $x _>> [x tgt]])]}]+       [$ [something]         {[$tgt {tgt}]}]        })))

@@ -1,111 +1,111 @@-(define $Integer-  (type+(define $integer+  (matcher     {      [,$n []-      {[$tgt (if (eq-n? tgt n)+      {[$tgt (if (eq? tgt n)                  {[]}                  {})]}]-     [_ [Something]+     [$ [something]       {[$tgt {tgt}]}]      }))  (define $compare-integer   (lambda [$m $n]-    (if (lt-n? m n)-        <less>-        (if (eq-n? m n)-            <equal>-            <greater>))))+    (if (lt? m n)+        <Less>+        (if (eq? m n)+            <Equal>+            <Greater>)))) -(define $Float-  (type+(define $float+  (matcher     {[,$d []-      {[$tgt (if (eq-f? tgt d)+      {[$tgt (if (eq? tgt d)                  {[]}                  {})]}]-     [_ [Something]+     [$ [something]       {[$tgt {tgt}]}]      }))  (define $compare-float   (lambda [$d1 $d2]-    (if (lt-f? d1 d2)-        <less>-        (if (eq-f? d1 d2)-            <equal>-            <greater>))))+    (if (lt? d1 d2)+        <Less>+        (if (eq? d1 d2)+            <Equal>+            <Greater>)))) -(define $Nat-  (type+(define $nat+  (matcher     {[,$n []-      {[$tgt (if (eq-n? tgt n)+      {[$tgt (if (eq? tgt n)                  {[]}                  {})]}]      [<o> []       {[0 {[]}]        [_ {}]}]-     [<s _> Nat-      {[$tgt (match (compare-integer tgt 0) Order+     [<s $> nat+      {[$tgt (match (compare-integer tgt 0) ordering                {[<greater> {(- tgt 1)}]                 [_ {}]})]}]-     [_ [Something]+     [$ [something]       {[$tgt {tgt}]}]      }))  (define $between   (lambda [$m $n]-    (match (compare-integer m n) Order+    (match (compare-integer m n) ordering       {[<less> {m @(between (+ m 1) n)}]        [<equal> {n}]        [<greater> {}]})))  (define $min   (lambda [$ns]-    (match ns (List Integer)+    (match ns (list integer)       {[<cons $n <nil>> n]        [<cons $n $rs>         (let {[$r (min rs)]}-          (match (compare-integer n r) Order+          (match (compare-integer n r) ordering             {[<less> n]              [_ r]}))]})))  (define $max   (lambda [$ns]-    (match ns (List Integer)+    (match ns (list integer)       {[<cons $n <nil>> n]        [<cons $n $rs>         (let {[$r (max rs)]}-          (match (compare-integer n r) Order+          (match (compare-integer n r) ordering             {[<greater> n]              [_ r]}))]}))) -(define $min&max+(define $min-and-max   (lambda [$ns]-    (match ns (List Integer)+    (match ns (list integer)       {[<cons $n <nil>> [n n]]        [<cons $n $rs>-        (let {[[$min-n $max-n] (min&max rs)]}-          (match (compare-integer n min-n) Order+        (let {[[$min-n $max-n] (min-and-max rs)]}+          (match (compare-integer n min-n) ordering             {[<less> [n max-n]]-             [_ (match (compare-integer n max-n) Order+             [_ (match (compare-integer n max-n) ordering                   {[<greater> [min-n n]]                    [_ [min-n max-n]]})]}))]})))  (define $gcd   (lambda [$ns]-    (match ns (Set Integer)+    (match ns (set integer)       {[<cons $n <nil>> n]        [<cons (& ,(min ns) $m)               $rs>-        (gcd {m @((remove-all Integer)-                    (map (lambda [$r] (mod r m))-                         rs)-                    0)})]})))+        (gcd {m @((remove-all integer)+                                       (map (lambda [$r] (mod r m))+                                            rs)+                                       0)})]})))  (define $fib   (lambda [$n]     (letrec {[$fib1 (lambda [$n $ret1 $ret2]-                      (match n Nat+                      (match n nat                         {[<o> ret2]                          [<s <o>> ret1]                          [<s $n1> (fib1 (- n 1) (+ ret1 ret2) ret1)]@@ -116,19 +116,18 @@ (define $fact   (lambda [$n]     (letrec {[$fact1 (lambda [$n $ret]-                       (match n [Nat]+                       (match n [nat]                          {[<o> ret]                           [<s $n1> (fact1 n1 (* n ret))]}))]}       (fact1 n 1)))) -(define $Mod+(define $mod   (lambda [$m]-    (type+    (matcher       {[,$n []-        {[$tgt (if (eq-n? (mod tgt m) (mod n m))+        {[$tgt (if (eq? (modulo tgt m) (modulo n m))                    {[]}                    {})]}]-       [_ [Something]-	{[$tgt {(mod tgt m)}]}]+       [$ [something]+        {[$tgt {(modulo tgt m)}]}]        })))-

@@ -2,18 +2,14 @@ ;; Pattern.egi ;; -(define $n-cons-  (macro [$n $v]-    (loop $l $i (between 1 n) <cons $`v_i l> _)))--(define $comb-  (macro [$n $v]-    (loop $l $i (between 1 n) <join _ <cons $`v_i l>> _)))+;(define $n-cons+;  (lambda [$n $v]+;    (loop $l $i (between 1 n) <cons $`v_i l> _))) -(define $comb/double-  (macro [$n $v]-    (loop $l $i (between 1 n) <join _ (& <cons $`v_i _> l)> _)))+;(define $comb+;  (lambda [$n $v]+;    (loop $l $i (between 1 n) <join _ <cons $`v_i l>> _))) -(define $cloop-  (macro [$n $v]-    (loop $l $i (between 1 n) {`v_i @l} {})))+;(define $comb/duplicate+;  (lambda [$n $v]+;    (loop $l $i (between 1 n) <join _ (& <cons $`v_i _> l)> _)))

@@ -1,56 +0,0 @@-;;;-;;; graph.egi-;;;--(define $Node Integer)--(define $NodeInfo-  (type-    {[,$val []-      {[$tgt (match [val tgt] [NodeInfo NodeInfo]-               {[[<node $n $in $out> <node ,n ,in ,out>] {[]}]-                [[_ _] {}]})]}]-     [<node _ _ _> [Node (Multiset Node) (Multiset Node)]-      {[<node $n $in $out> {[n in out]}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $all-paths-  (lambda [$g $s $e]-    (let {[$n (size g)]}-      (match-all g Graph-        [(| <cons <node ,s <cons ,e _> _> $rest>-            <cons <node ,s <cons $a_2 _> _>-                  (loop $l $i (between 3 (- n 1))-                        (| <cons <node ,a_(- i 1) <cons ,e _> _> $rest>-                           <cons <node ,a_(- i 1) <cons $a_i _> _> l>)-                        <cons <node ,a_(- n 1) <cons ,e _> $rest>>)>)-         [{s @(loop $l $i (between 2 (- n (size rest))) {a_i @l} {e})}]]))))--(define $Graph (Multiset NodeInfo))--(define $hamilton-cycle-  (lambda [$g]-    (let {[$n (size g)]}-      (match-all g Graph-        [<cons <node $a_1 <cons $a_2 _> _>-               (loop $l $i (between 3 n)-                     <cons <node ,a_(- i 1) <cons $a_i _> _>-                           l>-                     <cons <node ,a_n <cons ,a_1 _> _>-                           _>)>-         (loop $l $i (between 1 n) {a_i @l} {})]))))--(define $hamilton-path-  (lambda [$g]-    (let {[$n (size g)]}-      (match-all g Graph-        [<cons <node $a_1 <cons $a_2 _> _>-               (loop $l $i (between 3 n)-                     <cons <node ,a_(- i 1) <cons $a_i _> _>-                           l>-                     <cons <node ,a_n _ _>-                           <nil>>)>-         (loop $l $i (between 1 n) {a_i @l} {})]))))-

@@ -1,100 +0,0 @@-(define $Suit-  (type-    {[,$suit []-      {[$tgt (if (eq? tgt suit)-                 {[]}-                 {})]}]-     [<spade> []-      {[<spade> {[]}]-       [_ {}]}]-     [<heart> []-      {[<heart> {[]}]-       [_ {}]}]-     [<club> []-      {[<club> {[]}]-       [_ {}]}]-     [<diamond> []-      {[<diamond> {[]}]-       [_ {}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $Card-  (type-    {[,$val []-      {[$tgt (match [val tgt] [Card Card]-               {[[<card $s $n> <card ,s ,n>] {[]}]-                [[_ _] {}]})]}]-     [<card _ _> [Suit (Mod 13)]-      {[<card $s $n> {[s n]}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $poker-hands-  (lambda [$Cs]-    (match Cs (Multiset Card)-      {[<cons <card $S $n>-         <cons <card ,S ,(- n 1)>-          <cons <card ,S ,(- n 2)>-           <cons <card ,S ,(- n 3)>-            <cons <card ,S ,(- n 4)>-             !<nil>>>>>>-        <straight-flush>]-       [<cons <card _ $n>-         <cons <card _ ,n>-          !<cons <card _ ,n>-            !<cons <card _ ,n>-              !<cons _-                !<nil>>>>>>-        <four-of-kind>]-       [<cons <card _ $m>-         <cons <card _ ,m>-          <cons <card _ ,m>-           <cons <card _ $n>-            !<cons <card _ ,n>-              !<nil>>>>>>-        <full-house>]-       [<cons <card $S _>-         !<cons <card ,S _>-           !<cons <card ,S _>-             !<cons <card ,S _>-               !<cons <card ,S _>-                 !<nil>>>>>>-        <flush>]-       [<cons <card _ $n>-         <cons <card _ ,(- n 1)>-          <cons <card _ ,(- n 2)>-           <cons <card _ ,(- n 3)>-            <cons <card _ ,(- n 4)>-             !<nil>>>>>>-        <straight>]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons <card _ ,n>-           <cons _-            <cons _-             !<nil>>>>>>-        <three-of-kind>]-       [<cons <card _ $m>-         <cons <card _ ,m>-          !<cons <card _ $n>-            <cons <card _ ,n>-             !<cons _-               !<nil>>>>>>-        <two-pair>]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons _-           <cons _-            <cons _-             !<nil>>>>>>-        <one-pair>]-       [<cons _-         <cons _-          <cons _-           <cons _-            <cons _-             !<nil>>>>>>-        <nothing>]})))

@@ -1,16 +0,0 @@-(define $Tree-  (lambda [$a]-    (type-      {[,$val []-      {[$tgt (match [tgt val] [(Tree a) (Tree a)]-               {[[<node $n1 $n2> <node ,n1 ,n2>] {[]}]-                [[<leaf $x> <leaf ,x>] {[]}]-                [[_ _] {}]})]}]-     [<node _ _> [(Tree a) (Tree a)]-      {[<node $n1 $n2> {[n1 n2]}]}]-     [<leaf _> [a]-      {[<leaf $x> {[x]}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))-

@@ -1,30 +0,0 @@-(define $ass [|[~1 2 3~]-               [~4 5 6~]-               [~7 8 9~]-               [~10 11 12~]|])--(test (array-dimension ass))--(test (array-size 1 ass))--(test (array-size 2 ass))--(test (array-range ass))--(test (array-ref [2 2] ass))--(test (array-ref [2 3] ass))--(test (array-range? [2 3] ass))--(test (array-range? [2 4] ass))--(test (generate-array (lambda [$i1 $i2] (* (array-ref [i1 i2] ass) 2)) (array-range ass)))--(define $bss (generate-array (lambda [$i1 $i2] (* (array-ref [i1 i2] ass) 2)) (array-range ass)))--(test (array-ref [2 3] bss))--(test (match ass (Array Integer)-        {[(& <cons ,[2 2] $n> <cons ,[2 3] ,(+ n 1)>) <ok>]-         [_ <ko>]}))

@@ -1,177 +0,0 @@-(load "lib/poker-hands.egi")--;; match List-(test (match-all {1 2 3 4 5} (List Integer) [<snoc $x $xs> [x xs]]))-(test {[5 {1 2 3 4}]})--(test (match-all {1 2 3 4 5} (List Integer) [<join ,{1 2} $xs> xs]))-(test {{3 4 5}})--(test (match-all {1 2 3 4 5} (List Integer) [<join _ <join $xs _>> xs]))-(test {{} {1} {1 2} {1 2 3} {1 2 3 4} {1 2 3 4 5} {} {2} {2 3} {2 3 4} {2 3 4 5} {} {3} {3 4} {3 4 5} {} {4} {4 5} {} {5} {}})--(test (match-all {[1 2] [1 2]} (List [Integer Integer])-        [<cons [$a $b] _> [a b]]))-(test {[1 2]})--;; match Multiset-(test (match-all {1 2 3 4 5} (Multiset Integer)-        [<cons $m <cons $n _>> [m n]]))-(test {[1 2] [1 3] [1 4] [1 5] [2 1] [2 3] [2 4] [2 5] [3 1] [3 2] [3 4] [3 5] [4 1] [4 2] [4 3] [4 5] [5 1] [5 2] [5 3] [5 4]})--;; match a collection of collections-(test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer))-        [<cons <cons $x _>-          <cons <cons $y _>-           <cons <cons $z _>-            <nil>>>>-         [x y z]]))-(test {[1 11 21] [1 11 22] [2 11 21] [2 11 22] [3 11 21] [3 11 22]})--;; match a collection of collections with value patterns-(test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Integer))-        [<cons <cons $n _>-          <cons <cons ,n _>-           <cons <cons ,n _>-            <nil>>>>-         n]))-(test {1 4})--;; pattern as first class object-(test (let {[$pat <cons ,1 <nil>>]}-        (match {1} (Multiset Integer)-          {[pat <ok>]-           [_ <not-ok>]})))-(test <ok>)-      -;; Or-pattern test1-(test (match {} (Multiset Integer)-        {[(| <nil> <cons ,1 <nil>>) <ok>]-         [_ <not-ok>]}))-(test <ok>)--;; Or-pattern test2-(test (match {1} (Multiset Integer)-        {[(| <nil> <cons ,1 <nil>>) <ok>]-         [_ <not-ok>]}))-(test <ok>)--(test (match-all {1 2 3 4 5 6 7 1 3 5 7} (Multiset Integer)-        [<cons $x ^<cons ,x _>> x]))-(test {2 4 6})--(test (match-all {{1 2 3} {2 3 4} {1}} (Multiset (Multiset Integer))-        [<cons <cons $x ^<cons ,x _>>-          <cons ^<cons ,x _>-           <cons ^<cons ,x _>-            <nil>>>>-         x]))-(test {4 4}) ; is really ok?--(test (match-all {{1 2 3} {2 3 4}} (Multiset (Multiset Integer))-        [<cons <cons $x ^<cons ,x _>>-           <cons ^<cons ,x _>-            <nil>>>-         x]))-(test {1 4})--(test (match-all {1 2 3} (List Integer)-        [<join $hs $ts> [hs ts]]))-(test "here")-(test {[{} {1 2 3}] [{1} {2 3}] [{1 2} {3}] [{1 2 3} {}]})--(test (match-all {1 2 3} (List Integer)-        [<nioj $hs $ts> [hs ts]]))-(test {[{1 2 3} {}] [{2 3} {1}] [{3} {1 2}] [{} {1 2 3}]})--(test (match-all {1 2 3} (Multiset Integer)-        [<join $hs $ts> [hs ts]]))-(test {[{} {3 2 1}] [{1} {3 2}] [{2} {3 1}] [{1 2} {3}] [{3} {2 1}] [{1 3} {2}] [{2 3} {1}] [{1 2 3} {}]})--(test (match-all {1 2 3} (Set Integer)-        [<join $hs $ts> [hs ts]]))-(test {[{} {3 2 1}] [{1} {3 2}] [{1} {3 2 1}] [{2} {3 1}] [{2} {3 1 2}] [{1 2} {3}] [{1 2} {3 1}] [{1 2} {3 2}] [{1 2} {3 1 2}] [{3} {2 1}] [{3} {2 1 3}] [{1 3} {2}] [{1 3} {2 1}] [{1 3} {2 3}] [{1 3} {2 1 3}] [{2 3} {1}] [{2 3} {1 2}] [{2 3} {1 3}] [{2 3} {1 2 3}] [{1 2 3} {}] [{1 2 3} {1}] [{1 2 3} {2}] [{1 2 3} {1 2}] [{1 2 3} {3}] [{1 2 3} {1 3}] [{1 2 3} {2 3}] [{1 2 3} {1 2 3}]})--(test (match-all {1 2 3} (List Integer)-        [<join $hs <cons $x $ts>> [hs x ts]]))-(test {[{} 1 {2 3}] [{1} 2 {3}] [{1 2} 3 {}]})--;; noij-(test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))--(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))--(test (subcollections {<x> <y> <z>}))--;; Cut-pattern-(test (match {2 7 7 2 7} (Multiset Integer)-        {[<cons $m-           <cons ,m-            <cons ,m-             <cons $n-              !<cons ,n-                !<nil>>>>>>-          <ok>]-         [_ <ko>]}))--;; Value-pattern-(test (match {5 2 1 3 4} (Multiset Integer)-        {[<cons $n-           <cons ,(- n 1)-            <cons ,(- n 2)-             <cons ,(- n 3)-              <cons ,(- n 4)-               <nil>>>>>>-          <ok>]-         [_ <ko>]}))--(test (match-all {1 2 3 4} (List Integer)-        [<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]))-(test {1 2 3})--(define $pair-  (macro [$s $pat]-    <cons $`s <cons ,`s pat>>))--(test (match-all {1 2 3 1 2} (Multiset Integer)-        [(pair %k _) k]))-(test {1 2})--(define $loop-pat-  (lambda [$k $i]-    (match i Integer-      {[,k <join _ <cons $n_k _>>]-       [_ <join _ <cons $n_i (loop-pat k (+ i 1))>>]})))--(define $loop-pat-  (lambda [$k]-    (| <nil> <cons ,k (loop-pat (- k 1))>)))--(define $isStraight?-  (lambda [$Ns]-    (match Ns (Multiset Integer)-      {[<cons $n-         (loop-pat (- n 1))>-        <ok>]-       [_ <ko>]})))--(define $isStraight?-  (lambda [$Ns]-    (match Ns (Multiset Integer)-      {[<cons (& ,(max Ns) $n)-         (loop-pat (- n 1))>-        <ok>]-       [_ <ko>]})))--(test (isStraight? {1 2}))--;; comparison of large list-(test (match (between 1 10000) (List Integer) {[,(between 1 10000) <ok>] [_ <ko>]}))

@@ -1,25 +0,0 @@-(load "lib/graph.egi")--(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}>})--(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 (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 (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 g2))-(test {})--(test (hamilton-path g2))-(test {{1 2 3 4 5} {5 4 3 2 1}})

@@ -1,6 +0,0 @@-######-#. *R#-#  \.#-#\ * #-L  .\#-######

@@ -1,24 +0,0 @@-#############################-#..........................\#-#..\\###...#....        ###.#-#..\*\\\.. #.... ..##\\..\#.#-#..\*\.... #.... ..#\#....#.#-#...\###.. #.... ....#....#.#-#... ..... ..... .####......#-#\\. #....           .......#-#... #..#. .....*\ ##.......#-#.#....... ...#..  ....######-#. ...#... ...#.\  ....#..* #-##........ ...#.. #....#.#\\#-#.....*... .....*\#\\.....*.#-#.***.* .......*\****.....#.#-#.\\\.. ................   .#-#.#####    .######    ##### #-#....\\.................... #-#....****...#.##.....\\\\..\#-#....\\\\...#.........*....\#-#....\\\\...#.\\.    #\###.\#-#....     ..#.... ...#\\\\. #-#........ ..#.... ...#..... #-#........         ........#R#-###########################L#

@@ -1,7 +0,0 @@-#######-#..***#-#..\\\#-#...**#-#.*.*\#-LR....#-#######

@@ -1,9 +0,0 @@-########-#..R...#-#..*...#-#..#...#-#.\.\..L-####**.#-#\.....#-#\..* .#-########

@@ -1,9 +0,0 @@-#########-#.*..#\.#-#.\..#\.L-#.R .##.#-#.\  ...#-#..\  ..#-#...\  ##-#....\ \#-#########

@@ -1,12 +0,0 @@-############-#..........#-#.....*....#-#..\\\\\\..#-#.     ....#-#..\\\\\\\.#-#..\..    .#-#..\.. ....#-#..... ..* #-#..### ### #-#...R#\#\\.#-######L#####

@@ -1,15 +0,0 @@-###############-#\\\.......** #-#\\#.#####...##-#\\#.....*##. #-#\#####\...## #-#\......####* #-#\.######* #.\#-#\.#. *...##.##-#\##. ..  *...#-#\...... L#.#.#-###########.#.#-#\..........#.#-##.##########.#-#R.#\.........#-###############

@@ -1,9 +0,0 @@-    #######-    ##    *#-     ##R  *##-      ##\\\\##-       ##....##-      ##..\ . ##-     ## . L .  ##-    ##\\\# #\\\\##-   ######   #######

@@ -1,18 +0,0 @@-##############-#\\... ......#-###.#. ...*..#-  #.#. ... ..#-### #.   \ ..#-#. .#..... **#######-#.#\#..... ..\\\*. #-#*\\#.###. ####\\\ #-#\\.#.     ...## \ #-#\#.#..... ....# \ #  -###.#..... ....#   ##-#\\.#..... ....#\   # -########.. ..###*####-#......... .........#-#......... ....***..#-#..\\\\\ # ####.....#-#........*R..\\\   .#-##########L##########

@@ -1,17 +0,0 @@-        #L#######-        #*** \\ #-        #\\\ .. #-#########.##    ##########-#.......\ ..........*   .#-#*******\......#....#\\ .#-###\.\\\...**..#....... *#-#*****\\  .\\..##     #\.#-######### ....  ##########-        #       #-        ####*####      -        #.......#-#########  \\\\*##########-#*\\  **#     *..*\ \\\\\#-#.\**\*** .....**.# \\##\#-#\R......     .\\.. \\\\\#-##########################

@@ -1,466 +0,0 @@-;;;-;;; ICFPC 2012 Simulator-;;;--(define $RobotState-  (type-    {[,$val []-      {[$tgt (if (eq? tgt val)-                 {[]}-                 {})]}]-     [<normal> []-      {[<normal> {[]}]-       [_ {}]}]-     [<on-lambda> []-      {[<on-lambda> {[]}]-       [_ {}]}]-     [<abort> []-      {[<abort> {[]}]-       [_ {}]}]-     [<broken> []-      {[<broken> {[]}]-       [_ {}]}]-     [<goal> []-      {[<goal> {[]}]-       [_ {}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $Tile-  (type-    {[<robot ,$pState> []-      {[<robot $state> (if ((= RobotState) pState state)-                           {[]}-                           {})]-       [_ {}]}]-     [<robot _> [RobotState]-      {[<robot $state> {state}]-       [_ {}]}]-     [<rock ,$pFlag> []-      {[<rock $flag> (if (eq? pFlag flag)-                         {[]}-                         {})]-       [_ {}]}]-     [<rock _> [Bool]-      {[<rock $flag> {[flag]}]-       [_ {}]}]-     [<wall> []-      {[<wall> {[]}]-       [_ {}]}]-     [<lambda-stone> []-      {[<lambda-stone> {[]}]-       [_ {}]}]-     [<earth> []-      {[<earth> {[]}]-       [_ {}]}]-     [<empty> []-      {[<empty> {[]}]-       [_ {}]}]-     [<open-lift> []-      {[<open-lift> {[]}]-       [_ {}]}]-     [<closed-lift> []-      {[<closed-lift> {[]}]-           [_ {}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $show-tile-  (lambda [$tile]-    (match tile Tile-      {[<robot _> "R"]-       [<rock _> "*"]-       [<wall> "#"]-       [<lambda-stone> "\\"]-       [<earth> "."]-       [<empty> " "]-       [<open-lift> "O"]-       [<closed-lift> "L"]})))--(define $char-to-tile-  (lambda [$c]-    (match c Char-      {[,'R' <robot <normal>>]-       [,'*' <rock #f>]-       [,'#' <wall>]-       [,'\\' <lambda-stone>]-       [,'.' <earth>]-       [,' ' <empty>]-       [,'O' <open-lift>]-       [,'L' <closed-lift>]-       })))--(define $Mine (Array Tile))--(define $Move-  (type-    {[<left> []-      {[<left> {[]}]-       [_ {}]}]-     [<right> []-      {[<right> {[]}]-       [_ {}]}]-     [<up> []-      {[<up> {[]}]-       [_ {}]}]-     [<down> []-      {[<down> {[]}]-       [_ {}]}]-     [<wait> []-      {[<wait> {[]}]-       [_ {}]}]-     [<abort> []-      {[<abort> {[]}]-           [_ {}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $char-to-move-  (lambda [$c]-    (match c Char-      {[,'L' <left>]-       [,'R' <right>]-       [,'U' <up>]-       [,'D' <down>]-       [,'W' <wait>]-       [,'A' <abort>]-       [,'h' <left>]-       [,'l' <right>]-       [,'k' <up>]-       [,'j' <down>]-       })))--(define $Point [Integer Integer])--(define $GameState-  (type-    {[<game-state _ _ _ _> [Mine Integer Integer Integer]-      {[<game-state $mine $step $score $lambda-count>-        {[mine step score lambda-count]}]}]-     [_ [Something]-      {[$tgt {tgt}]}]-     }))--(define $get-mine-  (lambda [$game-state]-    (match game-state GameState-      {[<game-state $mine _ _ _> mine]})))--(define $show-mine-  (lambda [$mine]-    (let {[$kss (keys-for-display (array-range mine))]}-      (foldl string-append ""-             (map (lambda [$ks]-                    (string-append (foldl string-append ""-                                          (map (lambda [$k]-                                                 (show-tile (array-ref k mine))) ks))-                                   "\n"))-                  kss)))))--(define $get-robot-state-  (lambda [$mine]-    (let {[$rp ((find-from-value-with-pattern Tile) <robot _> mine)]}-      (match (array-ref rp mine) Tile-        {[<robot $state> state]}))))--(define $move-robot-  (lambda [$mine $move]-    (generate-array-      (lambda [$x $y]-        (match move Move-          {[<left>-            (match mine Mine-              {-               [(& <cons ,[x y] <robot _>>-                   <cons ,[(- x 1) y] <open-lift>>)-                <empty>]-               [(& <cons ,[x y] <open-lift>>-                   <cons ,[(+ x 1) y] <robot _>>)-                <robot <goal>>]-               [(& <cons ,[x y] <robot _>>-                   <cons ,[(- x 1) y] <lambda-stone>>)-                <empty>]-               [(& <cons ,[x y] <lambda-stone>>-                   <cons ,[(+ x 1) y] <robot _>>)-                <robot <on-lambda>>]-               [(& <cons ,[x y] <robot _>>-                   (| ^<cons ,[(- x 1) y] (| <wall> <rock _>)>-                      (& <cons ,[(- x 1) y] <rock _>>-                         <cons ,[(- x 2) y] <empty>>)))-                <empty>]-               [(& <cons ,[(+ x 1) y] <robot _>>-                   (| ^<cons ,[x y] (| <wall> <rock _>)>-                      (& <cons ,[x y] <rock _>>-                         <cons ,[(- x 1) y] <empty>>)))-                <robot <normal>>]-               [(& <cons ,[x y] <empty>>-                   <cons ,[(+ x 1) y] <rock _>>-                   <cons ,[(+ x 2) y] <robot _>>)-                <rock #f>]-               [<cons ,[x y] <robot _>>-                <robot <normal>>]-               [<cons ,[x y] $tile> tile]})]-           [<right>-            (match mine Mine-              {-               [(& <cons ,[x y] <robot _>>-                   <cons ,[(+ x 1) y] <open-lift>>)-                <empty>]-               [(& <cons ,[x y] <open-lift>>-                   <cons ,[(- x 1) y] <robot _>>)-                <robot <goal>>]-               [(& <cons ,[x y] <robot _>>-                   <cons ,[(+ x 1) y] <lambda-stone>>)-                <empty>]-               [(& <cons ,[x y] <lambda-stone>>-                   <cons ,[(- x 1) y] <robot _>>)-                <robot <on-lambda>>]-               [(& <cons ,[x y] <robot _>>-                   (| ^<cons ,[(+ x 1) y] (| <wall> <rock _>)>-                      (& <cons ,[(+ x 1) y] <rock _>>-                         <cons ,[(+ x 2) y] <empty>>)))-                <empty>]-               [(& <cons ,[(- x 1) y] <robot _>>-                   (| ^<cons ,[x y] (| <wall> <rock _>)>-                      (& <cons ,[x y] <rock _>>-                         <cons ,[(+ x 1) y] <empty>>)))-                <robot <normal>>]-               [(& <cons ,[x y] <empty>>-                   <cons ,[(- x 1) y] <rock _>>-                   <cons ,[(- x 2) y] <robot _>>)-                <rock #f>]-               [<cons ,[x y] <robot _>>-                <robot <normal>>]-               [<cons ,[x y] $tile> tile]})]-           [<up>-            (match mine Mine-              {-               [(& <cons ,[x y] <robot _>>-                   <cons ,[x (+ y 1)] <open-lift>>)-                <empty>]-               [(& <cons ,[x y] <open-lift>>-                   <cons ,[x (- y 1)] <robot _>>)-                <robot <goal>>]-               [(& <cons ,[x y] <robot _>>-                   <cons ,[x (+ y 1)] <lambda-stone>>)-                <empty>]-               [(& <cons ,[x y] <lambda-stone>>-                   <cons ,[x (- y 1)] <robot _>>)-                <robot <on-lambda>>]-               [(& <cons ,[x y] <robot _>>-                   ^<cons ,[x (+ y 1)] (| <wall> <rock _>)>)-                <empty>]-               [(& <cons ,[x (- y 1)] <robot _>>-                   ^<cons ,[x y] (| <wall> <rock _>)>)-                <robot <normal>>]-               [<cons ,[x y] <robot _>>-                <robot <normal>>]-               [<cons ,[x y] $tile> tile]})]-           [<down>-            (match mine Mine-              {-               [(& <cons ,[x y] <robot _>>-                   <cons ,[x (- y 1)] <open-lift>>)-                <empty>]-               [(& <cons ,[x y] <open-lift>>-                   <cons ,[x (+ y 1)] <robot _>>)-                <robot <goal>>]-               [(& <cons ,[x y] <robot _>>-                   <cons ,[x (- y 1)] <lambda-stone>>)-                <empty>]-               [(& <cons ,[x y] <lambda-stone>>-                   <cons ,[x (+ y 1)] <robot _>>)-                <robot <on-lambda>>]-               [(& <cons ,[x y] <robot _>>-                   ^<cons ,[x (- y 1)] (| <wall> <rock _>)>)-                <empty>]-               [(& <cons ,[x (+ y 1)] <robot _>>-                   ^<cons ,[x y] (| <wall> <rock _>)>)-                <robot <normal>>]-               [<cons ,[x y] <robot _>>-                <robot <normal>>]-               [<cons ,[x y] $tile> tile]})]-           [<abort>-            (match mine Mine-              {[<cons ,[x y] <robot _>>-                <robot <abort>>]-               [<cons ,[x y] $tile> tile]})]-           [<wait>-            (match mine Mine-              {[<cons ,[x y] <robot _>>-                <robot <normal>>]-               [<cons ,[x y] $tile> tile]})]-           }))-      (array-range mine))))-                           -(define $update-map-  (lambda [$mine]-    (generate-array-      (lambda [$x $y]-        (match mine Mine-          {[(& <cons ,[x y] <empty>>-               <cons ,[x (+ y 1)] <rock _>>)-            <rock #t>]-           [(& <cons ,[x (- y 1)] <empty>>-               <cons ,[x y] <rock _>>)-            <empty>]-           [(& <cons ,[x y] <empty>>-               <cons ,[(- x 1) y] (| <rock _> <lambda-stone>)>-               <cons ,[(- x 1) (+ y 1)] <rock _>>-               <cons ,[x (+ y 1)] <empty>>)-            <rock #t>]-           [(& <cons ,[x y] <rock _>>-               <cons ,[x (- y 1)] (| <rock _> <lambda-stone>)>-               <cons ,[(+ x 1) (- y 1)] <empty>>-               <cons ,[(+ x 1) y] <empty>>)-            <empty>]-           [(& <cons ,[x y] <rock _>>-               <cons ,[x (- y 1)] <rock _>>-               (| <cons ,[(+ x 1) y] ^<empty>>-                  <cons ,[(+ x 1) (- y 1)] ^<empty>>)-               <cons ,[(- x 1) (- y 1)] <empty>>-               <cons ,[(- x 1) y] <empty>>)-            <empty>]-           [(& <cons ,[(+ x 1) (+ y 1)] <rock _>>-               <cons ,[(+ x 1) y] <rock _>>-               (| <cons ,[(+ x 2) y] ^<empty>>-                  <cons ,[(+ x 2) (+ y 1)] ^<empty>>)-               <cons ,[x (+ y 1)] <empty>>-               <cons ,[x y] <empty>>)-            <rock #t>]-           [<cons ,[x y] <closed-lift>>-            (if (eq? 0 (size (lambda-stones mine)))-                <open-lift>-                <closed-lift>)]-           [<cons ,[x y] <rock _>>-                <rock #f>]-           [<cons ,[x y] $tile> tile]-           }))-      (array-range mine))))--(define $lambda-stones-  (lambda [$mine]-    (concat (map (lambda [$x $y]-                   (match mine Mine-                     {[<cons ,[x y] <lambda-stone>> {[x y]}]-                      [_ {}]}))-                 (array-keys mine)))))--(define $ending-update-  (lambda [$mine]-    (generate-array-      (lambda [$x $y]-        (match mine Mine-          {[(& <cons ,[x y] <robot _>>-               <cons ,[x (+ y 1)] <rock ,#t>>)-            <robot <broken>>]-           [<cons ,[x y] $tile> tile]-           }))-      (array-range mine))))--(define $ending?-  (lambda [$mine]-    (match (get-robot-state mine) RobotState-      {[(| <abort> <broken> <goal>) #t]-       [_ #f]})))--(define $calc-score-  (lambda [$game-state]-    (match game-state GameState-      {[<game-state $mine $step $score $lambda-count>-        (match (get-robot-state mine) RobotState-          {[<goal> (+ score (* 25 lambda-count))]-           [<abort> score]-           [<broken> 0]})]})))--(define $generate-mine-  (lambda [$lines]-    (do {[$tss (map (lambda [$line]-                      (map char-to-tile-                           (string-to-chars line)))-                    (reverse lines))]-         [$mx (max (map size tss))]-         [$my (size tss)]-         [$tss2 (map (lambda [$cs]-                       {@cs @(loop $l $i (between 1 (- mx (size cs))) {<wall> @l} {})})-                     tss)]-         }-      (letrec {[$rotate-                (lambda [$tss]-                  (match (car tss) (List Something)-                    {[<nil> {}]-                     [_ {(map car tss) @(rotate (map cdr tss))}]}))]}-        (let {[$tss3 (rotate tss2)]}-          (generate-array-            (lambda [$x $y] (nth y (nth x tss3)))-            [mx my]))))))--(define $main-  (lambda [$world $argv]-    (match argv (List String)-      {[<cons $file <nil>>-        (do {[[$world $port] (open-input-file world file)]-             }-          (letrec {[$readMapLoop (lambda [$world $lines]-                                   (do {[[$world $line] (read-line-from-port world port)]}-                                     (if (or (eof? line) (eq-s? line ""))-                                         [world lines]-                                         (readMapLoop world {@lines line}))))]-                   }-            (do {[[$world $lines] (readMapLoop world {})]-                 [$init-mine (generate-mine lines)]-                 [$init-state <game-state init-mine 0 0 0>]}-              (letrec {[$interactive-                        (lambda [$world $game-state]-                          (match game-state GameState-                            {[<game-state $mine $step $score $lambda-count>-                              (do {-                                   [$world (write-string world (show-mine mine))]-                                   [$world (write-char world '\n')]-                                   [$world (write-string world "robot-state: ")]-                                   [$world (write world (get-robot-state mine))]-                                   [$world (write-char world '\n')]-                                   [$world (write-string world "lambda-count: ")]-                                   [$world (write world lambda-count)]-                                   [$world (write-char world '\n')]-                                   [$world (write-string world "score: ")]-                                   [$world (write world score)]-                                   [$world (write-char world '\n')]-                                   [$world (write-string world "command: ")]-                                   [$world (flush world)]-                                   [[$world $cmd] (read-char world)]-                                   [$world (write-char world '\n')]-                                   [$world (flush world)]-                                   [$move (char-to-move cmd)]-                                   [$mine2 (ending-update (update-map (move-robot mine move)))]-                                   [$game-state2 <game-state mine2 (+ 1 step)-                                                             (if ((= RobotState) <on-lambda> (get-robot-state mine2))-                                                                 (- (+ 50 score) 1)-                                                                 (- score 1))-                                                             (if ((= RobotState) <on-lambda> (get-robot-state mine2))-                                                                 (+ 1 lambda-count)-                                                                 lambda-count)-                                                             >]-                                   }-                                (if (ending? mine2)-                                    (do {-                                         [$world (write-string world (show-mine mine2))]-                                         [$world (write-char world '\n')]-                                         [$world (write-string world "robot-state: ")]-                                         [$world (write world (get-robot-state mine2))]-                                         [$world (write-char world '\n')]-                                         [$world (write-string world "score: ")]-                                         [$world (write world (calc-score game-state2))]-                                         [$world (write-char world '\n')]-                                         }-                                      world)-                                    (interactive world game-state2)))]}))]}-                (interactive world init-state)))))]-       [_ (do {-               [$world (write-string world "usage: mine FILENAME (specify map file)\n")]-               }-            world)]})))-

@@ -1,6 +0,0 @@-(define $main-  (lambda [$world $argv]-    (do {[$world (write-string world "output : ")]-         [$world (write world argv)]-         [$world (write-char world '\n')]}-        world)))

@@ -1,17 +0,0 @@-(define $main-  (lambda [$world $argv]-    (match argv (List String)-      {[<cons $file1 <nil>>-        (do {[[$world $port] (open-input-file world file1)]}-            (letrec {[$copyLoop (lambda [$world]-                                  (do {[[$world $line] (read-line-from-port world port)]}-                                      (if (eof? line)-                                          world-                                          (do {[$world (write-string world line)]-                                               [$world (write-char world '\n')]}-                                              (copyLoop world)))))]}-              (do {[$world (copyLoop world)]-                   [$world (close-input-port world port)]}-                  world)))]-       [_ <argv-error>]})))-

@@ -1,10 +0,0 @@-(define $main-  (lambda [$world $argv]-    (do {[$world (write-string world "input char : ")]-         [$world (flush world)]-         [[$world $c] (read-char world)]-         [$world (write-char world '\n')]-         [$world (write-string world "output : ")]-         [$world (write-char world c)]-         [$world (write-char world '\n')]}-        world)))

@@ -1,19 +0,0 @@-(define $main-  (lambda [$world $argv]-    (match argv (List String)-      {[<cons $file1 <cons $file2 <nil>>>-        (do {[[$world $port1] (open-input-file world file1)]-             [[$world $port2] (open-output-file world file2)]}-            (letrec {[$copyLoop (lambda [$world]-                                  (do {[[$world $line] (read-line-from-port world port1)]}-                                      (if (eof? line)-                                          world-                                          (do {[$world (write-string-to-port world port2 line)]-                                               [$world (write-char-to-port world port2 '\n')]}-                                              (copyLoop world)))))]}-              (do {[$world (copyLoop world)]-                   [$world (close-output-port world port2)]-                   [$world (close-input-port world port1)]}-                  world)))]-       [_ <argv-error>]})))-

@@ -1,4 +0,0 @@-(define $main-  (lambda [$world $argv]-    (do {[$world (print world "Hello world!")]}-        world)))

@@ -1,9 +0,0 @@-(define $main-  (lambda [$world $argv]-    (do {[$world (write-string world "input : ")]-         [$world (flush world)]-         [[$world $val] (read world)]-         [$world (write-string world "output : ")]-         [$world (write world val)]-         [$world (write-char world '\n')]}-        world)))

@@ -1,13 +0,0 @@-(define $n-queen-  (lambda [$n]-    (match-all (between 1 n) (Multiset Integer)-      [<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))-                                  l1)-                               $a_i)-                         l>-                   <nil>)>-       (loop $l $i (between 1 n)  {a_i @l} {})])))

@@ -1,14 +0,0 @@-(test (between 3 5))-(test {3 4 5})--(test (min&max {10 20 4 40 23}))-(test [4 40])--(test (fib 10))-(test 89)--(test (fact 10))-(test 3628800)--(test (gcd {10 20 40 35}))-(test 5)

@@ -1,29 +0,0 @@-(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>)

@@ -0,0 +1,37 @@+module Main where++import Control.Applicative+import Control.Monad+++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 +  env <- primitiveEnv >>= loadLibraries+  result <- runEgisonM $ loadFile file >>= evalTopExprs' env+  assertString $ either show (const "") result++evalTopExprs' :: Env -> [EgisonTopExpr] -> EgisonM ()+evalTopExprs' env exprs = do+  let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs+  env <- recursiveBind env bindings+  forM_ tests $ evalExpr' env+ where+  collectDefsAndTests (Define name expr) (bindings, tests) =+    ((name, expr) : bindings, tests)+  collectDefsAndTests (Test expr) (bindings, tests) =+    (bindings, expr : tests)+  collectDefsAndTests _ r = r