egison 3.0.0 → 3.0.1

raw patch · 12 files changed

+649/−308 lines, 12 filesdep +randomPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random

API changes (from Hackage documentation)

Files

• egison.cabal +3/−3
• elisp/egison-mode.el +8/−0
• hs-src/Interpreter/egisoni.hs +65/−8
• hs-src/Language/Egison.hs +31/−5
• hs-src/Language/Egison/Core.hs +175/−59
• hs-src/Language/Egison/Desugar.hs +74/−31
• hs-src/Language/Egison/Parser.hs +54/−49
• hs-src/Language/Egison/Primitives.hs +93/−73
• hs-src/Language/Egison/Types.hs +66/−14
• lib/core/base.egi +4/−19
• lib/core/collection.egi +72/−45
• test/UnitTest.hs +4/−2

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.0.0+Version:             3.0.1 Synopsis:            An Interpreter for the Programming Language Egison Description:         An interpreter for the programming language Egison.                      A feature of Egison is the strong pattern match facility.@@ -10,7 +10,7 @@ Homepage:            http://egison.pira.jp License:             MIT License-file:        LICENSE-Author:              Satoshi Egi, Ryo Tanaka, Takahisa Watanabe, Kentaro Honda+Author:              Satoshi Egi, Ryo Tanaka, Takahisa Watanabe Maintainer:          egisatoshi@gmail.com Category:            Compilers/Interpreters Build-type:          Simple@@ -23,7 +23,7 @@                      elisp/egison-mode.el  Library-  Build-Depends:   base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring+  Build-Depends:   base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring   Hs-Source-Dirs:  hs-src   Exposed-Modules:                    Language.Egison

