egison 3.2.13 → 3.2.14

raw patch · 27 files changed

+1697/−602 lines, 27 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +3/−1
• hs-src/Interpreter/egisoni.hs +17/−86
• hs-src/Language/Egison.hs +43/−51
• hs-src/Language/Egison/Core.hs +160/−92
• hs-src/Language/Egison/Desugar.hs +17/−3
• hs-src/Language/Egison/Parser.hs +28/−20
• hs-src/Language/Egison/Primitives.hs +299/−265
• hs-src/Language/Egison/Types.hs +274/−80
• hs-src/Language/Egison/Util.hs +86/−0
• lib/core/collection.egi +2/−2
• sample/bipartite-graph.egi +87/−0
• sample/graph.egi +86/−0
• sample/io/argv.egi +18/−0
• sample/io/cat.egi +44/−0
• sample/io/cat2.egi +5/−0
• sample/io/dice.egi +6/−0
• sample/io/hello.egi +3/−0
• sample/io/interactive.egi +17/−0
• sample/io/print-primes.egi +4/−0
• sample/mahjong.egi +73/−0
• sample/n-queen.egi +58/−0
• sample/poker-hands.egi +114/−0
• sample/sequence.egi +32/−0
• sample/social-graph.egi +81/−0
• sample/tree.egi +89/−0
• sample/xml-test.egi +49/−0
• test/UnitTest.hs +2/−2

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.2.13+Version:             3.2.14 Synopsis:            Programming language with non-linear pattern-matching against unfree data types Description:         An interpreter for Egison, the programming langugage that realized non-linear pattern-matching with unfree data types.                      With Egison, you can represent pattern-matching with unfree data types intuitively,@@ -19,6 +19,7 @@  Data-files:          lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/string.egi lib/core/database.egi lib/core/io.egi                      lib/tree/xml.egi lib/math/prime.egi+                     sample/*.egi sample/io/*.egi sample/io/*.egi                      elisp/egison-mode.el  source-repository head@@ -37,6 +38,7 @@                    Language.Egison.Types                    Language.Egison.Parser                    Language.Egison.Primitives+                   Language.Egison.Util   Other-modules:   Paths_egison  Test-Suite test

@@ -27,6 +27,7 @@ import System.Exit (ExitCode (..), exitWith, exitFailure) import System.IO import Language.Egison+import Language.Egison.Util  main :: IO () main = do args <- getArgs@@ -36,20 +37,20 @@             Options {optShowHelp = True} -> printHelp             Options {optShowVersion = True} -> printVersionNumber             Options {optPrompt = prompt, optShowBanner = bannerFlag} -> do-                case nonOpts of-                    [] -> do-                        env <- primitiveEnv >>= loadLibraries-                        when bannerFlag showBanner >> repl env prompt >> when bannerFlag showByebyeMessage-                    (file:args) -> do-                        case opts of-                          Options {optLoadOnly = True} -> do-                            env <- primitiveEnvNoIO >>= loadLibraries-                            result <- evalEgisonTopExprs env [LoadFile file]-                            either print (const $ return ()) result-                          Options {optLoadOnly = False} -> do-                            env <- primitiveEnv >>= loadLibraries-                            result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))]-                            either print (const $ return ()) result+              case nonOpts of+                [] -> do+                  env <- primitiveEnv >>= loadCoreLibraries+                  when bannerFlag showBanner >> repl env prompt >> when bannerFlag showByebyeMessage+                (file:args) -> do+                  case opts of+                    Options {optLoadOnly = True} -> do+                      env <- primitiveEnvNoIO >>= loadCoreLibraries+                      result <- evalEgisonTopExprs env [LoadFile file]+                      either print (const $ return ()) result+                    Options {optLoadOnly = False} -> do+                      env <- primitiveEnv >>= loadCoreLibraries+                      result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))]+                      either print (const $ return ()) result  data Options = Options {     optShowVersion :: Bool,@@ -128,7 +129,7 @@   where     settings :: MonadIO m => FilePath -> Settings m     settings home = do-      setComplete completeParen $ defaultSettings { historyFile = Just (home </> ".egison_history") }+      setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history") }          loop :: Env -> String -> String -> InputT IO ()     loop env prompt' rest = do@@ -150,7 +151,7 @@             Left err | show err =~ "unexpected end of input" -> do               loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n"             Left err | show err =~ "expecting (top-level|\"define\")" -> do-              result <- liftIO $ handle onAbort $ fromEgisonM (readExpr newInput) >>= either (return . Left) (evalEgisonExpr env)+              result <- liftIO $ handle onAbort $ runEgisonExpr env newInput               case result of                 Left err | show err =~ "unexpected end of input" -> do                   loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n"@@ -165,73 +166,3 @@               loop env prompt ""             Right env' ->               loop env' prompt ""--completeParen :: Monad m => CompletionFunc m-completeParen arg@((')':_), _) = completeParen' arg-completeParen arg@(('>':_), _) = completeParen' arg-completeParen arg@((']':_), _) = completeParen' arg-completeParen arg@(('}':_), _) = completeParen' arg-completeParen arg@(('(':_), _) = (completeWord Nothing " \t<>[]{}$," completeAfterOpenParen) arg-completeParen arg@(('<':_), _) = (completeWord Nothing " \t()[]{}$," completeAfterOpenCons) arg-completeParen arg@((' ':_), _) = (completeWord Nothing "" completeNothing) arg-completeParen arg@([], _) = (completeWord Nothing "" completeNothing) arg-completeParen arg@(_, _) = (completeWord Nothing " \t[]{}$," completeEgisonKeyword) arg--completeAfterOpenParen :: Monad m => String -> m [Completion]-completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenParen--completeAfterOpenCons :: Monad m => String -> m [Completion]-completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons--completeNothing :: Monad m => String -> m [Completion]-completeNothing _ = return []--completeEgisonKeyword :: Monad m => String -> m [Completion]-completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords--egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "do", "lambda", "match-lambda", "match", "match-all", "pattern-function", "matcher", "algebraic-data-matcher", "if", "loop", "io"]-                            ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "empty?", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "simple-select", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "pfs", "pfs-n", "min", "max", "min-and-max", "power", "mod", "float", "ordering", "qsort", "intersperse", "intercalate", "split", "split/m"]-egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"]-egisonKeywordsInNeutral = ["something"]-                       ++ ["bool", "string", "integer", "nat", "nats", "nats0"]-egisonKeywords = egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral--completeParen' :: Monad m => CompletionFunc m-completeParen' (lstr, _) = case (closeParen lstr) of-                             Nothing -> return (lstr, [])-                             Just paren -> return (lstr, [(Completion paren paren False)])--closeParen :: String -> Maybe String-closeParen str = closeParen' 0 $ removeCharAndStringLiteral str--removeCharAndStringLiteral :: String -> String-removeCharAndStringLiteral [] = []-removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':(removeCharAndStringLiteral str)-removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':(removeCharAndStringLiteral str)-removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral (c:str) = c:(removeCharAndStringLiteral str)--removeCharAndStringLiteral' :: String -> String-removeCharAndStringLiteral' [] = []-removeCharAndStringLiteral' ('"':'\\':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral' ('"':str) = removeCharAndStringLiteral str-removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral' ('\'':str) = removeCharAndStringLiteral str-removeCharAndStringLiteral' (_:str) = removeCharAndStringLiteral' str--closeParen' :: Integer -> String -> Maybe String-closeParen' _ [] = Nothing-closeParen' 0 ('(':_) = Just ")"-closeParen' 0 ('<':_) = Just ">"-closeParen' 0 ('[':_) = Just "]"-closeParen' 0 ('{':_) = Just "}"-closeParen' n ('(':str) = closeParen' (n - 1) str-closeParen' n ('<':str) = closeParen' (n - 1) str-closeParen' n ('[':str) = closeParen' (n - 1) str-closeParen' n ('{':str) = closeParen' (n - 1) str-closeParen' n (')':str) = closeParen' (n + 1) str-closeParen' n ('>':str) = closeParen' (n + 1) str-closeParen' n (']':str) = closeParen' (n + 1) str-closeParen' n ('}':str) = closeParen' (n + 1) str-closeParen' n (_:str) = closeParen' n str

@@ -1,26 +1,33 @@+{- |+Module      : Language.Egison+Copyright   : Satoshi Egi+Licence     : MIT +This is the top module of Egison.+-}+ module Language.Egison        ( module Language.Egison.Types        , module Language.Egison.Parser        , module Language.Egison.Primitives-       , version-       , counter --danger-       , fromEgisonM-       , loadLibraries-       , loadPrimitives-       , loadEgisonFile-       , loadEgisonLibrary+       -- * Eval Egison expressions        , evalEgisonExpr        , evalEgisonTopExpr        , evalEgisonTopExprs+       , runEgisonExpr        , runEgisonTopExpr        , runEgisonTopExprs+       -- * Load Egison files+       , loadCoreLibraries+       , loadEgisonLibrary+       , loadEgisonFile+       -- * Information+       , version        ) where  import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error -import System.IO.Unsafe (unsafePerformIO) import Data.IORef import Data.Version import qualified Paths_egison as P@@ -30,37 +37,42 @@ import Language.Egison.Primitives import Language.Egison.Core +-- |Version number version :: Version version = P.version --- Unsafe-counter :: IORef Int-counter = unsafePerformIO (newIORef 0)+-- |eval an Egison expression+evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue)+evalEgisonExpr env expr = fromEgisonM $ evalExprDeep env expr -readCounter :: IO Int-readCounter = readIORef counter+-- |eval an Egison top expression+evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env)+evalEgisonTopExpr env exprs = fromEgisonM $ evalTopExpr env exprs -updateCounter :: Int -> IO ()-updateCounter = writeIORef counter+-- |eval Egison top expressions+evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)+evalEgisonTopExprs env exprs = fromEgisonM $ evalTopExprs env exprs -modifyCounter :: FreshT IO a -> IO a-modifyCounter m = do-  seed <- readCounter-  (result, seed) <- runFreshT seed m -  updateCounter seed-  return result  +-- |eval an Egison expression. Input is a Haskell string.+runEgisonExpr :: Env -> String -> IO (Either EgisonError EgisonValue)+runEgisonExpr env input = fromEgisonM $ readExpr input >>= evalExprDeep env -loadLibraries :: Env -> IO Env-loadLibraries env = do-  seed <- readIORef counter-  (result, seed') <- runFreshT seed $ runEgisonM $ foldM evalTopExpr env (map Load libraries)-  writeIORef counter seed'-  case result of+-- |eval an Egison top expression. Input is a Haskell string.+runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env)+runEgisonTopExpr env input = fromEgisonM $ readTopExpr input >>= evalTopExpr env++-- |eval Egison top expressions. Input is a Haskell string.+runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env)+runEgisonTopExprs env input = fromEgisonM $ readTopExprs input >>= evalTopExprs env++loadCoreLibraries :: Env -> IO Env+loadCoreLibraries env = do+  ret <- evalEgisonTopExprs env $ map Load libraries+  case ret of     Left err -> do       print . show $ err       return env-    Right env' -> -      return env'+    Right env' -> return env'   where     libraries :: [String]     libraries = [ "lib/core/base.egi"@@ -73,29 +85,9 @@                 , "lib/core/io.egi"                  ] -fromEgisonM :: EgisonM a -> IO (Either EgisonError a)-fromEgisonM = modifyCounter . runEgisonM--loadPrimitives :: Env -> IO Env-loadPrimitives env = (++) <$> return env <*> primitiveEnv-   loadEgisonFile :: Env -> FilePath -> IO (Either EgisonError Env)-loadEgisonFile env path = modifyCounter $ runEgisonM $ loadFile path >>= evalTopExprs env+loadEgisonFile env path = evalEgisonTopExpr env (LoadFile path)  loadEgisonLibrary :: Env -> FilePath -> IO (Either EgisonError Env)-loadEgisonLibrary env path = modifyCounter $ runEgisonM $ loadLibraryFile path >>= evalTopExprs env--evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue)-evalEgisonExpr env expr = modifyCounter $ runEgisonM $ evalExpr' env expr--evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env)-evalEgisonTopExpr env exprs = modifyCounter $ runEgisonM $ evalTopExpr env exprs--evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)-evalEgisonTopExprs env exprs = modifyCounter $ runEgisonM $ evalTopExprs env exprs--runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env)-runEgisonTopExpr env input = modifyCounter $ runEgisonM $ readTopExpr input >>= evalTopExpr env+loadEgisonLibrary env path = evalEgisonTopExpr env (Load path) -runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env)-runEgisonTopExprs env input = modifyCounter $ runEgisonM $ readTopExprs input >>= evalTopExprs env

@@ -1,6 +1,34 @@ {-# Language TupleSections #-}-module Language.Egison.Core where +{- |+Module      : Language.Egison.Core+Copyright   : Satoshi Egi+Licence     : MIT++This module provides functions to evaluate various objects.+-}++module Language.Egison.Core+    (+    -- * Egison code evaluation+      evalTopExprs+    , evalTopExpr+    , evalTopExpr'+    , evalExpr+    , evalExprDeep+    , evalRef+    , evalRefDeep+    , evalWHNF+    , applyFunc+    -- * Environment+    , recursiveBind+    -- * Pattern matching+    , patternMatch+    -- * Utiltiy functions+    , fromStringWHNF+    , fromStringValue+    ) where+ import Prelude hiding (mapM)  import Control.Arrow@@ -11,6 +39,7 @@  import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) import qualified Data.Sequence as Sq+import Data.Foldable (toList) import Data.Traversable (mapM) import Data.IORef import Data.List@@ -40,7 +69,7 @@ evalTopExprs env exprs = do   (bindings, rest) <- collectDefs exprs [] []   env <- recursiveBind env bindings-  forM_ rest $ evalTopExpr env+  forM_ rest $ evalTopExpr' env   return env  where   collectDefs (expr:exprs) bindings rest =@@ -56,22 +85,30 @@   collectDefs [] bindings rest = return (bindings, reverse 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 expr) = do+evalTopExpr env topExpr = evalTopExpr'' env topExpr >>= return . snd++evalTopExpr' :: Env -> EgisonTopExpr -> EgisonM Env+evalTopExpr' env topExpr = do+  ret <- evalTopExpr'' env topExpr+  liftIO $ putStrLn $ fst ret+  return $ snd ret++evalTopExpr'' :: Env -> EgisonTopExpr -> EgisonM (String, Env)+evalTopExpr'' env (Define name expr) = recursiveBind env [(name, expr)] >>= return . ((,) "")+evalTopExpr'' env (Test expr) = do+  val <- evalExprDeep env expr+  return ((show val), env)+evalTopExpr'' env (Execute expr) = do   io <- evalExpr env expr   case io of-    Value (IOFunc m) -> m >> return env+    Value (IOFunc m) -> m >> return ("", env)     _ -> throwError $ TypeMismatch "io" io-evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env-evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env+evalTopExpr'' env (Load file) = loadLibraryFile file >>= evalTopExprs env >>= return . ((,) "")+evalTopExpr'' env (LoadFile file) = loadFile file >>= evalTopExprs env >>= return . ((,) "")  evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c-evalExpr _ (StringExpr s) = return $ Value $ makeStringValue s+evalExpr _ (StringExpr s) = return $ Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b evalExpr _ (RationalExpr x) = return . Value $ Rational x evalExpr _ (IntegerExpr i) = return . Value $ Integer i@@ -85,8 +122,7 @@  evalExpr _ (TupleExpr []) = return . Value $ Tuple [] evalExpr env (TupleExpr [expr]) = evalExpr env expr-evalExpr env (TupleExpr exprs) =-  Intermediate . ITuple <$> mapM (newThunk env) exprs +evalExpr env (TupleExpr exprs) = Intermediate . ITuple <$> mapM (newThunk env) exprs  evalExpr env (CollectionExpr inners) =   if Sq.null inners then@@ -103,8 +139,8 @@  evalExpr env (HashExpr assocs) = do   let (keyExprs, exprs) = unzip assocs-  keyVals <- mapM (evalExpr' env) keyExprs-  keys <- liftError $ mapM makeKey keyVals+  keyWhnfs <- mapM (evalExpr env) keyExprs+  keys <- mapM makeHashKey keyWhnfs   refs <- mapM (newThunk env) exprs   case head keys of     IntKey _ -> do@@ -115,41 +151,53 @@       let keys' = map (\key -> case key of                                  StrKey s -> s) keys       return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs+ where+  makeHashKey :: WHNFData -> EgisonM EgisonHashKey+  makeHashKey (Value val) =+    case val of+      Integer i -> return (IntKey i)+      Collection _ -> do+        str <- fromStringWHNF $ Value val+        return $ StrKey $ B.pack str+      _ -> throwError $ TypeMismatch "integer or string" $ Value val+  makeHashKey whnf = do+    str <- fromStringWHNF whnf+    return $ StrKey $ B.pack str  evalExpr env (IndexedExpr expr indices) = do   array <- evalExpr env expr-  indices <- mapM (evalExpr' env) indices+  indices <- mapM (evalExprDeep env) indices   refArray array indices  where   refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData   refArray val [] = return val    refArray (Value (Array array)) (index:indices) = do-    i <- (liftError . liftM fromInteger . fromIntegerValue) (Value index)+    i <- (liftM fromInteger . fromEgison) index     case IntMap.lookup i array of       Just val -> refArray (Value val) indices       Nothing -> return $ Value Undefined   refArray (Intermediate (IArray array)) (index:indices) = do-    i <- (liftError . liftM fromInteger . fromIntegerValue) (Value index)+    i <- (liftM fromInteger . fromEgison) index     case IntMap.lookup i array of       Just ref -> evalRef ref >>= flip refArray indices       Nothing -> return $ Value Undefined   refArray (Value (IntHash hash)) (index:indices) = do-    key <- liftError $ fromIntegerValue $ Value index+    key <- fromEgison index     case HL.lookup key hash of       Just val -> refArray (Value val) indices       Nothing -> return $ Value Undefined   refArray (Intermediate (IIntHash hash)) (index:indices) = do-    key <- liftError $ fromIntegerValue $ Value index+    key <- fromEgison index     case HL.lookup key hash of       Just ref -> evalRef ref >>= flip refArray indices       Nothing -> return $ Value Undefined   refArray (Value (StrHash hash)) (index:indices) = do-    key <- liftError $ fromStringValue $ Value index+    key <- fromStringWHNF $ Value index     case HL.lookup (B.pack key) hash of       Just val -> refArray (Value val) indices       Nothing -> return $ Value Undefined   refArray (Intermediate (IStrHash hash)) (index:indices) = do-    key <- liftError $ fromStringValue $ Value index+    key <- fromStringWHNF $ Value index     case HL.lookup (B.pack key) hash of       Just ref -> evalRef ref >>= flip refArray indices       Nothing -> return $ Value Undefined@@ -159,7 +207,7 @@ evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern  evalExpr env (IfExpr test expr expr') = do-  test <- evalExpr env test >>= liftError . fromBoolValue+  test <- evalExpr env test >>= fromWHNF   evalExpr env $ if test then expr else expr'  evalExpr env (LetExpr bindings expr) =@@ -203,7 +251,7 @@   io <- evalExpr env expr   case io of     Value (IOFunc m) -> do-      val <- m >>= evalDeep+      val <- m >>= evalWHNF       case val of         Tuple [_, val'] -> return $ Value val'     _ -> throwError $ TypeMismatch "io" io@@ -258,8 +306,8 @@ evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr) -evalExpr' :: Env -> EgisonExpr -> EgisonM EgisonValue-evalExpr' env expr = evalExpr env expr >>= evalDeep+evalExprDeep :: Env -> EgisonExpr -> EgisonM EgisonValue+evalExprDeep env expr = evalExpr env expr >>= evalWHNF  evalRef :: ObjectRef -> EgisonM WHNFData evalRef ref = do@@ -271,35 +319,36 @@       writeThunk ref val       return val -evalRef' :: ObjectRef -> EgisonM EgisonValue-evalRef' ref = do+evalRefDeep :: ObjectRef -> EgisonM EgisonValue+evalRefDeep ref = do   obj <- liftIO $ readIORef ref   case obj of     WHNF (Value val) -> return val     WHNF val -> do-      val <- evalDeep val+      val <- evalWHNF val       writeThunk ref $ Value val       return val     Thunk thunk -> do-      val <- thunk >>= evalDeep+      val <- thunk >>= evalWHNF       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 (IArray refs)) = do-  refs' <- mapM evalRef' $ IntMap.elems refs+evalWHNF :: WHNFData -> EgisonM EgisonValue+evalWHNF (Value val) = return val+evalWHNF (Intermediate (IInductiveData name refs)) =+  InductiveData name <$> mapM evalRefDeep refs+evalWHNF (Intermediate (IArray refs)) = do+  refs' <- mapM evalRefDeep $ IntMap.elems refs   return $ Array $ IntMap.fromList $ zip (enumFromTo 1 (IntMap.size refs)) refs'-evalDeep (Intermediate (IIntHash refs)) = do-  refs' <- mapM evalRef' refs+evalWHNF (Intermediate (IIntHash refs)) = do+  refs' <- mapM evalRefDeep refs   return $ IntHash refs'-evalDeep (Intermediate (IStrHash refs)) = do-  refs' <- mapM evalRef' refs+evalWHNF (Intermediate (IStrHash refs)) = do+  refs' <- mapM evalRefDeep refs   return $ StrHash refs'-evalDeep (Intermediate (ITuple refs)) = Tuple <$> mapM evalRef' refs-evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef' . Sq.fromList)+evalWHNF (Intermediate (ITuple [ref])) = evalRefDeep ref+evalWHNF (Intermediate (ITuple refs)) = Tuple <$> mapM evalRefDeep refs+evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList)  applyFunc :: WHNFData -> WHNFData -> EgisonM WHNFData applyFunc (Value (Func env [name] body)) arg = do@@ -311,9 +360,8 @@     then evalExpr (extendEnv env $ makeBindings names refs) body     else throwError $ ArgumentsNum (length names) (length refs) applyFunc (Value (PrimitiveFunc func)) arg = do---  fromTuple arg >>= mapM evalRef >>= liftM Value . func-  arg' <- fromTuple arg >>= mapM evalRef'-  liftM Value . func $ map Value arg'+  arg' <- evalWHNF arg+  liftM Value . func $ arg' applyFunc (Value (IOFunc m)) arg = do   case arg of      Value World -> m@@ -322,7 +370,7 @@  generateArray :: Env -> String -> EgisonExpr -> EgisonExpr -> EgisonM WHNFData generateArray env name size expr = do  -  size' <- evalExpr env size >>= either throwError (return . fromInteger) . fromIntegerValue+  size' <- evalExpr env size >>= fromWHNF >>= return . fromInteger   elems <- mapM genElem (enumFromTo 1 size')   return $ Intermediate $ IArray $ IntMap.fromList elems   where@@ -356,32 +404,6 @@   zipWithM_ (\ref expr -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) refs exprs   return env' -fromArray :: WHNFData -> EgisonM [ObjectRef]-fromArray (Intermediate (IArray refs)) = return $ IntMap.elems refs-fromArray (Value (Array vals)) = mapM (newEvaluatedThunk . Value) $ IntMap.elems vals-fromArray val = throwError $ TypeMismatch "array" val--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 vals)) =-  if Sq.null vals then return MNil-                  else fromSeq <$> 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 --@@ -448,10 +470,10 @@         _ -> throwError $ TypeMismatch "pattern constructor" func          LoopPat name (LoopRangeConstant start end) pat pat' -> do-      startNum' <- evalExpr' env' start-      startNum <- extractInteger startNum'-      endNum' <- evalExpr' env' end-      endNum <- extractInteger endNum'+      startNum' <- evalExpr env' start+      startNum <- fromWHNF startNum'+      endNum' <- evalExpr env' end+      endNum <- fromWHNF endNum'       if startNum > endNum         then do           return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)@@ -460,8 +482,8 @@           let loops' = LoopContextConstant (name, startNumRef) endNum pat pat' : loops           return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)     LoopPat name (LoopRangeVariable start lastNumPat) pat pat' -> do-      startNum' <- evalExpr' env' start-      startNum <- extractInteger startNum'+      startNum' <- evalExpr env' start+      startNum <- fromWHNF startNum'       startNumRef <- liftIO . newIORef . WHNF $ Value $ Integer startNum       lastNumRef <- liftIO . newIORef . WHNF $ Value $ Integer (startNum - 1)       return $ fromList [MState env loops bindings (MAtom lastNumPat lastNumRef (Value Something) : MAtom pat' target matcher : trees),@@ -470,8 +492,8 @@       case loops of         [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern"         LoopContextConstant (name, startNumRef) endNum pat pat' : loops -> do-          startNum' <- evalRef' startNumRef-          startNum <- extractInteger startNum'+          startNum' <- evalRef startNumRef+          startNum <- fromWHNF startNum'           let nextNum = startNum + 1           if nextNum > endNum             then return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)@@ -480,8 +502,8 @@               let loops' = LoopContextConstant (name, nextNumRef) endNum pat pat' : loops                return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)         LoopContextVariable (name, startNumRef) lastNumPat pat pat' : loops -> do-          startNum' <- evalRef' startNumRef-          startNum <- extractInteger startNum'+          startNum' <- evalRef startNumRef+          startNum <- fromWHNF startNum'           let nextNum = startNum + 1           nextNumRef <- liftIO . newIORef . WHNF $ Value $ Integer nextNum           let loops' = LoopContextVariable (name, nextNumRef) lastNumPat pat pat' : loops @@ -500,12 +522,10 @@       return $ fromList $ flip map patterns $ \pattern ->         MState env loops bindings (MAtom pattern target matcher : trees)     NotPat pattern -> throwError $ strMsg "should not reach here (cut pattern)"-    CutPat pattern -> -- TEMPORARY ignoring cut patterns-      return $ msingleton (MState env loops bindings ((MAtom pattern target matcher):trees))     PredPat pred -> do       func <- evalExpr env' pred       arg <- evalRef target-      result <- applyFunc func arg >>= liftError . fromBoolValue+      result <- applyFunc func arg >>= fromWHNF       if result then return $ msingleton $ (MState env loops bindings trees)                 else return MNil     LetPat bindings' pattern ->@@ -528,15 +548,15 @@         _ -> -- Value Something -> -- for tupple patterns           case pattern of             ValuePat valExpr -> do-              val <- evalExpr' env' valExpr-              tgtVal <- evalRef' target+              val <- evalExprDeep env' valExpr+              tgtVal <- evalRefDeep target               if val == tgtVal                 then return $ msingleton $ MState env loops bindings trees                 else return MNil             WildCard -> return $ msingleton $ MState env loops bindings trees             PatVar name -> return $ msingleton $ MState env loops ((name, target):bindings) trees             IndexedPat (PatVar name) indices -> do-              indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices+              indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices               case lookup name bindings of                 Just ref -> do                   obj <- evalRef ref >>= flip updateArray indices >>= newEvaluatedThunk@@ -589,7 +609,7 @@               let env'' = extendEnv env' (bindings' ++ map (\lc -> case lc of                                                                      (LoopContextConstant binding _ _ _) -> binding                                                                      (LoopContextVariable binding _ _ _) -> binding) loops')-              indices <- mapM (evalExpr env'' >=> liftError . liftM fromInteger . fromIntegerValue) indices+              indices <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices               let pattern' = IndexedPat pattern $ map IntegerExpr indices               return $ msingleton $ MState env loops bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' bindings' trees'):trees)             Nothing -> throwError $ UnboundVariable name@@ -657,8 +677,8 @@   (++) <$> 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+  target <- lift (evalRef ref) >>= either (const matchFail) return . fromBuiltinWHNF+  isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target   if isEqual then return [] else matchFail  expandCollection :: WHNFData -> EgisonM (Seq Inner)@@ -726,3 +746,51 @@        lift $ writeThunk ref coll        unsnocCollection' coll   unsnocCollection' _ = matchFail++--+-- Util+--+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 vals)) =+  if Sq.null vals then return MNil+                  else fromSeq <$> 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++--+-- String+--+fromStringWHNF :: WHNFData -> EgisonM String+fromStringWHNF (Value (Collection seq)) = do+  let ls = toList seq+  mapM (\val -> case val of+                  Char c -> return c+                  _ -> throwError $ TypeMismatch "char" (Value val))+       ls+fromStringWHNF (Value (Tuple [val])) = fromStringWHNF (Value val)+fromStringWHNF whnf@(Intermediate (ICollection _)) = evalWHNF whnf >>= fromStringWHNF . Value+fromStringWHNF whnf = throwError $ TypeMismatch "string" whnf++fromStringValue :: EgisonValue -> EgisonM String+fromStringValue (Collection seq) = do+  let ls = toList seq+  mapM (\val -> case val of+                  Char c -> return c+                  _ -> throwError $ TypeMismatch "char" (Value val))+       ls+fromStringValue (Tuple [val]) = fromStringValue val+fromStringValue val = throwError $ TypeMismatch "string" (Value val)

@@ -1,5 +1,21 @@ {-# Language FlexibleInstances, GeneralizedNewtypeDeriving #-}-module Language.Egison.Desugar where++{- |+Module      : Language.Egison.Desugar+Copyright   : Satoshi Egi+Licence     : MIT++This module provide desugar functions.+-}++module Language.Egison.Desugar+    (+      DesugarM+    , runDesugarM+    , desugarTopExpr+    , desugar+    ) where+ import Control.Applicative (Applicative) import Control.Applicative ((<$>), (<*>), (<*), (*>), pure) import qualified Data.Sequence as Sq@@ -193,7 +209,6 @@    collectNames patterns = S.unions $ map collectName patterns     collectName :: EgisonPattern -> Set String-   collectName (CutPat pattern) = collectName pattern     collectName (NotPat pattern) = collectName pattern    collectName (AndPat patterns) = collectNames patterns    collectName (TuplePat patterns) = collectNames patterns@@ -211,7 +226,6 @@ desugarPattern' :: EgisonPattern -> DesugarM EgisonPattern desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr-desugarPattern' (CutPat pattern) = CutPat <$> desugarPattern' pattern desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (TuplePat patterns)  = TuplePat <$> mapM desugarPattern' patterns

@@ -1,15 +1,24 @@ {-# LANGUAGE TupleSections #-}++{- |+Module      : Language.Egison.Parser+Copyright   : Satoshi Egi+Licence     : MIT++This module provide Egison parser.+-}+ module Language.Egison.Parser -       ( readTopExprs+       (+       -- * Parse a string+         readTopExprs        , readTopExpr        , readExprs        , readExpr-       , loadFile+       -- * Parse a file        , loadLibraryFile-       , parseTopExprs-       , parseTopExpr-       , parseExprs-       , parseExpr ) where+       , loadFile+       ) where  import Prelude hiding (mapM) import Control.Monad.Identity hiding (mapM)@@ -36,12 +45,6 @@ import Language.Egison.Types import Language.Egison.Desugar import Paths_egison (getDataFileName)-  -doParse :: Parser a -> String -> Either EgisonError a-doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input-  where-    fromParsecError :: ParseError -> EgisonError-    fromParsecError = Parser . show  readTopExprs :: String -> EgisonM [EgisonTopExpr] readTopExprs = liftEgisonM . runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs@@ -55,6 +58,11 @@ readExpr :: String -> EgisonM EgisonExpr readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr +-- |Load a libary file+loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile++-- |Load a file loadFile :: FilePath -> EgisonM [EgisonTopExpr] loadFile file = do   doesExist <- liftIO $ doesFileExist file@@ -70,9 +78,15 @@   shebang ('#':'!':cs) = ';':'#':'!':cs   shebang cs = cs +--+-- Parser+-- -loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]-loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile+doParse :: Parser a -> String -> Either EgisonError a+doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input+  where+    fromParsecError :: ParseError -> EgisonError+    fromParsecError = Parser . show  parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] parseTopExprs = doParse $ whiteSpace >> endBy topExpr whiteSpace@@ -89,7 +103,6 @@ -- -- Expressions --- topExpr :: Parser EgisonTopExpr topExpr = parens (defineExpr               <|> testExpr@@ -334,7 +347,6 @@             <|> varPat             <|> valuePat             <|> predPat-            <|> cutPat             <|> notPat             <|> tuplePat             <|> inductivePat@@ -363,9 +375,6 @@ letPat :: Parser EgisonPattern letPat = keywordLet >> LetPat <$> bindings <*> pattern -cutPat :: Parser EgisonPattern-cutPat = reservedOp "!" >> CutPat <$> pattern- notPat :: Parser EgisonPattern notPat = reservedOp "^" >> NotPat <$> pattern @@ -487,7 +496,6 @@   , "&"   , "|"   , "^"-  , "!"   , ","   , "@"   , "..."]

@@ -1,4 +1,13 @@ {-# Language FlexibleContexts #-}++{- |+Module      : Language.Egison.Primitives+Copyright   : Satoshi Egi+Licence     : MIT++This module provides primitive functions in Egison.+-}+ module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where  import Control.Arrow@@ -51,38 +60,37 @@   return $ extendEnv nullEnv bindings  {-# INLINE noArg #-}-noArg :: (MonadError EgisonError m) =>-         m EgisonValue ->-         [WHNFData] -> m EgisonValue-noArg f = \vals -> case vals of +noArg :: EgisonM EgisonValue ->+         EgisonValue -> EgisonM EgisonValue+noArg f = \args -> case tupleToList args of                       [] -> f-                     _ -> throwError $ ArgumentsNum 0 $ length vals+                     vals -> throwError $ ArgumentsNum 0 $ length vals  {-# INLINE oneArg #-}-oneArg :: (MonadError EgisonError m) =>-          (WHNFData -> m EgisonValue) ->-          [WHNFData] -> m EgisonValue-oneArg f = \vals -> case vals of -                      [val] -> f val-                      [] -> f $ Value $ Tuple []-                      _ -> throwError $ ArgumentsNum 1 $ length vals+oneArg :: (EgisonValue -> EgisonM EgisonValue) ->+          EgisonValue -> EgisonM EgisonValue+oneArg f = \args -> case args of+                      (Tuple [val]) -> f val+                      _ -> f args  {-# INLINE twoArgs #-}-twoArgs :: (MonadError EgisonError m) =>-           (WHNFData -> WHNFData -> m EgisonValue) ->-           [WHNFData] -> m EgisonValue-twoArgs f = \vals -> case vals of +twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) ->+           EgisonValue -> EgisonM EgisonValue+twoArgs f = \args -> case tupleToList args of                         [val, val'] -> f val val'-                       _ -> throwError $ ArgumentsNum 2 $ length vals+                       vals -> throwError $ ArgumentsNum 2 $ length vals  {-# INLINE threeArgs #-}-threeArgs :: (MonadError EgisonError m) =>-             (WHNFData -> WHNFData -> WHNFData -> m EgisonValue) ->-             [WHNFData] -> m EgisonValue-threeArgs f = \vals -> case vals of +threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) ->+             EgisonValue -> EgisonM EgisonValue+threeArgs f = \args -> case tupleToList args of                           [val, val', val''] -> f val val' val''-                         _ -> throwError $ ArgumentsNum 3 $ length vals+                         vals -> throwError $ ArgumentsNum 3 $ length vals +tupleToList :: EgisonValue -> [EgisonValue]+tupleToList (Tuple vals) = vals+tupleToList val = [val]+ -- -- Constants --@@ -95,28 +103,29 @@ --  primitives :: [(String, PrimitiveFunc)]-primitives = [ ("+i", integerBinaryOp (+)) -             , ("-i", integerBinaryOp (-))-             , ("*i", integerBinaryOp (*))+primitives = [ ("+", plus)+             , ("-", minus)+             , ("*", multiply)+             , ("/", divide)+             , ("/-inverse", divideInverse)+                             , ("modulo",    integerBinaryOp mod)              , ("quotient",   integerBinaryOp quot)              , ("remainder", integerBinaryOp rem)-             , ("eq-i?",  integerBinaryPred (==))-             , ("lt-i?",  integerBinaryPred (<))-             , ("lte-i?", integerBinaryPred (<=))-             , ("gt-i?",  integerBinaryPred (>))-             , ("gte-i?", 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)+               +             , ("eq?",  eq)+             , ("lt?",  lt)+             , ("lte?", lte)+             , ("gt?",  gt)+             , ("gte?", gte)+               +             , ("round",    floatToIntegerOp round)+             , ("floor",    floatToIntegerOp floor)+             , ("ceiling",  floatToIntegerOp ceiling)+             , ("truncate", floatToIntegerOp truncate)+                             , ("sqrt", floatUnaryOp sqrt)              , ("exp", floatUnaryOp exp)              , ("log", floatUnaryOp log)@@ -132,24 +141,15 @@              , ("asinh", floatUnaryOp asinh)              , ("acosh", floatUnaryOp acosh)              , ("atanh", floatUnaryOp atanh)-             , ("round",    floatToIntegerOp round)-             , ("floor",    floatToIntegerOp floor)-             , ("ceiling",  floatToIntegerOp ceiling)-             , ("truncate", floatToIntegerOp truncate)+                             , ("itof", integerToFloat)              , ("rtof", rationalToFloat)-             , ("itos", integerToString)+                             , ("stoi", stringToInteger)-             , ("eq?",  eq)-             , ("lt?",  lt)-             , ("lte?", lte)-             , ("gt?",  gt)-             , ("gte?", gte)-             , ("+", plus)-             , ("-", minus)-             , ("*", multiply)-             , ("/", divide)-             , ("/-inverse", divideInverse)+               +             , ("read", read')+             , ("show", show')+                             , ("assert", assert)              , ("assert-equal", assertEqual) @@ -163,194 +163,224 @@              ]  integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc-integerUnaryOp op = (liftError .) $ oneArg $ \val ->-  Integer . op <$> fromIntegerValue val-+integerUnaryOp op = oneArg $ \val -> do+  i <- fromEgison val+  return $ Integer $ op i+   integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc-integerBinaryOp op = (liftError .) $ twoArgs $ \val val' ->-  (Integer .) . op <$> fromIntegerValue val-                   <*> fromIntegerValue val'+integerBinaryOp op = twoArgs $ \val val' -> do+  i <- fromEgison val+  i' <- fromEgison val'+  return $ Integer $ op i i'  integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc-integerBinaryPred pred = (liftError .) $ twoArgs $ \val val' ->-  (Bool .) . pred <$> fromIntegerValue val-                  <*> fromIntegerValue val'+integerBinaryPred pred = twoArgs $ \val val' -> do+  i <- fromEgison val+  i' <- fromEgison val'+  return $ Bool $ pred i i'  floatUnaryOp :: (Double -> Double) -> PrimitiveFunc-floatUnaryOp op = (liftError .) $ oneArg $ \val ->-  Float . op <$> fromFloatValue val+floatUnaryOp op = oneArg $ \val -> do+  f <- fromEgison val+  return $ Float $ op f  floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc-floatBinaryOp op = (liftError .) $ twoArgs $ \val val' ->-  (Float .) . op <$> fromFloatValue val-                 <*> fromFloatValue val'+floatBinaryOp op = twoArgs $ \val val' -> do+  f <- fromEgison val+  f' <- fromEgison val'+  return $ Float $ op f f'  floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc-floatBinaryPred pred = (liftError .) $ twoArgs $ \val val' ->-  (Bool .) . pred <$> fromFloatValue val-                  <*> fromFloatValue val'+floatBinaryPred pred = twoArgs $ \val val' -> do+  f <- fromEgison val+  f' <- fromEgison val'+  return $ Bool $ pred f f' -floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc-floatToIntegerOp op = (liftError .) $ oneArg $ \val ->-  Integer . op <$> fromFloatValue val+--+-- Arith+--+plus :: PrimitiveFunc+plus = twoArgs $ \val val' -> numberBinaryOp' val val'+ where+  numberBinaryOp' (Integer i)  (Integer i')  = return $ Integer $ (+) i  i'+  numberBinaryOp' (Integer i)  val           = numberBinaryOp' (Rational (i % 1)) val+  numberBinaryOp' val          (Integer i)   = numberBinaryOp' val (Rational (i % 1)) +  numberBinaryOp' (Rational r) (Rational r') = let y = (+) r r' in+                                                 if denominator y == 1+                                                   then return $ Integer $ numerator y+                                                   else return $ Rational y+  numberBinaryOp' (Rational r) (Float f)     = numberBinaryOp' (Float (fromRational r)) (Float f)+  numberBinaryOp' (Float f)    (Rational r)  = numberBinaryOp' (Float f) (Float (fromRational r))+  numberBinaryOp' (Float f)    (Float f')    = return $ Float $ (+) f f'+  numberBinaryOp' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' val          _             = throwError $ TypeMismatch "number" (Value val) -integerToFloat :: PrimitiveFunc-integerToFloat = (liftError .) $ oneArg $ \val ->-  Float . fromInteger <$> fromIntegerValue val+minus :: PrimitiveFunc+minus = twoArgs $ \val val' -> numberBinaryOp' val val'+ where+  numberBinaryOp' (Integer i)  (Integer i')  = return $ Integer $ (-) i  i'+  numberBinaryOp' (Integer i)  val           = numberBinaryOp' (Rational (i % 1)) val+  numberBinaryOp' val          (Integer i)   = numberBinaryOp' val (Rational (i % 1)) +  numberBinaryOp' (Rational r) (Rational r') = let y = (-) r r' in+                                                 if denominator y == 1+                                                   then return $ Integer $ numerator y+                                                   else return $ Rational y+  numberBinaryOp' (Rational r) (Float f)     = numberBinaryOp' (Float (fromRational r)) (Float f)+  numberBinaryOp' (Float f)    (Rational r)  = numberBinaryOp' (Float f) (Float (fromRational r))+  numberBinaryOp' (Float f)    (Float f')    = return $ Float $ (-) f f'+  numberBinaryOp' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' val          _             = throwError $ TypeMismatch "number" (Value val) -rationalToFloat :: PrimitiveFunc-rationalToFloat = (liftError .) $ oneArg $ \val ->-  Float . fromRational <$> fromRationalValue val+multiply :: PrimitiveFunc+multiply = twoArgs $ \val val' -> numberBinaryOp' val val'+ where+  numberBinaryOp' (Integer i)  (Integer i')  = return $ Integer $ (*) i  i'+  numberBinaryOp' (Integer i)  val           = numberBinaryOp' (Rational (i % 1)) val+  numberBinaryOp' val          (Integer i)   = numberBinaryOp' val (Rational (i % 1)) +  numberBinaryOp' (Rational r) (Rational r') = let y = (*) r r' in+                                                 if denominator y == 1+                                                   then return $ Integer $ numerator y+                                                   else return $ Rational y+  numberBinaryOp' (Rational r) (Float f)     = numberBinaryOp' (Float (fromRational r)) (Float f)+  numberBinaryOp' (Float f)    (Rational r)  = numberBinaryOp' (Float f) (Float (fromRational r))+  numberBinaryOp' (Float f)    (Float f')    = return $ Float $ (*) f f'+  numberBinaryOp' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' val          _             = throwError $ TypeMismatch "number" (Value val) -integerToString :: PrimitiveFunc-integerToString = (liftError .) $ oneArg $ \val ->-   makeStringValue . show <$> fromIntegerValue val+divide :: PrimitiveFunc+divide = twoArgs $ \val val' -> numberBinaryOp' val val'+ where+  numberBinaryOp' (Integer i)  (Integer i')  = return $ Rational $ (%) i  i'+  numberBinaryOp' (Integer i)  val           = numberBinaryOp' (Rational (i % 1)) val+  numberBinaryOp' val          (Integer i)   = numberBinaryOp' val (Rational (i % 1)) +  numberBinaryOp' (Rational r) (Rational r') =+    let m = numerator r' in+    let n = denominator r' in+    let y = (r * (n % m)) in+      if denominator y == 1+        then return $ Integer $ numerator y+        else return $ Rational y+  numberBinaryOp' (Rational r) (Float f)    = numberBinaryOp' (Float (fromRational r)) (Float f)+  numberBinaryOp' (Float f)    (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r))+  numberBinaryOp' (Float f)    (Float f')   = return $ Float $ (/) f f'+  numberBinaryOp' (Rational _) val          = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' (Float _)    val          = throwError $ TypeMismatch "number" (Value val)+  numberBinaryOp' val          _            = throwError $ TypeMismatch "number" (Value val) -stringToInteger :: PrimitiveFunc-stringToInteger = (liftError .) $ oneArg $ \val -> do-   numStr <- fromStringValue val-   return $ Integer (read numStr :: Integer)+divideInverse :: PrimitiveFunc+divideInverse =  oneArg $ divideInverse'+ where+  divideInverse' (Rational rat) = do+    return $ Tuple [Integer (numerator rat), Integer (denominator rat)]+  divideInverse' (Integer x) = do+    return $ Tuple [Integer x, Integer 1]+  divideInverse' val = throwError $ TypeMismatch "rational" (Value val) +--+-- Pred+-- eq :: PrimitiveFunc-eq = (liftError .) $ twoArgs $ \val val' ->-  (Bool .) . (==) <$> fromPrimitiveValue val-                  <*> fromPrimitiveValue val'+eq = twoArgs $ \val val' ->+  return $ Bool $ val == val'  lt :: PrimitiveFunc-lt = (liftError .) $ twoArgs lt'+lt = twoArgs $ \val val' -> numberBinaryPred' val val'  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-+  numberBinaryPred' (Integer i)  (Integer i')  = return $ Bool $ (<) i  i'+  numberBinaryPred' (Integer i)  val           = numberBinaryPred' (Rational (i % 1)) val+  numberBinaryPred' val          (Integer i)   = numberBinaryPred' val (Rational (i % 1)) +  numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<) r r'+  numberBinaryPred' (Rational r) (Float f)     = numberBinaryPred' (Float (fromRational r)) (Float f)+  numberBinaryPred' (Float f)    (Rational r)  = numberBinaryPred' (Float f) (Float (fromRational r))+  numberBinaryPred' (Float f)    (Float f')    = return $ Bool $ (<) f f'+  numberBinaryPred' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+   lte :: PrimitiveFunc-lte = (liftError .) $ twoArgs lte'+lte = twoArgs $ \val val' -> numberBinaryPred' val val'  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-+  numberBinaryPred' (Integer i)  (Integer i')  = return $ Bool $ (<=) i  i'+  numberBinaryPred' (Integer i)  val           = numberBinaryPred' (Rational (i % 1)) val+  numberBinaryPred' val          (Integer i)   = numberBinaryPred' val (Rational (i % 1)) +  numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<=) r r'+  numberBinaryPred' (Rational r) (Float f)     = numberBinaryPred' (Float (fromRational r)) (Float f)+  numberBinaryPred' (Float f)    (Rational r)  = numberBinaryPred' (Float f) (Float (fromRational r))+  numberBinaryPred' (Float f)    (Float f')    = return $ Bool $ (<=) f f'+  numberBinaryPred' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+   gt :: PrimitiveFunc-gt = (liftError .) $ twoArgs gt'+gt = twoArgs $ \val val' -> numberBinaryPred' val val'  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-+  numberBinaryPred' (Integer i)  (Integer i')  = return $ Bool $ (>) i  i'+  numberBinaryPred' (Integer i)  val           = numberBinaryPred' (Rational (i % 1)) val+  numberBinaryPred' val          (Integer i)   = numberBinaryPred' val (Rational (i % 1)) +  numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>) r r'+  numberBinaryPred' (Rational r) (Float f)     = numberBinaryPred' (Float (fromRational r)) (Float f)+  numberBinaryPred' (Float f)    (Rational r)  = numberBinaryPred' (Float f) (Float (fromRational r))+  numberBinaryPred' (Float f)    (Float f')    = return $ Bool $ (>) f f'+  numberBinaryPred' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+   gte :: PrimitiveFunc-gte = (liftError .) $ twoArgs gte'+gte = twoArgs $ \val val' -> numberBinaryPred' val val'  where-  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+  numberBinaryPred' (Integer i)  (Integer i')  = return $ Bool $ (>=) i  i'+  numberBinaryPred' (Integer i)  val           = numberBinaryPred' (Rational (i % 1)) val+  numberBinaryPred' val          (Integer i)   = numberBinaryPred' val (Rational (i % 1)) +  numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>=) r r'+  numberBinaryPred' (Rational r) (Float f)     = numberBinaryPred' (Float (fromRational r)) (Float f)+  numberBinaryPred' (Float f)    (Rational r)  = numberBinaryPred' (Float f) (Float (fromRational r))+  numberBinaryPred' (Float f)    (Float f')    = return $ Bool $ (>=) f f'+  numberBinaryPred' (Rational _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (Float _)    val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+  +--+-- Transform+--+integerToFloat :: PrimitiveFunc+integerToFloat = oneArg $ \val -> do+  i <- fromEgison val+  return $ Float $ fromInteger i -plus :: PrimitiveFunc-plus = (liftError .) $ twoArgs plus'- where-  plus' (Value (Integer x)) (Value (Integer x')) = return $ Integer $ (x + x')-  plus' (Value (Integer i)) val = plus' (Value (Rational (i % 1))) val-  plus' val (Value (Integer i)) = plus' val (Value (Rational (i % 1)))-  plus' (Value (Rational x)) (Value (Rational x')) = let y = (x + x') in-                                                      if denominator y == 1-                                                        then return $ Integer $ numerator y-                                                        else return $ Rational y-  plus' (Value (Float f)) (Value (Float f')) = return $ Float $ f + f'-  plus' (Value (Rational i)) (Value (Float f)) = return $ Float $ (fromRational i) + f-  plus' (Value (Float f)) (Value (Rational i)) = return $ Float $ f + (fromRational i)-  plus' (Value (Rational _)) val = throwError $ TypeMismatch "number" val-  plus' (Value (Float _)) val = throwError $ TypeMismatch "number" val-  plus' val _ = throwError $ TypeMismatch "number" val+rationalToFloat :: PrimitiveFunc+rationalToFloat = oneArg $ \val -> do+  r <- fromEgison val+  return $ Float $ fromRational r -minus :: PrimitiveFunc-minus = (liftError .) $ twoArgs minus'- where-  minus' (Value (Integer x)) (Value (Integer x')) = return $ Integer $ (x - x')-  minus' (Value (Integer i)) val = minus' (Value (Rational (i % 1))) val-  minus' val (Value (Integer i)) = minus' val (Value (Rational (i % 1)))-  minus' (Value (Rational x)) (Value (Rational x')) = let y = (x - x') in-                                                      if denominator y == 1-                                                        then return $ Integer $ numerator y-                                                        else return $ Rational y-  minus' (Value (Float f)) (Value (Float f')) = return $ Float $ f - f'-  minus' (Value (Rational i)) (Value (Float f)) = return $ Float $ (fromRational i) - f-  minus' (Value (Float f)) (Value (Rational i)) = return $ Float $ f - (fromRational i)-  minus' (Value (Rational _)) val = throwError $ TypeMismatch "number" val-  minus' (Value (Float _)) val = throwError $ TypeMismatch "number" val-  minus' val _ = throwError $ TypeMismatch "number" val+floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc+floatToIntegerOp op = oneArg $ \val -> do+  f <- fromEgison val+  return $ Integer $ op f -multiply :: PrimitiveFunc-multiply = (liftError .) $ twoArgs multiply'- where-  multiply' (Value (Integer x)) (Value (Integer x')) = return $ Integer $ (x * x')-  multiply' (Value (Integer i)) val = multiply' (Value (Rational (i % 1))) val-  multiply' val (Value (Integer i)) = multiply' val (Value (Rational (i % 1)))-  multiply' (Value (Rational x)) (Value (Rational x')) = let y = (x * x') in-                                                      if denominator y == 1-                                                        then return $ Integer $ numerator y-                                                        else return $ Rational y-  multiply' (Value (Float f)) (Value (Float f')) = return $ Float $ f * f'-  multiply' (Value (Rational i)) (Value (Float f)) = return $ Float $ (fromRational i) * f-  multiply' (Value (Float f)) (Value (Rational i)) = return $ Float $ f * (fromRational i)-  multiply' (Value (Rational _)) val = throwError $ TypeMismatch "number" val-  multiply' (Value (Float _)) val = throwError $ TypeMismatch "number" val-  multiply' val _ = throwError $ TypeMismatch "number" val+read' :: PrimitiveFunc+read'= oneArg $ \val -> fromStringValue val >>= readExpr >>= evalExprDeep nullEnv -divide :: PrimitiveFunc-divide = (liftError .) $ twoArgs divide'- where-  divide' (Value (Integer x)) (Value (Integer x')) = return $ Rational $ (x % x')-  divide' (Value (Integer i)) val = divide' (Value (Rational (i % 1))) val-  divide' val (Value (Integer i)) = divide' val (Value (Rational (i % 1)))-  divide' (Value (Rational x)) (Value (Rational x')) =-    let m = numerator x' in-    let n = denominator x' in-    let y = (x * (n % m)) in-      if denominator y == 1-        then return $ Integer $ numerator y-        else return $ Rational y-  divide' (Value (Rational x)) (Value (Float f)) = return $ Float $ (fromRational x) / f-  divide' (Value (Float f)) (Value (Rational x)) = return $ Float $ f / (fromRational x)-  divide' (Value (Rational _)) val = throwError $ TypeMismatch "number" val-  divide' (Value (Float f)) (Value (Float f')) = return $ Float $ f / f'-  divide' (Value (Float _)) val = throwError $ TypeMismatch "number" val-  divide' val _ = throwError $ TypeMismatch "number" val+show' :: PrimitiveFunc+show'= oneArg $ \val -> return $ toEgison $ show val -divideInverse :: PrimitiveFunc-divideInverse = (liftError .) $ oneArg $ divideInverse'- where-  divideInverse' (Value (Rational rat)) = do-    return $ Tuple [Integer (numerator rat), Integer (denominator rat)]-  divideInverse' (Value (Integer x)) = do-    return $ Tuple [Integer x, Integer 1]-  divideInverse' val = throwError $ TypeMismatch "rational" val+stringToInteger :: PrimitiveFunc+stringToInteger = oneArg $ \val -> do+  numStr <- fromEgison val+  return $ Integer (read numStr :: Integer) + assert ::  PrimitiveFunc-assert = (liftError .) $ twoArgs $ \label test -> do-  test <- fromBoolValue test+assert = twoArgs $ \label test -> do+  test <- fromEgison test   if test     then return $ Bool True     else throwError $ Assertion $ show label  assertEqual :: PrimitiveFunc 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 ++@@ -361,7 +391,7 @@   dbName <- fromStringValue val   qStr <- fromStringValue val'   let ret = unsafePerformIO $ query' (T.pack dbName) $ T.pack qStr-  return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeStringValue r)) ret+  return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeEgisonString r)) ret  where   query' :: T.Text -> T.Text -> IO [[String]]   query' dbName q = do@@ -384,7 +414,7 @@   dbName <- fromStringValue val   qStr <- fromStringValue val'   let ret = unsafePerformIO $ query' dbName $ BC.pack qStr-  return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeStringValue r)) ret+  return $ Collection $ Sq.fromList $ map (\r -> Tuple (map makeEgisonString r)) ret  where   query' :: String -> ByteString -> IO [[String]]   query' dbName q = do@@ -409,23 +439,21 @@ --  ioPrimitives :: [(String, PrimitiveFunc)]-ioPrimitives = [ ("return", return')+ioPrimitives = [+                 ("return", return')                , ("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", writeToStdout)+                                 , ("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)                                  , ("eof?", isEOFStdin)                , ("flush", flushStdout)@@ -434,8 +462,6 @@                , ("read-file", readFile')                                  , ("rand", randRange)-                 ---             , ("get-lib-dir-name", getLibDirName)                ]  makeIO :: EgisonM EgisonValue -> EgisonValue@@ -445,77 +471,85 @@ makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []])  return' :: PrimitiveFunc-return' = oneArg $ return . makeIO . evalDeep+return' = oneArg $ \val -> return $ makeIO $ return val  makePort :: IOMode -> PrimitiveFunc-makePort mode = (liftError .) $ oneArg $ \val -> do-  filename <- fromStringValue val -  return . makeIO . liftIO $ Port <$> openFile filename mode+makePort mode = oneArg $ \val -> do+  filename <- fromEgison val+  port <- liftIO $ openFile filename mode+  return $ makeIO $ return (Port port)  closePort :: PrimitiveFunc-closePort = (liftError .) $ oneArg $ \val ->-  makeIO' . liftIO . hClose <$> fromPortValue val+closePort = oneArg $ \val -> do+  port <- fromEgison val+  return $ makeIO' $ liftIO $ hClose port  writeChar :: PrimitiveFunc-writeChar = (liftError .) $ oneArg $ \val ->-  makeIO' . liftIO . putChar <$> fromCharValue val--writeString :: PrimitiveFunc-writeString = (liftError .) $ oneArg $ \val ->-  makeIO' . liftIO . putStr <$> fromStringValue val--writeToStdout :: PrimitiveFunc-writeToStdout = oneArg $ \val ->-  makeIO' . liftIO . putStr . show <$> evalDeep val--readChar :: PrimitiveFunc-readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar+writeChar = oneArg $ \val -> do+  c <- fromEgison val+  return $ makeIO' $ liftIO $ putChar c -readLine :: PrimitiveFunc-readLine = noArg $ return $ makeIO $ liftIO $ liftM makeStringValue getLine+writeCharToPort :: PrimitiveFunc+writeCharToPort = twoArgs $ \val val' -> do+  port <- fromEgison val+  c <- fromEgison val'+  return $ makeIO' $ liftIO $ hPutChar port c -readFromStdin :: PrimitiveFunc-readFromStdin = noArg $ return $ makeIO $ (liftIO getLine) >>= readExpr >>= evalExpr' nullEnv+writeString :: PrimitiveFunc+writeString = oneArg $ \val -> do+  s <- fromEgison val+  return $ makeIO' $ liftIO $ putStr s+  +writeStringToPort :: PrimitiveFunc+writeStringToPort = twoArgs $ \val val' -> do+  port <- fromEgison val+  s <- fromEgison val'+  return $ makeIO' $ liftIO $ hPutStr port s  flushStdout :: PrimitiveFunc flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout -isEOFStdin :: PrimitiveFunc-isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF--writeCharToPort :: PrimitiveFunc-writeCharToPort = (liftError .) $ twoArgs $ \val val' ->-  ((makeIO' . liftIO) .) . hPutChar <$> fromPortValue val <*> fromCharValue val'--writeStringToPort :: PrimitiveFunc-writeStringToPort = (liftError .) $ twoArgs $ \val val' ->-  ((makeIO' . liftIO) .) . hPutStr <$> fromPortValue val <*> fromStringValue val'+flushPort :: PrimitiveFunc+flushPort = oneArg $ \val -> do+  port <- fromEgison val+  return $ makeIO' $ liftIO $ hFlush port -writeToPort :: PrimitiveFunc-writeToPort = twoArgs $ \val val' -> do-  ((makeIO' . liftIO) .) . hPutStr <$> liftError (fromPortValue val)-                                   <*> (show <$> evalDeep val')+readChar :: PrimitiveFunc+readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar  readCharFromPort :: PrimitiveFunc-readCharFromPort = (liftError .) $ oneArg $ \val ->-  makeIO . liftIO . liftM Char . hGetChar <$> fromPortValue val+readCharFromPort = oneArg $ \val -> do+  port <- fromEgison val+  c <- liftIO $ hGetChar port+  return $ makeIO $ return (Char c) +readLine :: PrimitiveFunc+readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison getLine+ readLineFromPort :: PrimitiveFunc-readLineFromPort = (liftError .) $ oneArg $ \val ->-  makeIO . liftIO . liftM makeStringValue . hGetLine <$> fromPortValue val+readLineFromPort = oneArg $ \val -> do+  port <- fromEgison val+  s <- liftIO $ hGetLine port+  return $ makeIO $ return $ toEgison s -flushPort :: PrimitiveFunc-flushPort = (liftError .) $ oneArg $ \val ->-  makeIO' . liftIO . hFlush <$> fromPortValue val+readFile' :: PrimitiveFunc+readFile' =  oneArg $ \val -> do+  filename <- fromEgison val+  s <- liftIO $ readFile filename+  return $ makeIO $ return $ toEgison s+  +isEOFStdin :: PrimitiveFunc+isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF  isEOFPort :: PrimitiveFunc-isEOFPort = (liftError .) $ oneArg $ \val ->-  makeIO . liftIO . liftM Bool . hIsEOF <$> fromPortValue val+isEOFPort = oneArg $ \val -> do+  port <- fromEgison val+  b <- liftIO $ hIsEOF port+  return $ makeIO $ return (Bool b) -readFile' :: PrimitiveFunc-readFile' =  (liftError .) $ oneArg $ \val ->-  makeIO . liftIO . liftM makeStringValue . readFile <$> fromStringValue val-   randRange :: PrimitiveFunc-randRange = (liftError .) $ twoArgs $ \val val' ->-  return . makeIO . liftIO . liftM Integer . getStdRandom . randomR =<< liftM2 (,) (fromIntegerValue val) (fromIntegerValue val')+randRange = twoArgs $ \val val' -> do+  i <- fromEgison val+  i' <- fromEgison val'+  n <- liftIO $ getStdRandom $ randomR (i, i')+  return $ makeIO $ return (Integer n)

@@ -1,7 +1,81 @@ {-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable #-}-module Language.Egison.Types where+             MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable,+             TypeFamilies #-}+{- |+Module      : Language.Egison.Types+Copyright   : Satoshi Egi+Licence     : MIT +This module contains type definitions of Egison Data.+-}++module Language.Egison.Types+    (+    -- * Egison expressions+      EgisonTopExpr (..)+    , EgisonExpr (..)+    , EgisonPattern (..)+    , InnerExpr (..)+    , BindingExpr (..)+    , MatchClause (..)+    , MatcherInfo (..)+    , LoopRange (..)+    , PrimitivePatPattern (..)+    , PrimitiveDataPattern (..)+    -- * Egison values+    , EgisonValue (..)+    , Matcher (..)+    , PrimitiveFunc (..)+    , EgisonHashKey  (..) -- TODO ?+    , Egison (..)+    , fromMatcherValue+    -- * Internal data+    , Object (..)+    , ObjectRef (..)+    , WHNFData (..)+    , Intermediate (..)+    , Inner (..)+    , EgisonWHNF (..)+    , fromBuiltinWHNF -- TODO ?+    -- * Environment+    , Env (..)+    , Var (..)+    , Binding (..)+    , nullEnv+    , extendEnv+    , refVar+    -- * Pattern matching+    , PMMode (..)+    , MatchingState (..)+    , MatchingTree (..)+    , PatternBinding (..)+    , LoopContext (..)+    -- * Errors+    , EgisonError (..)+    , liftError+    -- * Monads+    , EgisonM (..)+    , runEgisonM+    , liftEgisonM+    , fromEgisonM+    , FreshT (..)+    , Fresh (..)+    , MonadFresh (..)+    , runFreshT+    , MatchM (..)+    , matchFail+    , MList (..)+    , fromList+    , fromSeq+    , fromMList+    , msingleton+    , mfoldr+    , mappend+    , mconcat+    , mmap+    , mfor+    ) where+ import Prelude hiding (foldr)  import Control.Exception@@ -16,9 +90,9 @@ import Control.Monad.Trans.Maybe  import Data.Monoid (Monoid)-import Data.Foldable (foldr, toList) import qualified Data.Sequence as Sq import Data.Sequence (Seq)+import Data.Foldable (foldr, toList) import Data.IORef import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap@@ -33,6 +107,8 @@ import qualified Data.IntMap as IntMap import Data.Ratio +import System.IO.Unsafe (unsafePerformIO)+ -- -- Expressions --@@ -89,6 +165,11 @@   | UndefinedExpr  deriving (Show) +data InnerExpr =+    ElementExpr EgisonExpr+  | SubCollectionExpr EgisonExpr+ deriving (Show)+ type BindingExpr = ([String], EgisonExpr) type MatchClause = (EgisonPattern, EgisonExpr) type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])]@@ -101,7 +182,6 @@   | PredPat EgisonExpr   | IndexedPat EgisonPattern [EgisonExpr]   | LetPat [BindingExpr] EgisonPattern-  | CutPat EgisonPattern   | NotPat EgisonPattern   | AndPat [EgisonPattern]   | OrPat [EgisonPattern]@@ -134,11 +214,6 @@   | PDConstantPat EgisonExpr  deriving (Show) -data InnerExpr =-    ElementExpr EgisonExpr-  | SubCollectionExpr EgisonExpr- deriving (Show)- -- -- Values --@@ -167,8 +242,12 @@   | EOF  type Matcher = (Env, MatcherInfo)-type PrimitiveFunc = [WHNFData] -> EgisonM EgisonValue+type PrimitiveFunc = EgisonValue -> EgisonM EgisonValue +data EgisonHashKey =+    IntKey Integer+  | StrKey ByteString+ instance Show EgisonValue where   show (Char c) = "'" ++ [c] ++ "'"   show (Bool True) = "#t"@@ -214,6 +293,100 @@  _ == _ = False  --+-- Egison data and Haskell data+--+class Egison a where+  toEgison :: a -> EgisonValue+  fromEgison :: EgisonValue -> EgisonM a++instance Egison Char where+  toEgison c = Char c+  fromEgison = liftError . fromCharValue++instance Egison Bool where+  toEgison b = Bool b+  fromEgison = liftError . fromBoolValue++instance Egison Integer where+  toEgison i = Integer i+  fromEgison = liftError . fromIntegerValue++instance Egison Rational where+  toEgison r = Rational r+  fromEgison = liftError . fromRationalValue++instance Egison Double where+  toEgison f = Float f+  fromEgison = liftError . fromFloatValue++instance Egison Handle where+  toEgison h = Port h+  fromEgison = liftError . fromPortValue++instance (Egison a) => Egison [a] where+  toEgison xs = Collection $ Sq.fromList (map toEgison xs)+  fromEgison (Collection seq) = mapM fromEgison (toList seq)+  fromEgison val = liftError $ throwError $ TypeMismatch "collection" (Value val)++instance Egison () where+  toEgison () = Tuple []+  fromEgison (Tuple []) = return ()+  fromEgison val = liftError $ throwError $ TypeMismatch "zero element tuple" (Value val)++instance (Egison a, Egison b) => Egison (a, b) where+  toEgison (x, y) = Tuple [toEgison x, toEgison y]+  fromEgison (Tuple (x:y:[])) = (liftM2 (,)) (fromEgison x) (fromEgison y)+  fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val)++instance (Egison a, Egison b, Egison c) => Egison (a, b, c) where+  toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z]+  fromEgison (Tuple (x:y:z:[])) = do+    x' <- fromEgison x+    y' <- fromEgison y+    z' <- fromEgison z+    return (x', y', z')+  fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val)++instance (Egison a, Egison b, Egison c, Egison d) => Egison (a, b, c, d) where+  toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w]+  fromEgison (Tuple (x:y:z:w:[])) = do+    x' <- fromEgison x+    y' <- fromEgison y+    z' <- fromEgison z+    w' <- fromEgison w+    return (x', y', z', w')+  fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val)++fromCharValue :: EgisonValue -> Either EgisonError Char+fromCharValue (Char c) = return c+fromCharValue val = throwError $ TypeMismatch "char" (Value val)++fromBoolValue :: EgisonValue -> Either EgisonError Bool+fromBoolValue (Bool b) = return b+fromBoolValue val = throwError $ TypeMismatch "bool" (Value val)++fromIntegerValue :: EgisonValue -> Either EgisonError Integer+fromIntegerValue (Integer i) = return i+fromIntegerValue val = throwError $ TypeMismatch "integer" (Value val)++fromRationalValue :: EgisonValue -> Either EgisonError Rational+fromRationalValue (Rational x) = return x+fromRationalValue val = throwError $ TypeMismatch "rational" (Value val)++fromFloatValue :: EgisonValue -> Either EgisonError Double+fromFloatValue (Float f) = return f+fromFloatValue val = throwError $ TypeMismatch "float" (Value val)++fromPortValue :: EgisonValue -> Either EgisonError Handle+fromPortValue (Port handle) = return handle+fromPortValue val = throwError $ TypeMismatch "port" (Value val)++-- TODO : write instance declaration for Matcher+fromMatcherValue :: EgisonValue -> Either EgisonError Matcher+fromMatcherValue (Matcher matcher) = return matcher+fromMatcherValue val = throwError $ TypeMismatch "matcher" (Value val)++-- -- Internal Data -- @@ -248,76 +421,77 @@   show (Intermediate (IIntHash _)) = "{|...|}"    show (Intermediate (IStrHash _)) = "{|...|}"  -data EgisonHashKey =-    IntKey Integer-  | StrKey ByteString--makeKey :: EgisonValue -> Either EgisonError EgisonHashKey-makeKey val =-  case val of-    Integer i -> return (IntKey i)-    Collection _ -> do-      str <- fromStringValue $ Value val-      return $ StrKey $ B.pack str-    _ -> throwError $ TypeMismatch "integer or string" $ Value val--fromCharValue :: WHNFData -> Either EgisonError Char-fromCharValue (Value (Char c)) = return c-fromCharValue val = throwError $ TypeMismatch "char" val--fromStringValue :: WHNFData -> Either EgisonError String-fromStringValue (Value (Collection seq)) = do-  let ls = toList seq-  mapM (\val -> case val of-                  Char c -> return c-                  _ -> throwError $ TypeMismatch "char" (Value val))-       ls-fromStringValue val = throwError $ TypeMismatch "string" val--makeStringValue :: String -> EgisonValue-makeStringValue str = Collection $ Sq.fromList $ map Char str--fromBoolValue :: WHNFData -> Either EgisonError Bool-fromBoolValue (Value (Bool b)) = return b-fromBoolValue val = throwError $ TypeMismatch "bool" val+--+-- Extract data from WHNF+--+class EgisonWHNF a where+  fromWHNF :: WHNFData -> EgisonM a+  +instance EgisonWHNF Char where+  fromWHNF = liftError . fromCharWHNF+  +instance EgisonWHNF Bool where+  fromWHNF = liftError . fromBoolWHNF+  +instance EgisonWHNF Integer where+  fromWHNF = liftError . fromIntegerWHNF+  +instance EgisonWHNF Rational where+  fromWHNF = liftError . fromRationalWHNF+  +instance EgisonWHNF Double where+  fromWHNF = liftError . fromFloatWHNF+  +instance EgisonWHNF Handle where+  fromWHNF = liftError . fromPortWHNF+  +instance EgisonWHNF Matcher where+  fromWHNF = liftError . fromMatcherWHNF+  +fromCharWHNF :: WHNFData -> Either EgisonError Char+fromCharWHNF (Value (Char c)) = return c+fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf -fromRationalValue :: WHNFData -> Either EgisonError Rational-fromRationalValue (Value (Rational x)) = return x-fromRationalValue val = throwError $ TypeMismatch "rational" val+fromBoolWHNF :: WHNFData -> Either EgisonError Bool+fromBoolWHNF (Value (Bool b)) = return b+fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf -fromIntegerValue :: WHNFData -> Either EgisonError Integer-fromIntegerValue (Value (Integer i)) = return i-fromIntegerValue val = throwError $ TypeMismatch "integer" val+fromIntegerWHNF :: WHNFData -> Either EgisonError Integer+fromIntegerWHNF (Value (Integer i)) = return i+fromIntegerWHNF whnf = throwError $ TypeMismatch "integer" whnf -fromFloatValue :: WHNFData -> Either EgisonError Double-fromFloatValue (Value (Float f)) = return f-fromFloatValue val = throwError $ TypeMismatch "float" val+fromRationalWHNF :: WHNFData -> Either EgisonError Rational+fromRationalWHNF (Value (Rational x)) = return x+fromRationalWHNF whnf = throwError $ TypeMismatch "rational" whnf -fromPortValue :: WHNFData -> Either EgisonError Handle-fromPortValue (Value (Port handle)) = return handle-fromPortValue val = throwError $ TypeMismatch "port" val+fromFloatWHNF :: WHNFData -> Either EgisonError Double+fromFloatWHNF (Value (Float f)) = return f+fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf -fromMatcherValue :: WHNFData -> Either EgisonError Matcher-fromMatcherValue (Value (Matcher matcher)) = return matcher-fromMatcherValue val = throwError $ TypeMismatch "matcher" val+fromPortWHNF :: WHNFData -> Either EgisonError Handle+fromPortWHNF (Value (Port handle)) = return handle+fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf -fromPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue-fromPrimitiveValue (Value val@(Char _)) = 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 +fromMatcherWHNF :: WHNFData -> Either EgisonError Matcher+fromMatcherWHNF (Value (Matcher matcher)) = return matcher+fromMatcherWHNF whnf = throwError $ TypeMismatch "matcher" whnf -extractInteger :: EgisonValue -> EgisonM Integer-extractInteger (Integer i) = return i-extractInteger val = throwError $ TypeMismatch "integer" (Value val)+--+--+--+fromBuiltinWHNF :: WHNFData -> Either EgisonError EgisonValue+fromBuiltinWHNF (Value val@(Char _)) = return val+fromBuiltinWHNF (Value val@(Bool _)) = return val+fromBuiltinWHNF (Value val@(Integer _)) = return val+fromBuiltinWHNF (Value val@(Float _)) = return val+fromBuiltinWHNF whnf = throwError $ TypeMismatch "primitive value" whnf  -- -- Environment -- -type Var = String type Env = [HashMap Var ObjectRef]+type Var = String type Binding = (Var, ObjectRef)  nullEnv :: Env@@ -391,6 +565,39 @@ -- Monads -- +newtype EgisonM a = EgisonM {+    unEgisonM :: ErrorT EgisonError (FreshT IO) a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh)++runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a)+runEgisonM = runErrorT . unEgisonM++liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a+liftEgisonM m = EgisonM $ ErrorT $ FreshT $ do+  s <- get+  (a, s') <- return $ runFresh s m+  put s'+  return $ either throwError return $ a   +  +fromEgisonM :: EgisonM a -> IO (Either EgisonError a)+fromEgisonM = modifyCounter . runEgisonM++counter :: IORef Int+counter = unsafePerformIO (newIORef 0)++readCounter :: IO Int+readCounter = readIORef counter++updateCounter :: Int -> IO ()+updateCounter = writeIORef counter++modifyCounter :: FreshT IO a -> IO a+modifyCounter m = do+  seed <- readCounter+  (result, seed) <- runFreshT seed m +  updateCounter seed+  return result  + newtype FreshT m a = FreshT { unFreshT :: StateT Int m a }   deriving (Functor, Applicative, Monad, MonadState Int, MonadTrans) @@ -432,20 +639,7 @@ runFresh :: Int -> Fresh a -> (a, Int) runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m -newtype EgisonM a = EgisonM {-    unEgisonM :: ErrorT EgisonError (FreshT IO) a-  } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh) -runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a)-runEgisonM = runErrorT . unEgisonM--liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a-liftEgisonM m = EgisonM $ ErrorT $ FreshT $ do-  s <- get-  (a, s') <- return $ runFresh s m-  put s'-  return $ either throwError return $ a   -   type MatchM = MaybeT EgisonM  matchFail :: MatchM a

@@ -0,0 +1,86 @@++{- |+Module      : Language.Egison.Util+Copyright   : Satoshi Egi+Licence     : MIT++This module provides utility functions.+-}++module Language.Egison.Util (completeEgison) where++import Data.List+import System.Console.Haskeline hiding (handle, catch, throwTo)++-- |Complete Egison keywords+completeEgison :: Monad m => CompletionFunc m+completeEgison arg@((')':_), _) = completeParen arg+completeEgison arg@(('>':_), _) = completeParen arg+completeEgison arg@((']':_), _) = completeParen arg+completeEgison arg@(('}':_), _) = completeParen arg+completeEgison arg@(('(':_), _) = (completeWord Nothing " \t<>[]{}$," completeAfterOpenParen) arg+completeEgison arg@(('<':_), _) = (completeWord Nothing " \t()[]{}$," completeAfterOpenCons) arg+completeEgison arg@((' ':_), _) = (completeWord Nothing "" completeNothing) arg+completeEgison arg@(('[':_), _) = (completeWord Nothing "" completeNothing) arg+completeEgison arg@(('{':_), _) = (completeWord Nothing "" completeNothing) arg+completeEgison arg@([], _) = (completeWord Nothing "" completeNothing) arg+completeEgison arg@(_, _) = (completeWord Nothing " \t[]{}$," completeEgisonKeyword) arg++completeAfterOpenParen :: Monad m => String -> m [Completion]+completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenParen++completeAfterOpenCons :: Monad m => String -> m [Completion]+completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons++completeNothing :: Monad m => String -> m [Completion]+completeNothing _ = return []++completeEgisonKeyword :: Monad m => String -> m [Completion]+completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords++egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"]+                            ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "empty?", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "qsort", "intersperse", "intercalate", "split", "split/m"]+egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"]+egisonKeywordsInNeutral = ["something"]+                       ++ ["bool", "string", "integer", "nats", "primes"]+egisonKeywords = egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral++completeParen :: Monad m => CompletionFunc m+completeParen (lstr, _) = case (closeParen lstr) of+  Nothing -> return (lstr, [])+  Just paren -> return (lstr, [(Completion paren paren False)])++closeParen :: String -> Maybe String+closeParen str = closeParen' 0 $ removeCharAndStringLiteral str++removeCharAndStringLiteral :: String -> String+removeCharAndStringLiteral [] = []+removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':(removeCharAndStringLiteral str)+removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':(removeCharAndStringLiteral str)+removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral (c:str) = c:(removeCharAndStringLiteral str)++removeCharAndStringLiteral' :: String -> String+removeCharAndStringLiteral' [] = []+removeCharAndStringLiteral' ('"':'\\':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral' ('"':str) = removeCharAndStringLiteral str+removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral' ('\'':str) = removeCharAndStringLiteral str+removeCharAndStringLiteral' (_:str) = removeCharAndStringLiteral' str++closeParen' :: Integer -> String -> Maybe String+closeParen' _ [] = Nothing+closeParen' 0 ('(':_) = Just ")"+closeParen' 0 ('<':_) = Just ">"+closeParen' 0 ('[':_) = Just "]"+closeParen' 0 ('{':_) = Just "}"+closeParen' n ('(':str) = closeParen' (n - 1) str+closeParen' n ('<':str) = closeParen' (n - 1) str+closeParen' n ('[':str) = closeParen' (n - 1) str+closeParen' n ('{':str) = closeParen' (n - 1) str+closeParen' n (')':str) = closeParen' (n + 1) str+closeParen' n ('>':str) = closeParen' (n + 1) str+closeParen' n (']':str) = closeParen' (n + 1) str+closeParen' n ('}':str) = closeParen' (n + 1) str+closeParen' n (_:str) = closeParen' n str

@@ -55,8 +55,8 @@  (define $between   (lambda [$s $e]-    (if (gt-i? (+ s 10) e)-      (if (gt-i? s e)+    (if (gt? (+ s 10) e)+      (if (gt? s e)         {}         {s @(between (+ s 1) e)})       {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(between (+ s 11) e)})

@@ -0,0 +1,87 @@+;;;+;;;+;;; Bipartite Graph demonstartion+;;;+;;;++;;+;; Matcher definitions+;;+(define $bipartite-graph+  (lambda [$a $b]+    (multiset (edge a b))))++(define $edge+  (lambda [$a $b]+    (algebraic-data-matcher+      {<edge a b>})))++;;+;; Demonstration code+;;+(define $bipartite-graph-data+  {<Edge 1 "a">+   <Edge 1 "a">+   <Edge 1 "a">+   <Edge 1 "a">+   <Edge 1 "b">+   <Edge 1 "c">+   <Edge 2 "a">+   <Edge 2 "a">+   <Edge 2 "a">+   <Edge 2 "a">+   <Edge 2 "a">+   <Edge 3 "c">+   <Edge 4 "a">+   <Edge 5 "a">+   <Edge 5 "b">+   <Edge 5 "c">+   <Edge 6 "c">+   <Edge 6 "c">+   <Edge 6 "c">+   })++(test (match-all bipartite-graph-data (bipartite-graph integer string)+        [<cons <edge ,1 $str> _> str]))++(test (unique/m integer+                (match-all bipartite-graph-data (bipartite-graph integer string)+                  [<cons <edge $n $str>+                         <cons <edge ,n ,str>+                               ^<cons <edge ,n ^,str> _>>>+                   n])))++(test (unique/m integer+                (match-all bipartite-graph-data (bipartite-graph integer string)+                  [<cons <edge $n $str>+                         <cons <edge ,n ,str>+                               ^<cons <edge ,n ^,str> _>>>+                   n])))++(test (unique/m integer+                (match-all bipartite-graph-data (bipartite-graph integer string)+                  [<cons <edge $n ,"a"> _>+                   n])))++(test (unique/m integer+                (match-all bipartite-graph-data (bipartite-graph integer string)+                  [<cons <edge $n ,"a">+                    <cons <edge ,n ,"c">+                     _>>+                   n])))++;; I found bug on nested not-patterns+;(test (unique/m integer+;                (match-all bipartite-graph-data (bipartite-graph integer string)+;                  [(& <cons <edge $n $str>+;                            <cons <edge ,n ,str>+;                                  <cons <edge ,n ,str> _>>>+;                      ^<cons <edge $n2 $str2>+;                             ^<cons <edge ,n2 ,str2> _>>)+;                   n])))++(test (unique/m integer+                (match-all bipartite-graph-data (bipartite-graph integer string)+                  [<cons <edge $n2 $str2>+                         ^<cons <edge ,n2 ,str2> _>>+                  n2])))

@@ -0,0 +1,86 @@+;;;+;;;+;;; Graph demonstartion+;;;+;;;++;;+;; Matcher definitions+;;+(define $graph+  (lambda [$a]+    (set (edge a))))++(define $edge+  (lambda [$a]+    (algebraic-data-matcher+      {<edge a a>})))++;;+;; Sample data+;;+(define $graph-data1+  {<Edge 1 4>+   <Edge 2 1>+   <Edge 3 1>+   <Edge 3 2>+   <Edge 4 3>+   <Edge 5 1>+   <Edge 5 4>+   })++(define $graph-data2+  {<Edge 1 4> <Edge 1 5> <Edge 1 8> <Edge 1 10>+   <Edge 2 3> <Edge 2 6> <Edge 2 12>+   <Edge 3 2> <Edge 3 7> <Edge 3 9>+   <Edge 4 1> <Edge 4 6>+   <Edge 5 1> <Edge 5 8> <Edge 5 9> <Edge 5 11>+   <Edge 6 2> <Edge 6 4> <Edge 6 10> <Edge 6 12>+   <Edge 7 3> <Edge 7 9> <Edge 7 11>+   <Edge 8 1> <Edge 8 5>+   <Edge 9 3> <Edge 9 5> <Edge 9 7>+   <Edge 10 1> <Edge 10 6> <Edge 10 12>+   <Edge 11 5> <Edge 11 7>+   <Edge 12 2> <Edge 12 6> <Edge 12 10>+   })+   +;;+;; Demonstration code+;;+;; find all nodes who have an edege from 's' but not have an edge to 's'+(test (let {[$s 1]}+        (match-all graph-data1 (graph integer)+          [<cons <edge ,s $x>+                 ^<cons <edge ,x ,x>+                        _>>+           x])))++;; find all nodes in two path from 's'+(test (let {[$s 1]}+        (match-all graph-data1 (graph integer)+          [<cons <edge (& ,s $x_1) $x_2>+                 <cons <edge ,x_2 $x_3>+                       _>>+           x])))++;; enumerate first 5 paths from 's' to 'e'+(test (take 5 (let {[$s 1] [$e 2]}+                 (match-all graph-data2 (graph integer)+                   [<cons <edge (& ,s $x_1) $x_2>+                          (loop $i [4 $n]+                            <cons <edge ,x_(- i 2) $x_(- i 1)> ...>+                            <cons <edge ,x_(- n 1) (& ,e $x_n)> _>)>+                    x]))))++;; find all cliques whose size is 'n'+(test (let {[$n 3]}+        (match-all graph-data2 (graph integer)+          [<cons <edge $x_1 $x_2>+                 (loop $i [3 ,n]+                   <cons <edge ,x_1 $x_i>+                         (loop $j [2 ,(- i 1)]+                           <cons <edge ,x_j ,x_i> ...>+                           ...)+                         _>+                   _)>+           x])))

@@ -0,0 +1,18 @@+(define $write-each+  (lambda [$xs]+    (match xs (list something)+      {[<nil> (do {} [])]+       [<cons $x $rs>+        (do {[(write-string x)]+             [(write-string "\n")]+             [(write-each rs)]+             }+          [])]})))++(define $main+  (lambda [$argv]+    (do {[(write-string "argv: ")]+         [(write argv)]+         [(write-string "\n")]+         [(write-each argv)]}+      [])))

@@ -0,0 +1,44 @@+(define $main+  (lambda [$argv]+    (match argv (list string)+      {[<nil> (letrec {[$iter+                        (do {[$eof (eof?)]+                             [(unless eof+                                (do {[$line (read-line)]+                                     [(write-string line)]+                                     [(write-char '\n')]+                                     [iter]}+                                  []))]}+                          [])]}+                iter)]+       [_ (cat-files argv)]})))++(define $cat-files+  (match-lambda (list string)+    {[<nil> nop]+     [<cons $file $files>+      (do {[$port (open-input-file file)]+           [(letrec {[$iter+                     (do {[$eof (eof-port? port)]+                          [(unless eof+                             (do {[$line (read-line-from-port port)]+                                  [(write-string line)]+                                  [(write-char '\n')]+                                  [iter]}+                               []))]}+                       [])]}+              iter)]+           [(close-input-port port)]+           [(cat-files files)]}+        [])]}))++(define $nop+  (return []))++(define $when+  (lambda [$cond $action]+    (if cond action nop)))++(define $unless+  (lambda [$cond $action]+    (when (not cond) action)))

@@ -0,0 +1,5 @@+(define $main+  (lambda [$argv]+    (do {[$content (read-file (car argv))]+         [(write-string content)]}+        [])))

@@ -0,0 +1,6 @@+(define $main+  (lambda [$argv]+    (do {[$v (rand 1 6)]+         [(write v)]+         [(write-char '\n')]}+        [])))

@@ -0,0 +1,3 @@+(define $main+  (lambda [$args]+    (print "Hello, world!")))

@@ -0,0 +1,17 @@+(define $repl+  (lambda []+    (do {[(write-string "input: ")]+         [(flush)]+         [$input (read)]+         [(write input)]+         [(print "")]+         [(write (take 3 input))]+         [(print "")]+         [(repl)]+         }+      [])))++(define $main+  (lambda [$argv]+    (do {[(repl)]}+      [])))

@@ -0,0 +1,4 @@+(define $main+  (lambda [$argv]+    (do {[(each print (map itos primes))]}+      [])))

@@ -0,0 +1,73 @@+;;;+;;;+;;; Mah-jong example+;;;+;;;++;;+;; Matcher definitions+;;+(define $suit+  (algebraic-data-matcher+    {<wan> <pin> <sou>}))++(define $honor+  (algebraic-data-matcher+    {<ton> <nan> <sha> <pe> <haku> <hatsu> <chun>}))++(define $hai+  (algebraic-data-matcher+    {<num suit integer> <ji honor>}))++;;+;; Pattern modularizations+;;+(define $twin+  (pattern-function [$pat1 $pat2]+    <cons (& $pat pat1)+     <cons ,pat+      pat2>>))++(define $shuntsu+  (pattern-function [$pat1 $pat2]+    <cons (& <num $s $n> pat1)+     <cons <num ,s ,(+ n 1)>+      <cons <num ,s ,(+ n 2)>+       pat2>>>))++(define $kohtsu+  (pattern-function [$pat1 $pat2]+    <cons (& $pat pat1)+     <cons ,pat+      <cons ,pat+       pat2>>>))++;;+;; A function that determins whether the hand is finished or not.+;;+(define $agari?+  (match-lambda (multiset hai)+    {[(twin $th_1+       (| (shuntsu $sh_1 (| (shuntsu $sh_2 (| (shuntsu $sh_3 (| (shuntsu $sh_4 <nil>)+                                                                (kohtsu $kh_1 <nil>)))+                                              (kohtsu $kh_1 (kohtsu $kh_2 <nil>))))+                            (kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 <nil>)))))+          (kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 (kohtsu $kh_4 <nil>)))))+       (twin $th_2 (twin $th_3 (twin $th_4 (twin $th_5 (twin $th_6 (twin $th_7 <nil>)))))))+      #t]+     [_ #f]}))++;;+;; Demonstration code+;;+(test (agari? {<Ji <Haku>> <Ji <Haku>>+               <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>+               <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>+               <Num <Pin> 2> <Num <Pin> 3> <Num <Pin> 4>+               <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>}))++(test (agari? {<Ji <Haku>> <Ji <Haku>>+               <Num <Pin> 1> <Num <Pin> 3> <Num <Pin> 4>+               <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>+               <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>+               <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>}))

@@ -0,0 +1,58 @@+(define $eight-queen+  (match-all {1 2 3 4 5 6 7 8} (multiset integer)+    [<cons $a_1+      <cons (& ^,(- a_1 1) ^,(+ a_1 1)+               $a_2)+       <cons (& ^,(- a_1 2) ^,(+ a_1 2)+                ^,(- a_2 1) ^,(+ a_2 1)+                $a_3)+        <cons (& ^,(- a_1 3) ^,(+ a_1 3)+                 ^,(- a_2 2) ^,(+ a_2 2)+                 ^,(- a_3 1) ^,(+ a_3 1)+                 $a_4)+          <cons (& ^,(- a_1 4) ^,(+ a_1 4)+                   ^,(- a_2 3) ^,(+ a_2 3)+                   ^,(- a_3 2) ^,(+ a_3 2)+                   ^,(- a_4 1) ^,(+ a_4 1)+                   $a_5)+           <cons (& ^,(- a_1 5) ^,(+ a_1 5)+                    ^,(- a_2 4) ^,(+ a_2 4)+                    ^,(- a_3 3) ^,(+ a_3 3)+                    ^,(- a_4 2) ^,(+ a_4 2)+                    ^,(- a_5 1) ^,(+ a_5 1)+                    $a_6)+            <cons (& ^,(- a_1 6) ^,(+ a_1 6)+                     ^,(- a_2 5) ^,(+ a_2 5)+                     ^,(- a_3 4) ^,(+ a_3 4)+                     ^,(- a_4 3) ^,(+ a_4 3)+                     ^,(- a_5 2) ^,(+ a_5 2)+                     ^,(- a_6 1) ^,(+ a_6 1)+                     $a_7)+             <cons (& ^,(- a_1 7) ^,(+ a_1 7)+                      ^,(- a_2 6) ^,(+ a_2 6)+                      ^,(- a_3 5) ^,(+ a_3 5)+                      ^,(- a_4 4) ^,(+ a_4 4)+                      ^,(- a_5 3) ^,(+ a_5 3)+                      ^,(- a_6 2) ^,(+ a_6 2)+                      ^,(- a_7 1) ^,(+ a_7 1)+                      $a_8)+              <nil>>>>>>>>>+     a]))++(test eight-queen)++(define $n-queen+  (lambda [$n]+    (match-all (between 1 n) (multiset integer)+      [<cons $a_1+             (loop $i [2 ,n]+                   <cons (loop $i1 [1 ,(- i 1)]+                               (& ^,(- a_i1 (- i i1))+                                  ^,(+ a_i1 (- i i1))+                                  ...)+                               $a_i)+                         ...>+                   <nil>)>+      a])))++(test (n-queen 4))

@@ -0,0 +1,114 @@+;;;+;;;+;;; Poker-hands demonstration+;;;+;;;++;;+;; Matcher definitions+;;+(define $suit+  (algebraic-data-matcher+    {<spade> <heart> <club> <diamond>}))++(define $card+  (algebraic-data-matcher+    {<card suit (mod 13)>}))++;;+;; A function that determins poker-hands+;;+(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>]})))++;;+;; Demonstration code+;;+(test (poker-hands {<Card <Club> 12>+                    <Card <Club> 10>+                    <Card <Club> 13>+                    <Card <Club> 1>+                    <Card <Club> 11>}))++(test (poker-hands {<Card <Diamond> 1>+                    <Card <Club> 2>+                    <Card <Club> 1>+                    <Card <Heart> 1>+                    <Card <Diamond> 2>}))++(test (poker-hands {<Card <Diamond> 4>+                    <Card <Club> 2>+                    <Card <Club> 5>+                    <Card <Heart> 1>+                    <Card <Diamond> 3>}))++(test (poker-hands {<Card <Diamond> 4>+                    <Card <Club> 10>+                    <Card <Club> 5>+                    <Card <Heart> 1>+                    <Card <Diamond> 3>}))+

@@ -0,0 +1,32 @@+;;;+;;;+;;; Pattern-matching against sequence of natural numbers+;;;+;;;++; first 100 natural numbers+(test (take 100 nats))++; inifinite list of two-combinations of numbers+(define $pairs (match-all nats (list integer)+                 [<join _ (& <cons $m _> <join _ <cons $n _>>)>+                  [m n]]))++; test 'pairs'+(test (take 100 pairs))++; infinite list of pythagoras numbers+(define $pyths (map (lambda [$m $n] (+ (power m 2) (power n 2))) pairs))++; test 'pyths'+(test (take 100 pyths))++; function that enumerates all common elements between two lists+(define $commons+  (lambda [$xs $ys]+    (match-all [xs ys] [(multiset integer) (multiset integer)]+      [[<cons $c _> <cons ,c _>]+       c])))++; test 'commons'+(test (commons (take 100 primes) (take 300 pyths)))

@@ -0,0 +1,81 @@+;;;+;;;+;;; Social-graph Demonstration+;;;+;;;++;;+;; Matcher definition+;;+(define $user+  (matcher+    {[,$u []+      {[$tgt (match [u tgt] [user user]+               {[[<id $id> <id ,id>] {[]}]+                [_ {}]})]}]+     [<id $> [integer]+      {[<User $id _ _> {id}]}]+     [<name $> [string]+      {[<User _ $name _> {name}]}]+     [<description $> [string]+      {[<User _ _ $txt> {txt}]}]+     [$ [something]+      {[$tgt {tgt}]}]+     }))++(define $user-table (multiset user))++(define $follow+  (matcher+    {[,$f []+      {[$tgt (match [f tgt] [follow follow]+               {[[(& <from-id $fid> <to-id $tid>) (& <from-id ,fid> <to-id ,tid>)] {[]}]+                [_ {}]})]}]+     [<from-id $> [integer]+      {[<Follow $fid _> {fid}]}]+     [<to-id $> [integer]+      {[<Follow _ $tid> {tid}]}]+     [$ [something]+      {[$tgt {tgt}]}]+     }))++(define $follow-table (multiset follow))++;;+;; Demonstration code+;;+(define $user-data+  {<User 1 "Egison_Lang" "The Programming Language Egison.\nThe pattern-matching-oriented pure functional programming language.">+   <User 2 "RakutenRIT" "Rakuten Institute of Technology">+   <User 3 "Haskeller" "I love Haskell programming.">+   })++(define $follow-data+  {<Follow 1 2>+   <Follow 2 3>+   })++; Users whom "Egison_Lang" follows+(test (match-all [user-data follow-data user-data] [user-table follow-table user-table]+        [[<cons (& <name ,"Egison_Lang"> <id $uid>) _>+          <cons (& <from-id ,uid> <to-id $fid>) _>+          <cons (& <id ,fid> <name $name> <description $txt>) _>]+         <User fid name txt>]))++; Users who don't follow back "Egison_Lang"+(test (match-all [user-data follow-data user-data] [user-table follow-table user-table]+        [[<cons (& <name ,"Egison_Lang"> <id $uid>) _>+          <cons (& <from-id ,uid> <to-id $fid>)+           ^<cons (& <from-id ,fid> <to-id ,uid>)+             _>>+          <cons (& <id ,fid> <name $name> <description $txt>) _>]+         <User fid name txt>]))++; Users who have interested in "Haskell" in the followers of followers of "Egison_Lang"+(test (match-all [user-data follow-data user-data] [user-table follow-table user-table]+        [[<cons (& <name ,"Egison_Lang"> <id $uid>) _>+          <cons (& <from-id ,uid> <to-id $fid>)+           <cons (& <from-id ,fid> <to-id $ffid>)+            _>>+          <cons (& <id ,ffid> <description (& <join _ <join ,"Haskell" _>> $txt)> <name $name>) _>]+         <User ffid name txt>]))

@@ -0,0 +1,89 @@+;;;+;;;+;;; Tree demonstration+;;;+;;;++;;+;; Matcher definition+;;+(define $tree+  (lambda [$a $b]+    (matcher+      {[,$val []+        {[$tgt (match [val tgt] [(tree a b) (tree a b)]+                 {[[<lnode $x $ts> <lnode ,x ,ts>] {[]}]+                  [[_ _] {}]})]}]+       [<leaf $> b+        {[<Leaf $x> {x}]+         [_ {}]}]+       [<lnode $ $> [a (list (tree a b))] ; Node whose children are seen as a list.+        {[<Node $x $ts> {[x ts]}]+         [_ {}]}]+       [<mnode $ $> [a (multiset (tree a b))] ; Node whose children are seen as a multiset.+        {[<Node $x $ts> {[x ts]}]+         [_ {}]}]+       [<descendant $> [(tree a b)]+        {[$t (match-all t (tree a b)+               [(loop $i [1 _] <mnode _ <cons ... _>> $x) x])]}]+       [$ [something]+        {[$tgt {tgt}]}]+       })))++;;+;; Demonstration code+;;+(define $tree-data+  <Node "Programming language"+    {<Node "Pattern-matching oriented"+       {<Leaf "Egison">}>+     <Node "Functional language"+       {<Node "Strictly typed"+          {<Leaf "OCaml">+           <Leaf "Haskell">+           <Leaf "Curry">+           <Leaf "Coq">+           }>+        <Node "Dynamically typed"+          {<Leaf "Egison">+           <Leaf "Lisp">+           <Leaf "Scheme">+           <Leaf "Clojure">+           }>+        }>+     <Node "Logic programming"+       {<Leaf "Prolog">+        <Leaf "LiLFeS">+        <Leaf "Curry">+        }>+     <Node "Object oriented"+       {<Leaf "C++">+        <Leaf "Java">+        <Leaf "Ruby">+        <Leaf "Python">+        <Leaf "OCaml">+        }>+     }>)+++; All langauges+(test (unique/m string (match-all tree-data (tree string string)+                         [<descendant <leaf $x>> x])))+        +; All langauges that belongs to Functional language+(test (unique/m string (match-all tree-data (tree string string)+                         [<descendant <mnode ,"Functional language" <cons <descendant <leaf $x>> _>>> x])))+        +; All langauges that belongs more than two categories+(test (unique/m string (match-all tree-data (tree string string)+                         [<mnode _ <cons <descendant <leaf $x>>+                                         <cons <descendant <leaf ,x>>+                                               _>>>+                          x])))++; All categories that Egison belongs+(test (match-all tree-data (tree string string)+        [(loop $i [1 $n]+               <mnode $c_i <cons ... _>>+               <leaf ,"Egison">)+         c]))

@@ -0,0 +1,49 @@+(load "lib/tree/xml.egi")++(define $xml1+  <Node "top"+        {<Node "middle1" {<Leaf "bottom1" "text1">+                          <Leaf "bottom1" "text2">+                          <Leaf "bottom1" "text3">+                          <Node "bottom1" {<Leaf "bottom2" "text21">+                                           <Leaf "bottom2" "text100">+                                           <Leaf "bottom2" "text22">}>+                          }>+         <Node "middle2" {<Leaf "bottom3" "text31">+                          <Leaf "bottom3" "text32">+                          <Leaf "bottom3" "text33">+                          <Leaf "bottom3" "text31">+                          <Leaf "bottom3" "text35">+                          }>++         <Node "middle3" {<Leaf "bottom4" "text41">+                          <Leaf "bottom4"  "text42">+                          <Node "bottom4" {<Leaf "bottom2" "text51">+                                           <Leaf "bottom2" "text100">+                                           <Leaf "bottom2" "text53">}>+                          <Leaf "bottom4"  "text44">+                          <Leaf "bottom4"  "text53">+                          }>+         }>)+++;; List up all tags.+(test (match-all xml1 xml+        [<descendant <mnode $tag _>  _> [tag]]))+; {top middle1 middle2 middle3 bottom1 bottom4}++;; List up all nodes which has more than two same child nodes.+(test (match-all xml1 xml+        [<descendant <mnode $tag <cons $x <cons ,x _>>>>+         [tag x]]))+; {[middle2 <Leaf bottom3 text31>] [middle2 <Leaf bottom3 text31>]}++;; List up all nodes which has more than two same descendant nodes.+(test (match-all xml1 xml+        [<descendant+          <mnode $tag+           <cons <descendant $x>+            <cons <descendant ,x>+             _>>>>+         [tag x]]))+; {[middle2 <Leaf bottom3 text31>] [middle2 <Leaf bottom3 text31>] [top <Leaf bottom2 text100>] [top <Leaf bottom2 text100>]}

@@ -20,12 +20,12 @@  runTestCase :: FilePath -> Test runTestCase file = TestLabel file . TestCase $ do-  env <- primitiveEnv >>= loadLibraries+  env <- primitiveEnv >>= loadCoreLibraries   assertEgisonM $ do     exprs <- loadFile file     let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs     env' <- recursiveBind env bindings-    forM_ tests $ evalExpr' env'+    forM_ tests $ evalExprDeep env'       where         assertEgisonM :: EgisonM a -> Assertion         assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")