@@ -22,9 +22,13 @@      "\\<let\\>"      "\\<letrec\\>"      "\\<matcher\\>"+     "\\<algebraic-data-matcher\\>"      "\\<loop\\>"+     "\\<function\\>"      "\\<match\\>"      "\\<match-all\\>"+     "\\<index-loop\\>"+     "\\<pattern-constructor\\>"       "\\<undefined\\>"      "\\<something\\>"@@ -112,6 +116,7 @@ (defun keyword-indent-point (name)   (cond ((equal "define" name) 2)         ((equal "lambda" name) 2)+        ((equal "function" name) 2)         ((equal "macro" name) 2)         ((equal "let" name) 2)         ((equal "letrec" name) 2)@@ -119,7 +124,10 @@         ((equal "match" name) 2)         ((equal "match-all" name) 2)         ((equal "matcher" name) 2)+        ((equal "algebraic-data-matcher" name) 2)         ((equal "generate-array" name) 2)+        ((equal "index-loop" name) 2)+        ((equal "pattern-constructor" name) 2)         ))  (defun egison-indent-line ()

@@ -15,17 +15,74 @@ import System.Directory (getHomeDirectory) import System.FilePath ((</>)) import System.Console.Haskeline+import System.Console.GetOpt+import System.Exit (ExitCode (..), exitWith, exitFailure) import Language.Egison  main :: IO () main = do args <- getArgs-          env <- primitiveEnv >>= loadLibraries-          if null args-            then showBanner >> repl env "> "-            else do-              result <- evalEgisonTopExpr env $ (LoadFile $ args !! 0)-              either print (const $ return ()) result+          let (actions, nonOpts, _) = getOpt Permute options args+          let opts = foldl (flip id) defaultOptions actions+          case opts of+            Options {optShowHelp = True} -> printHelp+            Options {optShowVersion = True} -> printVersionNumber+            Options {optPrompt = prompt, optShowBanner = bannerFlag} -> do+                env <- primitiveEnv >>= loadLibraries+                case nonOpts of+                    [] -> when bannerFlag showBanner >> repl env prompt >> when bannerFlag showByebyeMessage+                    (file:args) -> do+                        result <- evalEgisonTopExprs env [LoadFile file, Execute args]+                        either print (const $ return ()) result +data Options = Options {+    optShowVersion :: Bool,+    optShowHelp :: Bool,+    optShowBanner :: Bool,+    optPrompt :: String+    }++defaultOptions :: Options+defaultOptions = Options {+    optShowVersion = False,+    optShowHelp = False,+    optShowBanner = True,+    optPrompt = "> "+    }++options :: [OptDescr (Options -> Options)]+options = [+  Option ['v', 'V'] ["version"]+    (NoArg (\opts -> opts {optShowVersion = True}))+    "show version number",+  Option ['h', '?'] ["help"]+    (NoArg (\opts -> opts {optShowHelp = True}))+    "show usage information",+  Option [] ["no-banner"]+    (NoArg (\opts -> opts {optShowBanner = False}))+    "show usage information",+  Option ['p'] ["prompt"]+    (ReqArg (\prompt opts -> opts {optPrompt = prompt})+            "String")+    "output file to write"+  ]++printHelp :: IO ()+printHelp = do+  putStrLn "Usage: egison [options] file"+  putStrLn ""+  putStrLn "Options:"+  putStrLn "  --help                Display this information"+  putStrLn "  --version             Display egison version information"+  putStrLn "  --no-banner           Don't show banner"+  putStrLn "  --prompt string       Set prompt of the interpreter"+  putStrLn ""+  exitWith ExitSuccess++printVersionNumber :: IO ()+printVersionNumber = do+  putStrLn $ showVersion version +  exitWith ExitSuccess+ showBanner :: IO () showBanner = do   putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2013 Satoshi Egi"@@ -48,8 +105,8 @@     loop env prompt' rest = do       input <- getInputLine prompt'       case input of-        Nothing -> liftIO showByebyeMessage >> return ()-        Just "quit" -> liftIO showByebyeMessage >> return ()+        Nothing -> return () +        Just "quit" -> return ()          Just "" ->  loop env prompt ""         Just input' -> do           let newInput = rest ++ input'

@@ -3,16 +3,20 @@        ( module Language.Egison.Types        , module Language.Egison.Parser        , module Language.Egison.Primitives+       , counter --danger        , version        , loadLibraries        , loadPrimitives        , runEgisonTopExpr        , evalEgisonTopExpr+       , evalEgisonTopExprs        ) where  import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error +import System.IO.Unsafe (unsafePerformIO)+import Data.IORef import Data.Version import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 ()@@ -26,12 +30,19 @@ import Language.Egison.Parser import Language.Egison.Primitives +-- Unsafe+counter :: IORef Int+counter = unsafePerformIO (newIORef 0)++ version :: Version version = P.version  loadLibraries :: Env -> IO Env loadLibraries env = do-  result <- runEgisonM $ foldM evalTopExpr env (map Load libraries)+  seed <- readIORef counter+  (result, seed') <- runFreshT seed $ runEgisonM $ foldM evalTopExpr env (map Load libraries)+  writeIORef counter seed'   case result of     Left err -> do       print . show $ err@@ -49,9 +60,24 @@ loadPrimitives env = (++) <$> return env <*> primitiveEnv  runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env)-runEgisonTopExpr env input = runEgisonM $ do -  expr <- liftError $ readTopExpr input-  evalTopExpr env expr+runEgisonTopExpr env input = do+  seed <- readIORef counter+  (result, seed') <- runFreshT seed $ runEgisonM $ do +    expr <- liftEgisonM $ readTopExpr input+    evalTopExpr env expr+  writeIORef counter seed'+  return result  evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env)-evalEgisonTopExpr env expr = runEgisonM $ evalTopExpr env expr+evalEgisonTopExpr env expr = do+  seed <- readIORef counter+  (result, seed') <- runFreshT seed $ runEgisonM $ evalTopExpr env expr+  writeIORef counter seed'+  return result++evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)+evalEgisonTopExprs env exprs = do+  seed <- readIORef counter+  (result, seed') <- runFreshT seed $ runEgisonM $ foldM evalTopExpr env exprs+  writeIORef counter seed'+  return result

@@ -10,6 +10,12 @@ import Data.List import Data.Maybe +import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+ import Text.Parsec.ByteString.Lazy (parseFromFile) import System.Directory (doesFileExist) @@ -39,11 +45,11 @@   liftIO $ print val   return env evalTopExpr env (Execute argv) = do-  main <- refVar env ("main", []) >>= evalRef-  argv <- newEvaluatedThunk . Value . Collection $ map String argv-  world <- newEvaluatedThunk $ Value World-  applyFunc main [argv] >>= flip applyFunc [world]-  return env+  main <- refVar env "main" >>= evalRef+  io <- applyFunc main $ Value $ Collection $ map String argv+  case io of+    Value (IOFunc m) -> m >> return env+    _ -> throwError $ TypeMismatch "io" main evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env @@ -52,7 +58,7 @@   doesExist <- liftIO $ doesFileExist file   unless doesExist $ throwError $ strMsg ("file does not exist: " ++ file)   input <- liftIO $ readFile file-  exprs <- liftError $ readTopExprs input+  exprs <-  liftEgisonM $ readTopExprs input   concat <$> mapM recursiveLoad exprs  where   recursiveLoad (Load file) = loadFile file@@ -69,11 +75,9 @@ evalExpr _ (IntegerExpr i) = return . Value $ Integer i evalExpr _ (FloatExpr d) = return . Value $ Float d -evalExpr env (VarExpr name nums) = do-  var <- (,) name <$> mapM (evalExpr env >=> liftError . fromIntegerValue) nums-  refVar env var >>= evalRef+evalExpr env (VarExpr name) = refVar env name >>= evalRef -evalExpr env (InductiveDataExpr name []) = return . Value $ InductiveData name []+evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) =   Intermediate . IInductiveData name <$> mapM (newThunk env) exprs  @@ -82,13 +86,34 @@ evalExpr env (TupleExpr exprs) =   Intermediate . ITuple <$> mapM (newThunk env) exprs  -evalExpr env (CollectionExpr []) = return . Value $ Collection []+evalExpr _ (CollectionExpr []) = return . Value $ Collection [] evalExpr env (CollectionExpr inners) =   Intermediate . ICollection <$> mapM fromInnerExpr inners  where   fromInnerExpr (ElementExpr expr) = IElement <$> newThunk env expr   fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newThunk env expr +evalExpr env (ArrayExpr exprs) = do+  ref' <- mapM (newThunk env) exprs+  return . Intermediate . IArray $ IntMap.fromList $ zip (enumFromTo 1 (length exprs)) ref'++evalExpr env (IndexedExpr expr indices) = do+  array <- evalExpr env expr+  indices <- mapM (evalExpr env >=> liftError . liftM fromInteger . fromIntegerValue) indices+  refArray array indices+ where+  refArray :: WHNFData -> [Int] -> EgisonM WHNFData+  refArray val [] = return val +  refArray (Value (Array array)) (index:indices) =+    case IntMap.lookup index array of+      Just val -> refArray (Value val) indices+      Nothing -> return $ Value Undefined+  refArray (Intermediate (IArray array)) (index:indices) =+    case IntMap.lookup index array of+      Just ref -> evalRef ref >>= flip refArray indices+      Nothing -> return $ Value Undefined+  refArray val _ = throwError $ TypeMismatch "array" val+ evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr   evalExpr env (IfExpr test expr expr') = do@@ -113,21 +138,30 @@   extractBindings (names, expr) = do     var <- genVar     let k = length names-        target = VarExpr var []+        target = VarExpr var         matcher = TupleExpr $ replicate k SomethingExpr         nth n =           let pattern = TupleExpr $ flip map [1..k] $ \i ->                 if i == n-                  then PatternExpr $ PatVar "#_" []+                  then PatternExpr $ PatVar "#_"                   else PatternExpr WildCard-          in MatchExpr target matcher [(pattern, VarExpr "#_" [])]+          in MatchExpr target matcher [(pattern, VarExpr "#_")]     return ((var, expr) : map (second nth) (zip names [1..]))    genVar :: State Int String   genVar = modify (1+) >> gets (('#':) . show) +evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do+  let body = foldr genLet (TupleExpr [VarExpr "#1", expr]) bindings+  applyFunc (Value $ Func env ["#1"] body) $ Value World+ where+  genLet (names, expr) expr' =+    LetExpr [(["#1", "#2"], ApplyExpr expr $ TupleExpr [VarExpr "#1"])] $+    LetExpr [(names, VarExpr "#2")] expr'+ evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do   target <- newThunk env target+     matcher <- evalExpr env matcher   result <- patternMatch env pattern target matcher   mmap (flip evalExpr expr . extendEnv env) result >>= fromMList@@ -150,19 +184,33 @@   foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses  evalExpr env (FunctionExpr matcher clauses) =-  return . Value $ Func env ["#_"] (MatchExpr (VarExpr "#_" []) matcher clauses)+  return . Value $ Func env ["#_"] (MatchExpr (VarExpr "#_") matcher clauses) -evalExpr env (ApplyExpr func args) = do+evalExpr env (ApplyExpr func arg) = do   func <- evalExpr env func-  args <- evalExpr env args >>= fromTuple -  applyFunc func args+  arg <- evalExpr env arg+  applyFunc func arg  evalExpr env (MatcherExpr info) = return $ Value $ Matcher (env, info) +evalExpr env (GenerateArrayExpr (name:[]) (TupleExpr (size:[])) expr) =+  generateArray env name size expr+evalExpr env (GenerateArrayExpr (name:xs) (TupleExpr (size:ys)) expr) = +  generateArray env name size (GenerateArrayExpr xs (TupleExpr ys) expr)+evalExpr _ (GenerateArrayExpr _ _ _) = throwError $ strMsg "invalid generate-array expression"++evalExpr env (ArraySizeExpr expr) = +  evalExpr env expr >>= arraySize+  where+    arraySize :: WHNFData -> EgisonM WHNFData+    arraySize (Intermediate (IArray vals)) = return . Value . Integer . toInteger $ IntMap.size vals+    arraySize (Value (Array vals))         = return . Value . Integer . toInteger $ IntMap.size vals+    arraySize val                          = throwError $ TypeMismatch "array" val+ evalExpr _ (PatternExpr pattern) = return $ Value $ Pattern pattern  evalExpr _ SomethingExpr = return $ Value Something-evalExpr _ UndefinedExpr = throwError $ strMsg "undefined"+evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr)  evalExpr' :: Env -> EgisonExpr -> EgisonM EgisonValue@@ -196,21 +244,45 @@ 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+  return $ Array $ IntMap.fromList $ zip (enumFromTo 1 (IntMap.size refs)) refs' evalDeep (Intermediate (ITuple refs)) = Tuple <$> mapM evalRef' refs evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef') -applyFunc :: WHNFData -> [ObjectRef] -> EgisonM WHNFData-applyFunc (Value (Func env names body)) args-  | length names == length args =-    let env' = extendEnv env $ makeBindings names args-    in evalExpr env' body-  | otherwise = throwError $ ArgumentsNum (length names) (length args)-applyFunc (Value (PrimitiveFunc func)) args =-  mapM evalRef args >>= liftM Value . liftError . func-applyFunc (Value (IOFunc func)) args =-  mapM evalRef args >>= liftM Value . func+applyFunc :: WHNFData -> WHNFData -> EgisonM WHNFData+applyFunc (Value (Func env [name] body)) arg = do+  ref <- newEvaluatedThunk arg+  evalExpr (extendEnv env $ makeBindings [name] [ref]) body+applyFunc (Value (Func env names body)) arg = do+  refs <- fromTuple arg+  if length names == length refs+    then evalExpr (extendEnv env $ makeBindings names refs) body+    else throwError $ ArgumentsNum (length names) (length refs)+applyFunc (Value (PrimitiveFunc func)) arg =+  fromTuple arg >>= mapM evalRef >>= liftM Value . func+applyFunc (Value (IOFunc m)) arg = do+  case arg of+     Value World -> m+     _ -> throwError $ TypeMismatch "world" arg applyFunc val _ = throwError $ TypeMismatch "function" val +generateArray :: Env -> String -> EgisonExpr -> EgisonExpr -> EgisonM WHNFData+generateArray env name size expr = do  +  size' <- evalExpr env size >>= either throwError (return . fromInteger) . fromIntegerValue+  elems <- mapM genElem (enumFromTo 1 size')+  return $ Intermediate $ IArray $ IntMap.fromList elems+  where+    genElem :: Int -> EgisonM (Int, ObjectRef)+    genElem i = do env <- bindEnv env name $ toInteger i+                   val <- evalExpr env expr >>= newEvaluatedThunk                   +                   return (i, val)+    +    bindEnv :: Env -> String -> Integer -> EgisonM Env+    bindEnv env name i = do+      ref <- liftIO $ newIORef (WHNF . Value . Integer $ i)+      return $ extendEnv env [(name, ref)]+ newThunk :: Env -> EgisonExpr -> EgisonM ObjectRef newThunk env expr = liftIO . newIORef . Thunk $ evalExpr env expr @@ -221,7 +293,7 @@ newEvaluatedThunk = liftIO . newIORef . WHNF  makeBindings :: [String] -> [ObjectRef] -> [Binding]-makeBindings = zip . map (flip (,) [])+makeBindings = zip  recursiveBind :: Env -> [(String, EgisonExpr)] -> EgisonM Env recursiveBind env bindings = do@@ -231,6 +303,11 @@   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@@ -279,14 +356,44 @@   let env' = extendEnv env bindings   pattern <- evalPattern env' pattern   case pattern of-    VarExpr _ _ -> throwError $ strMsg "cannot use variable in pattern"-    ApplyExpr func (TupleExpr args) -> do+    VarExpr _ -> throwError $ strMsg "cannot use variable in pattern"+    ApplyExpr func arg -> do       func <- evalExpr env' func       case func of+        Value (Func env [name] expr) -> do+          penv <- (:[]) . (,) name <$> evalPattern env' arg+          return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees)         Value (Func env names expr) -> do-          penv <- zip (map (flip (,) []) names) <$> mapM (evalPattern env') args+          let args = case arg of+                       TupleExpr exprs -> exprs+                       expr -> [expr]+          penv <- zip names <$> mapM (evalPattern env') args           return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees)         _ -> throwError $ TypeMismatch "pattern constructor" func+    IndexedExpr (PatternExpr (PatVar name)) indices -> do+      indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices+      let (index:_) = indices +      case lookup name bindings of+        Just ref -> do+          val <- evalRef ref+          case val of+            Intermediate (IArray val) -> do+              obj <- newEvaluatedThunk $ Intermediate . IArray $ IntMap.insert index target val+              return $ msingleton $ MState env (subst name obj bindings) trees+            Value (Array val) -> do+              keys' <- return $ IntMap.keys val+              vals' <- mapM (newEvaluatedThunk . Value) $ IntMap.elems val+              obj <- newEvaluatedThunk $ Intermediate . IArray $ IntMap.insert index target (IntMap.fromList $ zip keys' vals')+              return $ msingleton $ MState env (subst name obj bindings) trees+        Nothing  -> do+          obj <- newEvaluatedThunk $ Intermediate . IArray $ IntMap.singleton index target +          return $ msingleton $ MState env ((name, obj):bindings) trees+       where+        subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)]+        subst k nv ((k', v'):xs) | k == k'   = (k', nv):(subst k nv xs)+                                 | otherwise = (k', v'):(subst k nv xs)+        subst _ _ [] = []+    IndexedExpr expr index -> throwError $ strMsg ("invalid indexed-pattern: " ++ show expr)      TupleExpr patterns -> do       matchers <- fromTuple matcher >>= mapM evalRef       targets <- evalRef target >>= fromTuple@@ -307,16 +414,17 @@     PatternExpr (CutPat pattern) -> -- TEMPORARY ignoring cut patterns       return $ msingleton (MState env bindings ((MAtom pattern target matcher):trees))     PatternExpr (PredPat pred) -> do-      result <- evalExpr env' pred >>= flip applyFunc [target] >>= liftError . fromBoolValue+      func <- evalExpr env' pred+      arg <- evalRef target+      result <- applyFunc func arg >>= liftError . fromBoolValue       if result then return $ msingleton $ (MState env bindings trees)                 else return MNil     PatternExpr pattern' ->       case matcher of         Value Something ->            case pattern' of-            PatVar name nums -> do-              var <- (,) name <$> mapM (evalExpr env' >=> liftError . fromIntegerValue) nums-              return $ msingleton $ MState env ((var, target):bindings) trees+            PatVar name -> do+              return $ msingleton $ MState env ((name, target):bindings) trees             _ -> throwError $ strMsg "something can only match with a pattern variable"         Value (Matcher matcher) -> do           (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher@@ -325,32 +433,40 @@             let trees' = zipWith3 MAtom patterns targets matchers ++ trees             return $ MState env bindings trees'         _ -> throwError $ TypeMismatch "matcher" matcher+    _ -> throwError $ strMsg "should not reach here" processMState (MState env bindings ((MNode penv (MState _ _ [])):trees)) =   return $ msingleton $ MState env bindings trees processMState (MState env bindings ((MNode penv state@(MState env' bindings' (tree:trees')):trees))) = do+  let env'' = extendEnv env' bindings   case tree of     MAtom pattern target matcher -> do-      pattern <- evalPattern env' pattern+      pattern <- evalPattern env'' pattern       case pattern of-        VarExpr name nums -> do-          var <- (,) name <$> mapM (evalExpr env' >=> liftError . fromIntegerValue) nums-          case lookup var penv of-            Just pattern -> do+        VarExpr name ->+          case lookup name penv of+            Just pattern ->               return $ msingleton $ MState env bindings (MAtom pattern target matcher:MNode penv (MState env' bindings' trees'):trees)-            Nothing -> throwError $ UnboundVariable var+            Nothing -> throwError $ UnboundVariable name+        IndexedExpr (VarExpr name) (index:_) ->+          case lookup name penv of+            Just pattern -> do+              index <- evalExpr env'' index >>= liftError . fromIntegerValue+              let pattern' = IndexedExpr pattern [IntegerExpr index]+              return $ msingleton $ MState env bindings (MAtom pattern' target matcher:MNode penv (MState env' bindings' trees'):trees)+            Nothing -> throwError $ UnboundVariable name         _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv)     _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv)  evalPattern :: Env -> EgisonExpr -> EgisonM EgisonExpr+evalPattern _ (TupleExpr [expr]) = return expr evalPattern _ expr@(TupleExpr _) = return expr evalPattern _ expr@(PatternExpr _) = return expr-evalPattern _ expr@(VarExpr _ _) = return expr+evalPattern _ expr@(VarExpr _) = return expr+evalPattern _ expr@(IndexedExpr _ _) = return expr evalPattern _ expr@(ApplyExpr _ _) = return expr evalPattern env (IfExpr test expr expr') = do   test <- evalExpr env test >>= liftError . fromBoolValue   evalPattern env $ if test then expr else expr'  -evalPattern env (LetExpr _ _) = undefined-evalPattern env (LetRecExpr _ _) = undefined evalPattern _ _ = throwError $ strMsg "pattern expression required"  inductiveMatch :: Env -> EgisonExpr -> ObjectRef -> Matcher ->@@ -382,22 +498,22 @@ primitivePatPatternMatch _ PPWildCard _ = return ([], []) primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], []) primitivePatPatternMatch env (PPValuePat name) pattern = do-  pattern <- lift $ evalExpr env pattern+  pattern <- lift $ evalPattern env pattern   case pattern of-    Value (Pattern (ValuePat expr)) -> do+    PatternExpr (ValuePat expr) -> do       ref <- lift $ newThunk env expr-      return ([], [((name, []), ref)])+      return ([], [(name, ref)])     _ -> matchFail primitivePatPatternMatch env (PPInductivePat name patterns) pattern = do-  pattern <- lift $ evalExpr env pattern+  pattern <- lift $ evalPattern env pattern   case pattern of-    Value (Pattern (InductivePattern name' exprs)) | name == name' ->+    PatternExpr (InductivePattern name' exprs) | name == name' ->       (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs     _ -> matchFail  primitiveDataPatternMatch :: PrimitiveDataPattern -> ObjectRef -> MatchM [Binding] primitiveDataPatternMatch PDWildCard _ = return []-primitiveDataPatternMatch (PDPatVar name) ref = return [((name, []), ref)]+primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)] primitiveDataPatternMatch (PDInductivePat name patterns) ref = do   val <- lift $ evalRef ref   case val of@@ -449,15 +565,15 @@   unconsCollection' (Value (Collection (val:vals))) =     lift $ (,) <$> newEvaluatedThunk (Value val)                <*> newEvaluatedThunk (Value $ Collection vals)-  unconsCollection' (Intermediate (ICollection ((IElement ref):inners))) =-    lift $ (,) ref <$> newEvaluatedThunk (Intermediate $ ICollection inners)+  unconsCollection' (Intermediate (ICollection ((IElement ref'):inners))) =+    lift $ (,) ref' <$> newEvaluatedThunk (Intermediate $ ICollection inners)   unconsCollection' (Intermediate (ICollection ((ISubCollection ref'):inners))) = do     inners' <- lift $ evalRef ref' >>= expandCollection     let coll = Intermediate (ICollection (inners' ++ inners))     lift $ writeThunk ref coll     unconsCollection' coll   unconsCollection' _ = matchFail-  + unsnocCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef) unsnocCollection ref = lift (evalRef ref) >>= unsnocCollection'   where@@ -469,11 +585,11 @@     unsnocCollection' (Intermediate (ICollection [])) = matchFail     unsnocCollection' (Intermediate (ICollection inners)) =       case last inners of-        IElement ref ->+        IElement ref' ->           lift $ (,) <$> newEvaluatedThunk (Intermediate . ICollection $ init inners)-                     <*> pure ref-        ISubCollection ref -> do-          inners' <- lift $ evalRef ref >>= expandCollection+                     <*> pure ref'+        ISubCollection ref' -> do+          inners' <- lift $ evalRef ref' >>= expandCollection           let coll = Intermediate (ICollection (init inners ++ inners'))           lift $ writeThunk ref coll           unsnocCollection' coll

@@ -5,29 +5,35 @@ import Data.Char (toUpper) import Control.Monad.Error import Control.Monad.State+import Control.Monad.Reader import Control.Monad.Identity import Language.Egison.Types -newtype DesugarM a = DesugarM { unDesugarM :: StateT Int (ErrorT EgisonError Identity) a }-  deriving (Functor, Applicative, Monad, MonadState Int, MonadError EgisonError)-           -class (Applicative m, Monad m) => MonadFresh m where-  fresh :: m String-           -instance MonadFresh DesugarM where-  fresh = do counter <- get; modify (+ 1) -             return $ genFreshName counter-    where-      genFreshName :: Int -> String-      genFreshName n = "$_" ++ show n+type Subst = [(String, EgisonExpr)] -runDesugarM :: DesugarM a -> Either EgisonError a-runDesugarM d =runIdentity $ runErrorT $ flip evalStateT 0 $ unDesugarM d+newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ErrorT EgisonError Fresh) a }+  deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst) +instance MonadFresh (ReaderT Subst (ErrorT EgisonError Fresh)) where+  fresh = lift $ lift $ fresh++runDesugarM :: DesugarM a -> Fresh (Either EgisonError a)+runDesugarM = runErrorT . flip runReaderT [] . unDesugarM++desugarTopExpr :: EgisonTopExpr -> DesugarM EgisonTopExpr+desugarTopExpr (Define name expr) = do+  expr' <- desugar expr+  return (Define name expr')+desugarTopExpr (Test expr) = do+  expr' <- desugar expr+  return (Test expr')+desugarTopExpr expr = return expr++ desugar :: EgisonExpr -> DesugarM EgisonExpr-desugar (AlgebraicDataMatcher patterns) = do+desugar (AlgebraicDataMatcherExpr patterns) = do   matcherName <- fresh-  matcherRef <- return $ VarExpr matcherName []+  matcherRef <- return $ VarExpr matcherName   matcher <- genMatcherClauses patterns matcherRef   return $ LetRecExpr [([matcherName], matcher)] matcherRef     where@@ -43,7 +49,7 @@       genMainClause patterns matcher = do         clauses <- genClauses patterns         return (PPValuePat "val", TupleExpr [],-                 [(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr "val" []), (VarExpr "tgt" [])]) +                 [(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr "val"), (VarExpr "tgt")])                                                (TupleExpr [matcher, matcher])                                                clauses))])         where@@ -59,8 +65,8 @@           genMatchingPattern :: EgisonExpr -> DesugarM (EgisonExpr, EgisonExpr)           genMatchingPattern (PatternExpr (InductivePattern name patterns)) = do             names <- mapM (const fresh) patterns-            return $ ((PatternExpr $ InductivePattern name (map (PatternExpr . flip PatVar []) names))  -                     ,(PatternExpr $ InductivePattern name (map (PatternExpr . ValuePat . (flip VarExpr [])) names)))+            return $ ((PatternExpr $ InductivePattern name (map (PatternExpr . PatVar) names))  +                     ,(PatternExpr $ InductivePattern name (map (PatternExpr . ValuePat . VarExpr) names)))                  genMatcherClause :: EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMatcherClause pattern = do@@ -78,7 +84,7 @@           genPrimitiveDataPat :: EgisonExpr -> DesugarM (PrimitiveDataPattern, [EgisonExpr])           genPrimitiveDataPat (PatternExpr (InductivePattern name patterns)) = do             patterns' <- mapM (const fresh) patterns -            return (PDInductivePat (capitalize name) $ map PDPatVar patterns', map (flip VarExpr []) patterns')+            return (PDInductivePat (capitalize name) $ map PDPatVar patterns', map VarExpr patterns')           genPrimitiveDataPatr _ = throwError $ Desugar "invalid algebraic-data-matcher"            capitalize :: String -> String@@ -87,7 +93,7 @@              genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genSomethingClause = -        return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr $ [ElementExpr (VarExpr "tgt" [])])])+        return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr $ [ElementExpr (VarExpr "tgt")])])            matchingSuccess :: EgisonExpr       matchingSuccess = CollectionExpr $ [ElementExpr $ TupleExpr []]@@ -99,12 +105,17 @@   name <- fresh   matcher' <- desugar matcher   clauses' <- desugarMatchClauses clauses-  desugar (LambdaExpr [name] (MatchExpr (VarExpr name []) matcher' clauses'))+  desugar (LambdaExpr [name] (MatchExpr (VarExpr name) matcher' clauses')) -desugar (VarExpr name exprs) = do-  exprs' <- mapM desugar exprs-  return $ VarExpr name exprs'+desugar (ArrayRefExpr (VarExpr name) (TupleExpr nums)) =+  desugar $ IndexedExpr (VarExpr name) nums+  +desugar (ArrayRefExpr expr nums) =+  desugar $ ArrayRefExpr expr (TupleExpr [nums]) +desugar (IndexedExpr expr indices) = +  IndexedExpr <$> desugar expr <*> (mapM desugar indices)+ desugar (InductiveDataExpr name exprs) = do    exprs' <- mapM desugar exprs   return $ InductiveDataExpr name exprs'@@ -145,11 +156,25 @@   expr' <- desugar expr   return $ LetRecExpr binds' expr'   -desugar (LoopExpr s0 s1 expr0 expr1 expr2) = do-  expr0' <- desugar expr0-  expr1' <- desugar expr1-  expr2' <- desugar expr2-  return $ LoopExpr s0 s1 expr0' expr1' expr2'+desugar (IndexLoopExpr n0 n1 n2 expr0 expr1 expr2 expr3) = do+  name <- fresh+  helper <- genHelper name+  return $ ApplyExpr (LetRecExpr [([name], helper)] (ApplyExpr (VarExpr name) expr1)) expr0+ where+  genHelper :: String -> DesugarM EgisonExpr+  genHelper name = do+    indicesName <- fresh+    patName <- fresh+    let subst = [(n0, ApplyExpr (ApplyExpr (VarExpr name) (VarExpr indicesName)) (VarExpr patName)), (n1, VarExpr patName)]+    bodyExpr <- local (subst ++) $ desugar expr2+    initExpr <- desugar expr3+    let matchClauses = [ (PatternExpr $ InductivePattern "nil" [], LambdaExpr [patName] $ initExpr)+                       , (PatternExpr $ InductivePattern "cons" [PatternExpr (PatVar n2), PatternExpr (PatVar indicesName)], LambdaExpr [patName] $ bodyExpr)]+    return $ LambdaExpr [indicesName] $ MatchExpr (VarExpr indicesName) matcher matchClauses++  matcher :: EgisonExpr+  matcher = ApplyExpr (VarExpr "list") SomethingExpr+         desugar (MatchExpr expr0 expr1 clauses) = do     expr0' <- desugar expr0@@ -163,6 +188,9 @@   clause' <- desugarMatchClause clause   return $ MatchAllExpr expr0' expr1' clause'   +desugar (PatternExpr pattern) =+  PatternExpr <$> desugarPattern pattern+   desugar (DoExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr@@ -172,9 +200,25 @@   expr0' <- desugar expr0   expr1' <- desugar expr1   return $ ApplyExpr expr0' expr1'++desugar (VarExpr name) = do+  asks $ maybe (VarExpr name) id . lookup name    desugar expr = return expr +desugarPattern :: EgisonPattern -> DesugarM EgisonPattern+desugarPattern (ValuePat expr) = ValuePat <$> desugar expr+desugarPattern (PredPat expr) = PredPat <$> desugar expr+desugarPattern (CutPat expr) = CutPat <$> desugar expr+desugarPattern (NotPat expr) = NotPat <$> desugar expr+desugarPattern (AndPat exprs) = AndPat <$> mapM desugar exprs+desugarPattern (OrPat exprs)  = OrPat <$> mapM desugar exprs+desugarPattern (IndexedPattern pat expr) = +  IndexedPattern <$> desugarPattern pat <*> desugar expr+desugarPattern (InductivePattern name exprs) =+  InductivePattern name <$> mapM desugar exprs+desugarPattern pattern = return pattern+ desugarBinding :: BindingExpr -> DesugarM BindingExpr desugarBinding (name, expr) = do   expr' <- desugar expr@@ -199,5 +243,4 @@   clause' <- desugarMatchClause clause   rest'   <- desugarMatchClauses rest   return $ clause : rest'-   desugarMatchClauses [] = return []

@@ -25,34 +25,20 @@ import Language.Egison.Types import Language.Egison.Desugar   -runParser' :: Parser a -> String -> Either EgisonError a-runParser' parser input = either (throwError . Parser) return $ parse parser "egison" (B.pack input)-  -readTopExprs :: String -> Either EgisonError [EgisonTopExpr]-readTopExprs input = either throwError (mapM desugarTopExpr) $ runParser' (whiteSpace >> parseTopExprs) input--readTopExpr :: String -> Either EgisonError EgisonTopExpr-readTopExpr input = either throwError desugarTopExpr $ runParser' (whiteSpace >> parseTopExpr) input--readExprs :: String -> Either EgisonError [EgisonExpr]-readExprs input = either throwError (mapM desugarExpr) $ runParser' (whiteSpace >> parseExprs) input+doParse :: Parser a -> String -> Either EgisonError a+doParse p input = either (throwError . Parser) return $ parse p "egison" $ B.pack input -readExpr :: String -> Either EgisonError EgisonExpr-readExpr input = either throwError desugarExpr $ runParser' (whiteSpace >> parseExpr) input+readTopExprs :: String -> Fresh (Either EgisonError [EgisonTopExpr])+readTopExprs input = runDesugarM $ either throwError (mapM desugarTopExpr) $ doParse (whiteSpace >> parseTopExprs) input -desugarTopExpr :: EgisonTopExpr -> Either EgisonError EgisonTopExpr-desugarTopExpr (Define name expr) = do-  expr' <- desugarExpr expr-  return (Define name expr')-  -desugarTopExpr (Test expr) = do-  expr' <- desugarExpr expr-  return (Test expr')+readTopExpr :: String -> Fresh (Either EgisonError EgisonTopExpr)+readTopExpr input = runDesugarM $ either throwError desugarTopExpr $ doParse (whiteSpace >> parseTopExpr) input -desugarTopExpr expr = return expr+readExprs :: String -> Fresh (Either EgisonError [EgisonExpr])+readExprs input = runDesugarM $ either throwError (mapM desugar) $ doParse (whiteSpace >> parseExprs) input -desugarExpr :: EgisonExpr -> Either EgisonError EgisonExpr-desugarExpr expr = either throwError return $ runDesugarM $ desugar expr+readExpr :: String -> Fresh (Either EgisonError EgisonExpr)+readExpr input = runDesugarM $ either throwError desugar $ doParse (whiteSpace >> parseExpr) input  -- Expressions @@ -86,7 +72,11 @@ parseExprs = endBy parseExpr whiteSpace  parseExpr :: Parser EgisonExpr-parseExpr = (try parseConstantExpr+parseExpr = do expr <- parseExpr'+               option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> parseExpr')++parseExpr' :: Parser EgisonExpr+parseExpr' = (try parseConstantExpr              <|> try parseVarExpr --           <|> parseOmitExpr              <|> try parsePatVarExpr@@ -100,6 +90,7 @@                                       <|> try parseInductiveDataExpr              <|> parseInductivePatternExpr+             <|> try parseArrayExpr              <|> parseTupleExpr              <|> parseCollectionExpr              <|> parens (parseAndPatExpr @@ -109,29 +100,20 @@                          <|> parseFunctionExpr                          <|> parseLetRecExpr                          <|> parseLetExpr-                         <|> parseLoopExpr+                         <|> parseIndexLoopExpr                          <|> parseDoExpr                          <|> parseMatchAllExpr                          <|> parseMatchExpr                          <|> parseMatcherExpr                          <|> parseApplyExpr-                         <|> parseAlgebraicDataMatcherExpr)+                         <|> parseAlgebraicDataMatcherExpr+                         <|> parseGenerateArrayExpr+                         <|> parseArraySizeExpr+                         <|> parseArrayRefExpr)                          <?> "expression")  parseVarExpr :: Parser EgisonExpr-parseVarExpr = VarExpr <$> ident <*> parseIndexNums--parseIndexNums :: Parser [EgisonExpr]-parseIndexNums = ((:) <$> try (prefix >> parseExpr) <*> parseIndexNums)-              <|> pure []-  where-    prefix :: Parser Char-    prefix = do result <- char '_' >> isConsumed whiteSpace-                if result then parserFail "unexpected whiteSpace"-                          else return '_'-    -    isConsumed :: Parser a -> Parser Bool-    isConsumed p = (/=) <$> getPosition <*> (p >> getPosition)+parseVarExpr = VarExpr <$> ident  parseInductiveDataExpr :: Parser EgisonExpr parseInductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy parseExpr whiteSpace@@ -149,6 +131,12 @@   parseInnerExpr = (char '@' >> SubCollectionExpr <$> parseExpr)                <|> ElementExpr <$> parseExpr +parseArrayExpr :: Parser EgisonExpr+parseArrayExpr = between lp rp $ ArrayExpr <$> sepEndBy parseExpr whiteSpace+  where+    lp = P.lexeme lexer (string "[|")+    rp = P.lexeme lexer (string "|]")+ parseMatchAllExpr :: Parser EgisonExpr parseMatchAllExpr = keywordMatchAll >> MatchAllExpr <$> parseExpr <*> parseExpr <*> parseMatchClause @@ -236,9 +224,9 @@ parseVarName :: Parser String parseVarName = char '$' >> ident -parseLoopExpr :: Parser EgisonExpr-parseLoopExpr = keywordLoop >> LoopExpr <$> parseVarName <*> parseVarName-                                        <*> parseExpr <*> parseExpr <*> parseExpr+parseIndexLoopExpr :: Parser EgisonExpr+parseIndexLoopExpr = keywordIndexLoop >> IndexLoopExpr <$> parseVarName <*> parseVarName <*> parseVarName+                                                       <*> parseExpr <*> parseExpr <*> parseExpr <*> parseExpr  parseApplyExpr :: Parser EgisonExpr parseApplyExpr = (keywordApply >> ApplyExpr <$> parseExpr <*> parseExpr) @@ -252,7 +240,7 @@   case vars of     [] -> return . ApplyExpr func . TupleExpr $ rights args     _ | all null vars ->-        let genVar = modify (1+) >> gets (flip VarExpr [] . ('#':) . show)+        let genVar = modify (1+) >> gets (VarExpr . ('#':) . show)             args' = evalState (mapM (either (const genVar) return) args) 0         in return . LambdaExpr (annonVars $ length vars) . ApplyExpr func $ TupleExpr args'       | all (not . null) vars ->@@ -260,7 +248,7 @@             n = Set.size ns         in if Set.findMin ns == 1 && Set.findMax ns == n              then-               let args' = map (either (flip VarExpr [] . ('#':)) id) args+               let args' = map (either (VarExpr . ('#':)) id) args                in return . LambdaExpr (annonVars n) . ApplyExpr func $ TupleExpr args'              else fail "invalid partial application"       | otherwise -> fail "invalid partial application"@@ -284,7 +272,7 @@ parseValuePatExpr = reservedOp "," >> PatternExpr . ValuePat <$> parseExpr  parsePatVarExpr :: Parser EgisonExpr-parsePatVarExpr = P.lexeme lexer $ (PatternExpr .) . PatVar <$> parseVarName <*> parseIndexNums+parsePatVarExpr = P.lexeme lexer $ PatternExpr . PatVar <$> parseVarName  parsePredPatExpr :: Parser EgisonExpr parsePredPatExpr = reservedOp "?" >> PatternExpr . PredPat <$> parseExpr@@ -297,11 +285,20 @@  parseAlgebraicDataMatcherExpr :: Parser EgisonExpr parseAlgebraicDataMatcherExpr = keywordAlgebraicDataMatcher -                                >> (parens $ AlgebraicDataMatcher <$> parseAlgebraicDataMatcherBody)+                                >> (parens $ AlgebraicDataMatcherExpr <$> parseAlgebraicDataMatcherBody)   where     parseAlgebraicDataMatcherBody :: Parser [EgisonExpr]     parseAlgebraicDataMatcherBody = reservedOp "|" >> sepEndBy1 parseInductivePatternExpr whiteSpace +parseGenerateArrayExpr :: Parser EgisonExpr+parseGenerateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> parseVarNames <*> parseExpr <*> parseExpr++parseArraySizeExpr :: Parser EgisonExpr+parseArraySizeExpr = keywordArraySize >> ArraySizeExpr <$> parseExpr++parseArrayRefExpr :: Parser EgisonExpr+parseArrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> parseExpr <*> parseExpr+ --parseOmitExpr :: Parser EgisonExpr --parseOmitExpr = prefixChar '`' >> OmitExpr <$> ident <*> parseIndexNums @@ -368,13 +365,16 @@   , "pattern-constructor"   , "letrec"   , "let"-  , "loop"+  , "index-loop"   , "match-all"   , "match"   , "matcher"   , "do"   , "function"   , "algebraic-data-matcher"+  , "generate-array"+  , "array-size"+  , "array-ref"   , "something"   , "undefined"]   @@ -408,7 +408,7 @@ keywordPatternConstructor   = reserved "pattern-constructor" keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let"-keywordLoop                 = reserved "loop"+keywordIndexLoop            = reserved "index-loop" keywordMatchAll             = reserved "match-all" keywordMatch                = reserved "match" keywordMatcher              = reserved "matcher"@@ -417,6 +417,9 @@ keywordSomething            = reserved "something" keywordUndefined            = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher"+keywordGenerateArray        = reserved "generate-array"+keywordArraySize            = reserved "array-size"+keywordArrayRef             = reserved "array-ref"  sign :: Num a => Parser (a -> a) sign = (char '-' >> return negate)@@ -464,6 +467,8 @@  ident :: Parser String ident = P.identifier lexer+    <|> try ((:) <$> char '+' <*> ident)+    <|> try ((:) <$> char '-' <*> ident)     <|> (P.lexeme lexer $ string "+")     <|> (P.lexeme lexer $ string "-") 

@@ -6,19 +6,20 @@ import Control.Monad.Error  import Data.IORef+import qualified Data.Array as A  import System.IO+import System.Random  import Language.Egison.Types import Language.Egison.Core  primitiveEnv :: IO Env primitiveEnv = do-  let ops = map (second PrimitiveFunc) (primitives ++ ioPrimitives) ++-            map (second IOFunc) assertions+  let ops = map (second PrimitiveFunc) (primitives ++ ioPrimitives)   bindings <- forM (constants ++ ops) $ \(name, op) -> do     ref <- newIORef . WHNF $ Value op-    return ((name, []), ref)+    return (name, ref)   return $ extendEnv nullEnv bindings  {-# INLINE noArg #-}@@ -35,6 +36,7 @@           [WHNFData] -> m EgisonValue oneArg f = \vals -> case vals of                        [val] -> f val+                      [] -> f $ Value $ Tuple []                       _ -> throwError $ ArgumentsNum 1 $ length vals  {-# INLINE twoArgs #-}@@ -69,7 +71,7 @@              , ("-", integerBinaryOp (-))              , ("*", integerBinaryOp (*))              , ("modulo",    integerBinaryOp mod)-             , ("qutient",   integerBinaryOp quot)+             , ("quotient",   integerBinaryOp quot)              , ("remainder", integerBinaryOp rem)              , ("eq-n?",  integerBinaryPred (==))              , ("lt-n?",  integerBinaryPred (<))@@ -111,47 +113,49 @@              , ("lte?", lte)              , ("gt?",  gt)              , ("gte?", gte)-             , ("string-append", stringAppend) ]-             +             , ("string-append", stringAppend)+             , ("assert", assert)+             , ("assert-equal", assertEqual) ]+ integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc-integerUnaryOp op = oneArg $ \val ->+integerUnaryOp op = (liftError .) $ oneArg $ \val ->   Integer . op <$> fromIntegerValue val  integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc-integerBinaryOp op = twoArgs $ \val val' ->+integerBinaryOp op = (liftError .) $ twoArgs $ \val val' ->   (Integer .) . op <$> fromIntegerValue val                    <*> fromIntegerValue val'  integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc-integerBinaryPred pred = twoArgs $ \val val' ->+integerBinaryPred pred = (liftError .) $ twoArgs $ \val val' ->   (Bool .) . pred <$> fromIntegerValue val                   <*> fromIntegerValue val'  floatUnaryOp :: (Double -> Double) -> PrimitiveFunc-floatUnaryOp op = oneArg $ \val ->+floatUnaryOp op = (liftError .) $ oneArg $ \val ->   Float . op <$> fromFloatValue val  floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc-floatBinaryOp op = twoArgs $ \val val' ->+floatBinaryOp op = (liftError .) $ twoArgs $ \val val' ->   (Float .) . op <$> fromFloatValue val                  <*> fromFloatValue val'  floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc-floatBinaryPred pred = twoArgs $ \val val' ->+floatBinaryPred pred = (liftError .) $ twoArgs $ \val val' ->   (Bool .) . pred <$> fromFloatValue val                   <*> fromFloatValue val'  floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc-floatToIntegerOp op = oneArg $ \val ->+floatToIntegerOp op = (liftError .) $ oneArg $ \val ->   Integer . op <$> fromFloatValue val  eq :: PrimitiveFunc-eq = twoArgs $ \val val' ->+eq = (liftError .) $ twoArgs $ \val val' ->   (Bool .) . (==) <$> fromPrimitiveValue val                   <*> fromPrimitiveValue val'  lt :: PrimitiveFunc-lt = twoArgs lt'+lt = (liftError .) $ twoArgs lt'  where   lt' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i < i'   lt' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i < f@@ -162,7 +166,7 @@   lt' val _ = throwError $ TypeMismatch "number" val  lte :: PrimitiveFunc-lte = twoArgs lte'+lte = (liftError .) $ twoArgs lte'  where   lte' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i <= i'   lte' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i <= f@@ -173,7 +177,7 @@   lte' val _ = throwError $ TypeMismatch "number" val  gt :: PrimitiveFunc-gt = twoArgs gt'+gt = (liftError .) $ twoArgs gt'  where   gt' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i > i'   gt' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i > f@@ -184,7 +188,7 @@   gt' val _ = throwError $ TypeMismatch "number" val  gte :: PrimitiveFunc-gte = twoArgs gte'+gte = (liftError .) $ twoArgs gte'  where   gte' (Value (Integer i)) (Value (Integer i')) = return $ Bool $ i >= i'   gte' (Value (Integer i)) (Value (Float f)) = return $ Bool $ fromInteger i >= f@@ -194,17 +198,36 @@   gte' (Value (Float _)) val = throwError $ TypeMismatch "number" val   gte' val _ = throwError $ TypeMismatch "number" val ++ stringAppend :: PrimitiveFunc-stringAppend = twoArgs $ \val val' ->+stringAppend = (liftError .) $ twoArgs $ \val val' ->   (String .) . (++) <$> fromStringValue val                     <*> fromStringValue val' +assert ::  PrimitiveFunc+assert = (liftError .) $ twoArgs $ \label test -> do+  test <- fromBoolValue 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 +++                                  "\n but found: " ++ show actual+ -- -- IO Primitives --  ioPrimitives :: [(String, PrimitiveFunc)]-ioPrimitives = [ ("open-input-file", makePort ReadMode)+ioPrimitives = [ ("return", return')+               , ("open-input-file", makePort ReadMode)                , ("open-output-file", makePort WriteMode)                , ("close-input-port", closePort)                , ("close-output-port", closePort)@@ -215,6 +238,7 @@                , ("write-string", writeString)                , ("write", write) --             , ("print", writeStringLine)+               , ("eof?", isEOFStdin)                , ("flush", flushStdout)                , ("read-char-from-port", readCharFromPort)                , ("read-line-from-port", readLineFromPort)@@ -222,92 +246,88 @@                , ("write-char-to-port", writeCharToPort)                , ("write-string-to-port", writeStringToPort)                , ("write-to-port", writeToPort)+               , ("eof-port?", isEOFPort) --             , ("print-to-port", writeStringLineToPort)-               , ("flush-port", flushPort) ]+               , ("flush-port", flushPort) +--               , ("rand", rand)+--               , ("rand-range", randRange) ]+               , ("rand", randRange) ]                  --             , ("get-lib-dir-name", getLibDirName) ] -makeIO :: IO EgisonValue -> EgisonValue-makeIO io = IOFunc . oneArg $ \val ->-  case val of-    Value World -> Tuple . (:) World . return <$> liftIO io-    _ -> throwError $ TypeMismatch "world" val+makeIO :: EgisonM EgisonValue -> EgisonValue+makeIO m = IOFunc $ liftM (Value . Tuple . (World :) . (:[])) m -makeIO' :: IO () -> EgisonValue-makeIO' io = IOFunc . oneArg $ \val ->-  case val of-    Value World -> liftIO io >> return World-    _ -> throwError $ TypeMismatch "world" val+makeIO' :: EgisonM () -> EgisonValue+makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) +return' :: PrimitiveFunc+return' = oneArg $ return . makeIO . evalDeep+ makePort :: IOMode -> PrimitiveFunc-makePort mode = oneArg $ \val -> do+makePort mode = (liftError .) $ oneArg $ \val -> do   filename <- fromStringValue val -  return . makeIO $ Port <$> openFile filename mode+  return . makeIO . liftIO $ Port <$> openFile filename mode  closePort :: PrimitiveFunc-closePort = oneArg $ \val -> makeIO' . hClose <$> fromPortValue val+closePort = (liftError .) $ oneArg $ \val ->+  makeIO' . liftIO . hClose <$> fromPortValue val  writeChar :: PrimitiveFunc-writeChar = oneArg $ \val -> makeIO' . putChar <$> fromCharValue val+writeChar = (liftError .) $ oneArg $ \val ->+  makeIO' . liftIO . putChar <$> fromCharValue val  writeString :: PrimitiveFunc-writeString = oneArg $ \val -> makeIO' . putStr <$> fromStringValue val+writeString = (liftError .) $ oneArg $ \val ->+  makeIO' . liftIO . putStr <$> fromStringValue val  write :: PrimitiveFunc-write = oneArg $ Right . makeIO' . putStr . show+write = oneArg $ \val ->+  makeIO' . liftIO . putStr . show <$> evalDeep val  readChar :: PrimitiveFunc-readChar = noArg $ Right $ makeIO (liftM Char getChar)+readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar  readLine :: PrimitiveFunc-readLine = noArg $ Right $ makeIO (liftM String getLine)+readLine = noArg $ return $ makeIO $ liftIO $ liftM String getLine  flushStdout :: PrimitiveFunc-flushStdout = noArg $ Right $ makeIO' $ hFlush stdout+flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout +isEOFStdin :: PrimitiveFunc+isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF+ writeCharToPort :: PrimitiveFunc-writeCharToPort = twoArgs $ \val val' ->-  (makeIO' .) . hPutChar <$> fromPortValue val <*> fromCharValue val'+writeCharToPort = (liftError .) $ twoArgs $ \val val' ->+  ((makeIO' . liftIO) .) . hPutChar <$> fromPortValue val <*> fromCharValue val'  writeStringToPort :: PrimitiveFunc-writeStringToPort = twoArgs $ \val val' ->-  (makeIO' .) . hPutStr <$> fromPortValue val <*> fromStringValue val'+writeStringToPort = (liftError .) $ twoArgs $ \val val' ->+  ((makeIO' . liftIO) .) . hPutStr <$> fromPortValue val <*> fromStringValue val'  writeToPort :: PrimitiveFunc-writeToPort = twoArgs $ \val val' ->-  makeIO' . flip hPutStr (show val') <$> fromPortValue val+writeToPort = twoArgs $ \val val' -> do+  ((makeIO' . liftIO) .) . hPutStr <$> liftError (fromPortValue val)+                                   <*> (show <$> evalDeep val')  readCharFromPort :: PrimitiveFunc-readCharFromPort = oneArg $ \val ->-  makeIO . liftM Char . hGetChar <$> fromPortValue val+readCharFromPort = (liftError .) $ oneArg $ \val ->+  makeIO . liftIO . liftM Char . hGetChar <$> fromPortValue val  readLineFromPort :: PrimitiveFunc-readLineFromPort = oneArg $ \val ->-  makeIO . liftM String . hGetLine <$> fromPortValue val+readLineFromPort = (liftError .) $ oneArg $ \val ->+  makeIO . liftIO . liftM String . hGetLine <$> fromPortValue val  flushPort :: PrimitiveFunc-flushPort = oneArg $ \val ->-  makeIO' . hFlush <$> fromPortValue val------- Assertions---+flushPort = (liftError .) $ oneArg $ \val ->+  makeIO' . liftIO . hFlush <$> fromPortValue val -assertions :: [(String, IOFunc)]-assertions = [ ("assert", assert)-             , ("assert-equal", assertEqual) ]+isEOFPort :: PrimitiveFunc+isEOFPort = (liftError .) $ oneArg $ \val ->+  makeIO . liftIO . liftM Bool . hIsEOF <$> fromPortValue val -assert :: IOFunc -assert = twoArgs $ \label test -> do-  test <- liftError $ fromBoolValue test-  if test-    then return $ Bool True-    else throwError $ Assertion $ show label+--rand :: PrimitiveFunc+--rand = noArg $ return $ makeIO $ liftIO $ liftM Integer $ getStdRandom random -assertEqual :: IOFunc -assertEqual = threeArgs $ \label actual expected -> do-  actual <- evalDeep actual-  expected <- evalDeep expected-  if actual == expected-    then return $ Bool True-    else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++-                                  "\n but found: " ++ show actual+randRange :: PrimitiveFunc+randRange = (liftError .) $ twoArgs $ \val val' ->+  return . makeIO . liftIO . liftM Integer . getStdRandom . randomR =<< liftM2 (,) (fromIntegerValue val) (fromIntegerValue val')

@@ -1,8 +1,11 @@-{-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving,+             MultiParamTypeClasses, UndecidableInstances  #-} module Language.Egison.Types where  import Control.Applicative import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Identity import Control.Monad.Trans.Maybe  import Data.IORef@@ -12,6 +15,9 @@ import System.IO import Text.Parsec (ParseError) +import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+ -- -- Expressions --@@ -31,11 +37,12 @@   | BoolExpr Bool   | IntegerExpr Integer   | FloatExpr Double-  | VarExpr String [EgisonExpr]-+  | VarExpr String+  | IndexedExpr EgisonExpr [EgisonExpr]   | InductiveDataExpr String [EgisonExpr]   | TupleExpr [EgisonExpr]   | CollectionExpr [InnerExpr]+  | ArrayExpr [EgisonExpr]    | PatternExpr EgisonPattern @@ -45,7 +52,7 @@   | LetExpr [BindingExpr] EgisonExpr   | LetRecExpr [BindingExpr] EgisonExpr -  | LoopExpr String String EgisonExpr EgisonExpr EgisonExpr+  | IndexLoopExpr String String String EgisonExpr EgisonExpr EgisonExpr EgisonExpr        | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause@@ -58,7 +65,10 @@        | ApplyExpr EgisonExpr EgisonExpr -  | AlgebraicDataMatcher [EgisonExpr]+  | AlgebraicDataMatcherExpr [EgisonExpr]+  | GenerateArrayExpr [String] EgisonExpr EgisonExpr+  | ArraySizeExpr EgisonExpr+  | ArrayRefExpr EgisonExpr EgisonExpr    | SomethingExpr   | UndefinedExpr@@ -70,13 +80,14 @@  data EgisonPattern =     WildCard-  | PatVar String [EgisonExpr]+  | PatVar String   | ValuePat EgisonExpr   | PredPat EgisonExpr   | CutPat EgisonExpr   | NotPat EgisonExpr   | AndPat [EgisonExpr]   | OrPat [EgisonExpr]+  | IndexedPattern EgisonPattern EgisonExpr   | InductivePattern String [EgisonExpr]  deriving (Show) @@ -116,18 +127,19 @@   | InductiveData String [EgisonValue]   | Tuple [EgisonValue]   | Collection [EgisonValue]+  | Array (IntMap EgisonValue)   | Pattern EgisonPattern   | Matcher Matcher   | Func Env [String] EgisonExpr   | PrimitiveFunc PrimitiveFunc-  | IOFunc IOFunc+  | IOFunc (EgisonM WHNFData)   | Port Handle   | Something+  | Undefined   | EOF  type Matcher = (Env, MatcherInfo)-type PrimitiveFunc = [WHNFData] -> Either EgisonError EgisonValue-type IOFunc = [WHNFData] -> EgisonM EgisonValue+type PrimitiveFunc = [WHNFData] -> EgisonM EgisonValue  instance Show EgisonValue where   show (Char c) = return c@@ -140,6 +152,7 @@   show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">"   show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]"   show (Collection vals) = "{" ++ unwords (map show vals) ++ "}"+  show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]"   show (Pattern _) = "#<pattern>"   show (Matcher _) = "#<matcher>"   show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)"@@ -147,6 +160,7 @@   show (IOFunc _) = "#<io>"   show (Port _) = "#<port>"   show Something = "something"+  show Undefined = "undefined"   show World = "#<world>"   show EOF = "#<eof>" @@ -158,6 +172,7 @@  (Float f) == (Float f') = f == f'  (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals'  (Tuple vals) == (Tuple vals') = vals == vals'+ (Array vals) == (Array vals') = vals == vals'  (Collection vals) == (Collection vals') = vals == vals'  _ == _ = False @@ -179,6 +194,7 @@     IInductiveData String [ObjectRef]   | ITuple [ObjectRef]   | ICollection [Inner]+  | IArray (IntMap ObjectRef)  data Inner =     IElement ObjectRef@@ -189,6 +205,7 @@   show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"   show (Intermediate (ITuple _)) = "[...]"   show (Intermediate (ICollection _)) = "{...}"+  show (Intermediate (IArray _)) = "[|...|]"   fromCharValue :: WHNFData -> Either EgisonError Char fromCharValue (Value (Char c)) = return c@@ -234,7 +251,7 @@ -- Environment -- -type Var = (String, [Integer])+type Var = String type Env = [HashMap Var ObjectRef] type Binding = (Var, ObjectRef) @@ -277,8 +294,7 @@      instance Show EgisonError where   show (Parser error) = "Parse error at: " ++ show error-  show (UnboundVariable (var, nums)) = "Unbound variable: " ++ var ++-                                      concatMap (('_':) . show) nums+  show (UnboundVariable var) = "Unbound variable: " ++ var   show (TypeMismatch expected found) = "Expected " ++  expected ++                                         ", but found: " ++ show found   show (ArgumentsNum expected got) = "Wrong number of arguments: expected " ++@@ -299,13 +315,49 @@ -- Monads -- +newtype FreshT m a = FreshT { unFreshT :: StateT Int m a }+  deriving (Functor, Applicative, Monad, MonadState Int, MonadTrans)++type Fresh = FreshT Identity++class (Applicative m, Monad m) => MonadFresh m where+  fresh :: m String++instance (Applicative m, Monad m) => MonadFresh (FreshT m) where+  fresh = FreshT $ do counter <- get; modify (+ 1)+                      return $ "$_" ++ show counter++instance (MonadError e m) => MonadError e (FreshT m) where+  throwError = lift . throwError+  catchError m h = FreshT $ catchError (unFreshT m) (unFreshT . h)++instance (MonadState s m) => MonadState s (FreshT m) where+  get = lift $ get+  put s = lift $ put s+  +instance MonadIO (FreshT IO) where+  liftIO = lift++runFreshT :: Monad m => Int -> FreshT m a -> m (a, Int)+runFreshT seed = flip (runStateT . unFreshT) seed++runFresh :: Int -> Fresh a -> (a, Int)+runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m+ newtype EgisonM a = EgisonM {-    unEgisonM :: ErrorT EgisonError IO a+    unEgisonM :: ErrorT EgisonError (FreshT IO) a   } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError) -runEgisonM :: EgisonM a -> IO (Either EgisonError a)+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

@@ -36,7 +36,7 @@       {[$tgt (if (eq? tgt c)                  {[]}                  {})]}]-     [_ [something]+     [$ [something]       {[$tgt {tgt}]}]      })) @@ -46,28 +46,13 @@       {[$tgt (if (eq? tgt s)                  {[]}                  {})]}]-     [_ [something]+     [$ [something]       {[$tgt {tgt}]}]      }))  (define $ordering-  (matcher-    {[,$val []-      {[$tgt (if (eq? val tgt)-                 {[]}-                 {})]}]-     [<less> []-      {[<Less> {[]}]-       [_ {}]}]-     [<equal> []-      {[<Equal> {[]}]-       [_ {}]}]-     [<greater> []-      {[<Greater> {[]}]-       [_ {}]}]-     [_ [something]-      {[$tgt {tgt}]}]-     }))+  (algebraic-data-matcher +    (| <less> <equal> <greater>)))  (define $match?   (lambda [$a]

@@ -33,7 +33,12 @@                                       [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}                  (helper {} tgt))]}]        [<nioj ,$pxs $> [(list a)]-        {[$tgt (match-all tgt (list a) [<join $ys ,pxs> ys])]}]+        {[$tgt (letrec {[$helper (lambda [$pxs $tgt]+                                   (match [pxs tgt] [(list a) (list a)]+                                     {[[<nil> _] {tgt}]+                                      [[<snoc $x $xs> <snoc ,x $ys>] (helper xs ys)]+                                      [[_ _] {}]}))]}+                 (helper pxs tgt))]}]        [<nioj $ $> [(list a) (list a)]         {[$tgt (letrec {[$helper (lambda [$xs $ys]                                    (match ys (list a)@@ -78,6 +83,15 @@             {x @(filter pred xs)}             (filter pred xs))]}))) +(define $split+  (lambda [$pred $ls]+    (letrec {[$helper (lambda [$ls $xs $ys]+                        (match ls (list something)+                          {[<nil> [xs ys]]+                           [<cons (& ?pred $l) $rs> (helper rs {l @xs} ys)]+                           [<cons $l $rs> (helper rs xs {l @ys})]}))]}+      (helper ls {} {}))))+ (define $remove   (lambda [$a]     (lambda [$xs $x]@@ -102,42 +116,47 @@          [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))  (define $add-  (lambda [$xs $x]-    (if (member? x xs)-        xs-        {@xs x})))+  (lambda [$a]+    (lambda [$xs $x]+      (if ((member? a) x xs)+          xs+          {@xs x}))))  (define $union-  (lambda [$xs $ys]-    (match ys (list something)-      {[<nil> xs]-       [<cons $y $rs> ((union a) ((add a) xs y) rs)]})))+  (lambda [$a]+    (lambda [$xs $ys]+      (match ys (list something)+        {[<nil> xs]+         [<cons $y $rs> ((union a) ((add a) xs y) rs)]}))))  (define $occurrence-  (lambda [$xs]-    (letrec {[$remove-and-count-              (lambda [$x $xs]-                (match xs (list something)-                  {[<nil> [{} 1]]-                   [<cons ,x $ys> (let {[[$r $i] (remove-and-count x ys)]}-                                    [r (+ i 1)])]-                   [<cons $y $ys> (let {[[$r $i] (remove-and-count x ys)]}-                                    [{y @r} i])]}))]}-      (match xs (list something)-        {[<nil> {}]-         [<cons $x $ys> (let {[[$rs $i] (remove-and-count x ys)]}-                          {[x i] @(occurrence rs)})]}))))+  (lambda [$a]+    (lambda [$xs]+      (letrec {[$remove-and-count+                (lambda [$x $xs]+                  (match xs (list a)+                    {[<nil> [{} 1]]+                     [<cons ,x $ys> (let {[[$r $i] (remove-and-count x ys)]}+                                      [r (+ i 1)])]+                     [<cons $y $ys> (let {[[$r $i] (remove-and-count x ys)]}+                                      [{y @r} i])]}))]}+        (match xs (list something)+          {[<nil> {}]+           [<cons $x $ys> (let {[[$rs $i] (remove-and-count x ys)]}+                            {[x i] @((occurrence a) rs)})]}))))) +#| (define $subcollections   (lambda [$xs]     (foldr (lambda [$x $rs]              (let {[[$y $i] x]}                 (map-and-concat (lambda [$sub] -                                 (match-all (loop $l $j (between 1 i) {y @l} {}) (list something)+                                 (match-all (index-loop $l $j (between 1 i) {y @l} {}) (list something)                                    [<join $ys _> {@ys @sub}]))                                rs)))            {{}}            ((occurrence a) xs))))+|#  (define $size   (lambda [$xs]@@ -194,38 +213,46 @@         {@(reverse rs) x}]})))  (define $member?-  (lambda [$x $ys]-    (match ys (list something)-      {[<nil> #f]-       [<cons ,x $ys> #t]-       [<cons $y $ys> ((member? a) x ys)]})))+  (lambda [$a]+    (lambda [$x $ys]+      (match ys (list a)+        {[<nil> #f]+         [<cons ,x $ys> #t]+         [<cons $y $ys> ((member? a) x ys)]}))))  (define $unique-  (lambda [$xs]-    (letrec {[$loop-fn-              (lambda [$xs $ys]-                (match xs (list something)-                  {[<nil> ys]-                   [<cons $x $rs>-                    (if (member? x ys)-                        (loop-fn rs ys)-                        (loop-fn rs {@ys x}))]}))]}-      (loop-fn xs {}))))+  (lambda [$a]+    (lambda [$xs]+      (letrec {[$loop-fn+                (lambda [$xs $ys]+                  (match xs (list something)+                    {[<nil> ys]+                     [<cons $x $rs>+                      (if ((member? a) x ys)+                          (loop-fn rs ys)+                          (loop-fn rs {@ys x}))]}))]}+        (loop-fn xs {})))))  (define $subcollection?-  (lambda [$xs $ys]-    (match xs (list something)-      {[<nil> #t]-       [<cons $x $rest>-        (if (member? x ys)-            (subcollection? rest ys)-            #f)]})))+  (lambda [$a]+    (lambda [$xs $ys]+      (match xs (list something)+        {[<nil> #t]+         [<cons $x $rest>+          (if ((member? a) x ys)+              ((subcollection? a) rest ys)+              #f)]}))))  (define $concat   (lambda [$xs]     (match xs (list something)       {[<nil> {}]        [<cons $x $rs> {@x @(concat rs)}]})))++(define $empty?+  (function (list something)+   {[<nil>      #t]+    [<cons _ _> #f]}))  (define $multiset   (lambda [$a]

@@ -2,7 +2,7 @@  import Control.Applicative import Control.Monad-+import Data.IORef  import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (hUnitTestToTests)@@ -21,7 +21,9 @@ runTestCase :: FilePath -> Test runTestCase file = TestLabel file . TestCase $ do    env <- primitiveEnv >>= loadLibraries-  result <- runEgisonM $ loadFile file >>= evalTopExprs' env+  seed <- readIORef counter+  (result, seed') <- runFreshT seed $ runEgisonM $ loadFile file >>= evalTopExprs' env+  writeIORef counter seed'   assertString $ either show (const "") result  evalTopExprs' :: Env -> [EgisonTopExpr] -> EgisonM ()