egison 3.7.12 → 3.7.13

raw patch · 29 files changed

+2002/−551 lines, 29 filesdep +faildep +lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fail, lens

API changes (from Hackage documentation)

Files

• egison.cabal +8/−5
• elisp/egison-mode.el +0/−5
• hs-src/Interpreter/egison.hs +53/−41
• hs-src/Language/Egison.hs +24/−19
• hs-src/Language/Egison/Core.hs +280/−217
• hs-src/Language/Egison/Desugar.hs +74/−52
• hs-src/Language/Egison/MathOutput.hs +74/−11
• hs-src/Language/Egison/Parser.hs +45/−35
• hs-src/Language/Egison/ParserNonS.hs +986/−0
• hs-src/Language/Egison/Primitives.hs +18/−18
• hs-src/Language/Egison/Types.hs +117/−56
• hs-src/Language/Egison/Util.hs +18/−17
• lib/core/base.egi +1/−1
• lib/core/collection.egi +3/−5
• lib/core/number.egi +3/−2
• lib/core/string.egi +9/−9
• lib/math/common/arithmetic.egi +25/−8
• lib/math/expression.egi +3/−3
• sample/efficient-backtracking.egi +14/−0
• sample/math/geometry/ThurstonManifold.egi +85/−0
• sample/math/geometry/ThurstonManifold2.egi +54/−0
• sample/math/geometry/ThurstonManifold3.egi +37/−0
• sample/math/geometry/riemann-curvature-tensor-of-S2.egi +1/−1
• sample/n-queen.egi +5/−2
• sample/nishiwaki.egi +16/−0
• sample/poker-hands.egi +9/−9
• sample/prime-millionaire.egi +18/−0
• test/Test.hs +22/−5
• test/UnitTest.hs +0/−30

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.7.12+Version:             3.7.13 Synopsis:            Programming language with non-linear pattern-matching against non-free data Description:   An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.@@ -45,7 +45,7 @@   Please view and try more demonstrations!   .   <http://www.egison.org>-  .  +  .   Egison makes programming dramatically simple.   Please enjoy Egison! Homepage:            http://www.egison.org@@ -66,9 +66,11 @@ source-repository head   type: git   location: https://github.com/egison/egison.git-  + Library-  Build-Depends:   base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector, parallel, split, hashable+  Build-Depends:   base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector, parallel, split, hashable, lens+  if !impl(ghc > 8.0)+    Build-Depends: fail   Hs-Source-Dirs:  hs-src   Exposed-Modules:                    Language.Egison@@ -76,6 +78,7 @@                    Language.Egison.Desugar                    Language.Egison.Types                    Language.Egison.Parser+                   Language.Egison.ParserNonS                    Language.Egison.Primitives                    Language.Egison.Util                    Language.Egison.MathOutput@@ -87,7 +90,7 @@   Hs-Source-Dirs: test   Main-Is:        Test.hs   Build-Depends: egison, base >= 4.0 && < 5, transformers, mtl, Glob, HUnit, test-framework, test-framework-hunit, filepath-  Other-modules:   Paths_egison, UnitTest+  Other-modules:   Paths_egison  Benchmark benchmark   Type: exitcode-stdio-1.0

@@ -81,8 +81,6 @@      "\\<next-matcher\\>"      "\\<matcher\\>"      "\\<self\\>"-     "\\<matcher-bfs\\>"-     "\\<matcher-dfs\\>"      "\\<algebraic-data-matcher\\>"      "\\<pattern-function\\>" @@ -196,7 +194,6 @@         ((equal "if" name) 2)         ((equal "apply" name) 2)         ((equal "generate-array" name) 2)-        ((equal "array-size" name) 2)         ((equal "array-ref" name) 2)         ((equal "generate-tensor" name) 2)         ((equal "tensor-map" name) 2)@@ -210,8 +207,6 @@         ((equal "next-match-all" name) 2)         ((equal "next-match-all-lambda" name) 2)         ((equal "matcher" name) 2)-        ((equal "matcher-bfs" name) 2)-        ((equal "matcher-dfs" name) 2)         ((equal "algebraic-data-matcher" name) 2)         ((equal "pattern-function" name) 2)         ((equal "do" name) 2)

@@ -29,49 +29,48 @@           case opts of             Options {optShowHelp = True} -> printHelp             Options {optShowVersion = True} -> printVersionNumber-            Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag, optMathExpr = mathExprLang} -> do+            Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag, optMathExpr = mathExprLang, optSExpr = isSExpr} -> do               coreEnv <- if noIOFlag then initialEnvNoIO else initialEnv-              mEnv <- evalEgisonTopExprs coreEnv $ (map Load loadLibs) ++ (map LoadFile loadFiles)+              mEnv <- evalEgisonTopExprs coreEnv $ (map (Load isSExpr) loadLibs) ++ (map (LoadFile isSExpr) loadFiles)               case mEnv of                 Left err -> putStrLn $ show err                 Right env -> do                   case mExpr of                     Just expr ->                       if tsvFlag-                        then do ret <- runEgisonTopExprs env ("(execute (each (compose show-tsv print) " ++ expr ++ "))")+                        then do ret <- runEgisonTopExprs isSExpr env ("(execute (each (compose show-tsv print) " ++ expr ++ "))")                                 case ret of                                   Left err -> hPutStrLn stderr $ show err                                   Right _ -> return ()-                        else do ret <- runEgisonExpr env expr+                        else do ret <- runEgisonExpr isSExpr env expr                                 case ret of                                   Left err -> hPutStrLn stderr (show err) >> exitFailure                                   Right val -> putStrLn (show val) >> exitWith ExitSuccess                     Nothing ->                       case mCmd of-                        Just cmd -> do cmdRet <- runEgisonTopExpr env ("(execute " ++ cmd ++ ")")+                        Just cmd -> do cmdRet <- runEgisonTopExpr isSExpr env ("(execute " ++ cmd ++ ")")                                        case cmdRet of                                          Left err -> putStrLn (show err) >> exitFailure                                          _ -> exitWith ExitSuccess                         Nothing ->                           case mSub of-                            Just sub -> do cmdRet <- runEgisonTopExprs env ("(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if tsvFlag then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ intercalate " " (map fst fieldInfo) ++  "} {" ++ intercalate " " (map snd fieldInfo) ++  "})]} (" ++ sub ++ " SH.input))))")+                            Just sub -> do cmdRet <- runEgisonTopExprs isSExpr env ("(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if tsvFlag then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ intercalate " " (map fst fieldInfo) ++  "} {" ++ intercalate " " (map snd fieldInfo) ++  "})]} (" ++ sub ++ " SH.input))))")                                            case cmdRet of                                              Left err -> putStrLn (show err) >> exitFailure                                              _ -> exitWith ExitSuccess                             Nothing ->                               case nonOpts of-                                [] -> do-                                  when bannerFlag showBanner >> repl noIOFlag mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess-                                (file:args) -> do+                                [] -> when bannerFlag showBanner >> repl noIOFlag isSExpr mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess+                                (file:args) ->                                   case opts of                                     Options {optTestOnly = True} -> do                                       result <- if noIOFlag                                                   then do input <- readFile file-                                                          runEgisonTopExprsNoIO env input-                                                  else evalEgisonTopExprsTestOnly env [LoadFile file]+                                                          runEgisonTopExprsNoIO isSExpr env input+                                                  else evalEgisonTopExprsTestOnly env [LoadFile isSExpr file]                                       either print (const $ return ()) result                                     Options {optTestOnly = False} -> do-                                      result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map (ElementExpr . StringExpr) (map T.pack args))))]+                                      result <- evalEgisonTopExprs env [LoadFile isSExpr file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map (ElementExpr . StringExpr) (map T.pack args))))]                                       either print (const $ return ()) result  data Options = Options {@@ -88,7 +87,8 @@     optShowBanner :: Bool,     optTestOnly :: Bool,     optPrompt :: String,-    optMathExpr :: Maybe String+    optMathExpr :: Maybe String,+    optSExpr :: Bool     }  defaultOptions :: Options@@ -106,28 +106,18 @@     optShowBanner = True,     optTestOnly = False,     optPrompt = "> ",-    optMathExpr = Nothing+    optMathExpr = Nothing,+    optSExpr = True     }  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 ['T'] ["tsv"]-    (NoArg (\opts -> opts {optTsvOutput = True}))-    "output in tsv format",-  Option ['e'] ["eval"]-    (ReqArg (\expr opts -> opts {optEvalString = Just expr})-            "String")-    "eval the argument string",-  Option ['c'] ["command"]-    (ReqArg (\expr opts -> opts {optExecuteString = Just expr})-            "String")-    "execute the argument string",+  Option ['v', 'V'] ["version"]+    (NoArg (\opts -> opts {optShowVersion = True}))+    "show version number",   Option ['L'] ["load-library"]     (ReqArg (\d opts -> opts {optLoadLibs = optLoadLibs opts ++ [d]})             "[String]")@@ -139,16 +129,24 @@   Option [] ["no-io"]     (NoArg (\opts -> opts {optNoIO = True}))     "prohibit all io primitives",+  Option ['p'] ["prompt"]+    (ReqArg (\prompt opts -> opts {optPrompt = prompt})+            "String")+    "set prompt string",   Option [] ["no-banner"]     (NoArg (\opts -> opts {optShowBanner = False}))     "do not display banner",   Option ['t'] ["test"]     (NoArg (\opts -> opts {optTestOnly = True}))     "execute only test expressions",-  Option ['p'] ["prompt"]-    (ReqArg (\prompt opts -> opts {optPrompt = prompt})+  Option ['e'] ["eval"]+    (ReqArg (\expr opts -> opts {optEvalString = Just expr})             "String")-    "set prompt string",+    "eval the argument string",+  Option ['c'] ["command"]+    (ReqArg (\expr opts -> opts {optExecuteString = Just expr})+            "String")+    "execute the argument string",   Option ['s'] ["substitute"]     (ReqArg (\expr opts -> opts {optSubstituteString = Just expr})             "String")@@ -161,6 +159,9 @@     (ReqArg (\expr opts -> opts {optSubstituteString = Just ("(filter " ++ expr ++ " $)")})             "String")     "filter strings",+  Option ['T'] ["tsv"]+    (NoArg (\opts -> opts {optTsvOutput = True}))+    "output in tsv format",   Option ['F'] ["--field"]     (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [(readFieldOption d)]})             "String")@@ -168,7 +169,10 @@   Option ['M'] ["math"]     (ReqArg (\lang opts -> opts {optMathExpr = Just lang})             "String")-    "output in LaTeX format"+    "output in AsciiMath, Latex, or Mathematica format",+  Option ['N'] ["new-syntax"]+    (NoArg (\opts -> opts {optSExpr = False}))+    "parse by new syntax"   ]  readFieldOption :: String -> (String, String)@@ -214,11 +218,17 @@   putStrLn "  --substitute, -s expr      Substitute input using the argument expression"   putStrLn "  --map, -m expr             Substitute each line of input using the argument expression"   putStrLn "  --filter, -f expr          Filter each line of input using the argument predicate"+  putStrLn ""+  putStrLn "Options to change input or output format:"+  putStrLn "  --tsv, -T                  Input and output in tsv format"+  putStrLn "  --field, -F field          Specify a field type of input tsv"+  putStrLn "  --math, -M (asciimath|latex|mathematica)"+  putStrLn "                             Output in AsciiMath, LaTeX, or Mathematica format (only for interpreter)"   exitWith ExitSuccess  printVersionNumber :: IO () printVersionNumber = do-  putStrLn $ showVersion version +  putStrLn $ showVersion version   exitWith ExitSuccess  showBanner :: IO ()@@ -234,27 +244,27 @@ showByebyeMessage :: IO () showByebyeMessage = putStrLn $ "Leaving Egison Interpreter." -repl :: Bool -> (Maybe String) -> Env -> String -> IO ()-repl noIOFlag mathExprLang env prompt = do+repl :: Bool -> Bool -> (Maybe String) -> Env -> String -> IO ()+repl noIOFlag isSExpr mathExprLang env prompt = do   loop env  where   settings :: MonadIO m => FilePath -> Settings m   settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history") }-    +   loop :: Env -> IO ()-  loop env = (do +  loop env = (do     home <- getHomeDirectory-    input <- liftIO $ runInputT (settings home) $ getEgisonExpr prompt+    input <- liftIO $ runInputT (settings home) $ getEgisonExpr isSExpr prompt     case (noIOFlag, input) of       (_, Nothing) -> return ()-      (True, Just (_, (LoadFile _))) -> do+      (True, Just (_, (LoadFile _ _))) -> do         putStrLn "error: No IO support"         loop env-      (True, Just (_, (Load _))) -> do+      (True, Just (_, (Load _ _))) -> do         putStrLn "error: No IO support"         loop env       (_, Just (topExpr, _)) -> do-        result <- liftIO $ runEgisonTopExpr' env topExpr+        result <- liftIO $ runEgisonTopExpr' isSExpr env topExpr         case result of           Left err -> do             liftIO $ putStrLn $ show err@@ -266,6 +276,8 @@               (Just "haskell") -> putStrLn (mathExprToHaskell output) >> loop env'               (Just "asciimath") -> putStrLn (mathExprToAsciiMath output) >> loop env'               (Just "latex") -> putStrLn (mathExprToLatex output) >> loop env'+              (Just "mathematica") -> putStrLn (mathExprToMathematica output) >> loop env'+              _ -> putStrLn "error: this output lang is not supported"              )     `catch`     (\e -> case e of

@@ -8,7 +8,6 @@  module Language.Egison        ( module Language.Egison.Types-       , module Language.Egison.Parser        , module Language.Egison.Primitives        -- * Eval Egison expressions        , evalEgisonExpr@@ -34,7 +33,8 @@ import qualified Paths_egison as P  import Language.Egison.Types-import Language.Egison.Parser+import Language.Egison.Parser as Parser+import Language.Egison.ParserNonS as ParserNonS import Language.Egison.Primitives import Language.Egison.Core @@ -59,38 +59,43 @@ evalEgisonTopExprsTestOnly env exprs = fromEgisonM $ evalTopExprsTestOnly env exprs  -- |eval an Egison expression. Input is a Haskell string.-runEgisonExpr :: Env -> String -> IO (Either EgisonError EgisonValue)-runEgisonExpr env input = fromEgisonM $ readExpr input >>= evalExprDeep env+runEgisonExpr :: Bool -> Env -> String -> IO (Either EgisonError EgisonValue)+runEgisonExpr True env input = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env+runEgisonExpr False env input = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env  -- |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+runEgisonTopExpr :: Bool -> Env -> String -> IO (Either EgisonError Env)+runEgisonTopExpr True env input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr env+runEgisonTopExpr False env input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr env  -- |eval an Egison top expression. Input is a Haskell string.-runEgisonTopExpr' :: Env -> String -> IO (Either EgisonError (Maybe String, Env))-runEgisonTopExpr' env input = fromEgisonM $ readTopExpr input >>= evalTopExpr' env+runEgisonTopExpr' :: Bool -> Env -> String -> IO (Either EgisonError (Maybe String, Env))+runEgisonTopExpr' True env input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' env+runEgisonTopExpr' False env input = fromEgisonM $ ParserNonS.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+runEgisonTopExprs :: Bool -> Env -> String -> IO (Either EgisonError Env)+runEgisonTopExprs True env input = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs env+runEgisonTopExprs False env input = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs env  -- |eval Egison top expressions without IO. Input is a Haskell string.-runEgisonTopExprsNoIO :: Env -> String -> IO (Either EgisonError Env)-runEgisonTopExprsNoIO env input = fromEgisonM $ readTopExprs input >>= evalTopExprsNoIO env+runEgisonTopExprsNoIO :: Bool -> Env -> String -> IO (Either EgisonError Env)+runEgisonTopExprsNoIO True env input = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprsNoIO env+runEgisonTopExprsNoIO False env input = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprsNoIO env  -- |load an Egison file-loadEgisonFile :: Env -> FilePath -> IO (Either EgisonError Env)-loadEgisonFile env path = evalEgisonTopExpr env (LoadFile path)+loadEgisonFile :: Bool -> Env -> FilePath -> IO (Either EgisonError Env)+loadEgisonFile isSExpr env path = evalEgisonTopExpr env (LoadFile isSExpr path)  -- |load an Egison library-loadEgisonLibrary :: Env -> FilePath -> IO (Either EgisonError Env)-loadEgisonLibrary env path = evalEgisonTopExpr env (Load path)+loadEgisonLibrary :: Bool -> Env -> FilePath -> IO (Either EgisonError Env)+loadEgisonLibrary isSExpr env path = evalEgisonTopExpr env (Load isSExpr path)  -- |Environment that contains core libraries initialEnv :: IO Env initialEnv = do   env <- primitiveEnv-  ret <- evalEgisonTopExprs env $ map Load coreLibraries+  ret <- evalEgisonTopExprs env $ map (Load True) coreLibraries   case ret of     Left err -> do       print . show $ err@@ -100,8 +105,8 @@ -- |Environment that contains core libraries without IO primitives initialEnvNoIO :: IO Env initialEnvNoIO = do-  env <- primitiveEnvNoIO -  ret <- evalEgisonTopExprs env $ map Load coreLibraries+  env <- primitiveEnvNoIO+  ret <- evalEgisonTopExprs env $ map (Load True) coreLibraries   case ret of     Left err -> do       print . show $ err

@@ -1,4 +1,6 @@-{-# Language TupleSections, ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ViewPatterns    #-}  {- | Module      : Language.Egison.Core@@ -40,36 +42,40 @@     , packStringValue     ) where -import Prelude hiding (mapM, mappend)+import           Prelude                   hiding (mapM, mappend, mconcat) -import Control.Arrow-import Control.Applicative-import Control.Monad.Except hiding (mapM)-import Control.Monad.State hiding (mapM, state)-import Control.Monad.Trans.Maybe+import           Control.Applicative+import           Control.Arrow+import           Control.Lens              (makeLenses, (%~), (&), (.~), (^.))+import           Control.Monad.Except      hiding (mapM)+import           Control.Monad.State       hiding (mapM, state)+import           Control.Monad.Trans.Maybe -import Data.List (partition)-import Data.List.Split (split, oneOf)-import Data.Sequence (Seq, ViewL(..), ViewR(..), (><))-import qualified Data.Sequence as Sq-import Data.Ratio-import Data.Foldable (toList)-import Data.Traversable (mapM)-import Data.IORef-import Data.Maybe+import           Data.Foldable             (toList)+import           Data.IORef+import           Data.List                 (last, partition, nub, drop, any)+import           Data.List.Split           (oneOf, split)+import           Data.Maybe+import           Data.Ratio+import           Data.Sequence             (Seq, ViewL (..), ViewR (..), (><))+import qualified Data.Sequence             as Sq+import           Data.Traversable          (mapM) -import qualified Data.HashMap.Lazy as HL-import Data.Array ((!))-import qualified Data.Array as Array-import qualified Data.Vector as V-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap+import           Data.Array                ((!))+import qualified Data.Array                as Array+import           Data.Map                  (unionWith, unionsWith, toAscList, singleton, Map, (!), empty)+import qualified Data.Map                  as M+import qualified Data.HashMap.Lazy         as HL+import           Data.HashMap.Strict       (HashMap)+import qualified Data.HashMap.Strict       as HashMap+import qualified Data.Vector               as V -import Data.Text (Text)-import qualified Data.Text as T+import           Data.Text                 (Text)+import qualified Data.Text                 as T -import Language.Egison.Types-import Language.Egison.Parser+import           Language.Egison.Parser as Parser+import           Language.Egison.ParserNonS as ParserNonS+import           Language.Egison.Types  -- -- Evaluator@@ -86,11 +92,11 @@   collectDefs (expr:exprs) bindings rest =     case expr of       Define name expr -> collectDefs exprs ((name, expr) : bindings) rest-      Load file -> do-        exprs' <- loadLibraryFile file+      Load b file -> do+        exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file         collectDefs (exprs' ++ exprs) bindings rest-      LoadFile file -> do-        exprs' <- loadFile file+      LoadFile b file -> do+        exprs' <- if b then Parser.loadFile file else ParserNonS.loadFile file         collectDefs (exprs' ++ exprs) bindings rest       Execute _ -> collectDefs exprs bindings (expr : rest)       _ -> collectDefs exprs bindings rest@@ -107,11 +113,11 @@   collectDefs (expr:exprs) bindings rest =     case expr of       Define name expr -> collectDefs exprs ((name, expr) : bindings) rest-      Load file -> do-        exprs' <- loadLibraryFile file+      Load b file -> do+        exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file         collectDefs (exprs' ++ exprs) bindings rest-      LoadFile file -> do-        exprs' <- loadFile file+      LoadFile b file -> do+        exprs' <- if b then Parser.loadFile file else ParserNonS.loadFile file         collectDefs (exprs' ++ exprs) bindings rest       Test _ -> collectDefs exprs bindings (expr : rest)       Redefine _ _ -> collectDefs exprs bindings (expr : rest)@@ -129,16 +135,16 @@   collectDefs (expr:exprs) bindings rest =     case expr of       Define name expr -> collectDefs exprs ((name, expr) : bindings) rest-      Load _ -> throwError $ Default "No IO support"-      LoadFile _ -> throwError $ Default "No IO support"-      _ -> collectDefs exprs bindings (expr : rest)+      Load _ _           -> throwError $ Default "No IO support"+      LoadFile _ _       -> throwError $ Default "No IO support"+      _                -> collectDefs exprs bindings (expr : rest)   collectDefs [] bindings rest = return (bindings, reverse rest)  evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env evalTopExpr env topExpr = do   ret <- evalTopExpr' env topExpr   case fst ret of-    Nothing -> return ()+    Nothing     -> return ()     Just output -> liftIO $ putStrLn output   return $ snd ret @@ -152,9 +158,9 @@   io <- evalExpr env expr   case io of     Value (IOFunc m) -> m >> return (Nothing, env)-    _ -> throwError $ TypeMismatch "io" io-evalTopExpr' env (Load file) = loadLibraryFile file >>= evalTopExprs env >>= return . ((,) Nothing)-evalTopExpr' env (LoadFile file) = loadFile file >>= evalTopExprs env >>= return . ((,) Nothing)+    _                -> throwError $ TypeMismatch "io" io+evalTopExpr' env (Load b file) = (if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file) >>= evalTopExprs env >>= return . ((,) Nothing)+evalTopExpr' env (LoadFile b file) = (if b then Parser.loadFile file else ParserNonS.loadFile file) >>= evalTopExprs env >>= return . ((,) Nothing)  evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c@@ -173,12 +179,12 @@   whnf <- evalExpr env expr   case whnf of     Value val -> return . Value $ QuotedFunc val-    _ -> throwError $ TypeMismatch "value in quote-function" $ whnf+    _         -> throwError $ TypeMismatch "value in quote-function" $ whnf  evalExpr env (VarExpr name) = do   x <- refVar' env name >>= evalRef   return (case x of-            Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) -> +            Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) ->               case fn of                 Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) argnames args js, 1)]]) p)                 Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)@@ -192,7 +198,7 @@  evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) =-  Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs +  Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs  evalExpr _ (TupleExpr []) = return . Value $ Tuple [] evalExpr env (TupleExpr [expr]) = evalExpr env expr@@ -208,7 +214,7 @@   fromInnerExpr :: InnerExpr -> EgisonM Inner   fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr   fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr- + evalExpr env (ArrayExpr exprs) = do   refs' <- mapM (newObjectRef env) exprs   return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs'@@ -217,10 +223,21 @@   whnfs <- mapM (evalExpr env) exprs   case whnfs of     ((Intermediate (ITensor (Tensor _ _ _))):_) -> do-      ret <- mapM toTensor whnfs >>= tConcat' >>= fromTensor+      ret <- mapM toTensor (map f $ zip whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor       return ret-    _ -> do-      fromTensor (Tensor [fromIntegral (length whnfs)] (V.fromList whnfs) [])+    _ -> fromTensor (Tensor [fromIntegral $ length whnfs] (V.fromList whnfs) [])+ where+  f ((Intermediate (ITensor (Tensor ns xs indices))), i) =+    Intermediate $ ITensor $ Tensor ns (V.fromList $ map g $ zip (V.toList xs) $ map (\ms -> map toEgison $ (toInteger i):ms) $ enumTensorIndices ns) indices+  f (x, _) = x+  g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) =+    let Env _ maybe_vwi = env in+    let fn' = case maybe_vwi of+                Nothing -> fn+                Just (VarWithIndices nameString indexList) ->+                   Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms in+    Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p+  g (x, _) = x  evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do   nsWhnf <- evalExpr env nsExpr@@ -271,7 +288,7 @@                 let mObjRef = refVar env (Var xs $ is ++ (map f indices))                 case mObjRef of                   (Just objRef) -> evalRef objRef-                  Nothing -> evalExpr env expr+                  Nothing       -> evalExpr env expr               _ -> evalExpr env expr   js <- mapM (\i -> case i of                       Superscript n -> evalExprDeep env n >>= return . Superscript@@ -279,7 +296,7 @@                       SupSubscript n -> evalExprDeep env n >>= return . SupSubscript                       Userscript n -> evalExprDeep env n >>= return . Userscript               ) indices-  +   ret <- case tensor of       (Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])])))) -> do         js2 <- mapM (\i -> case i of@@ -311,10 +328,10 @@                              Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript                     ) indices         refArray tensor (map (\j -> case j of-                                      Superscript k -> ScalarData k-                                      Subscript k -> ScalarData k+                                      Superscript k  -> ScalarData k+                                      Subscript k    -> ScalarData k                                       SupSubscript k -> ScalarData k-                                      Userscript k -> ScalarData k+                                      Userscript k   -> ScalarData k                               ) js2)   let ret2 = case expr of                (VarExpr var) -> do@@ -328,10 +345,10 @@   return ret2  where   f :: Index a -> Index ()-  f (Superscript _) = Superscript ()-  f (Subscript _) = Subscript ()+  f (Superscript _)  = Superscript ()+  f (Subscript _)    = Subscript ()   f (SupSubscript _) = SupSubscript ()-  f (Userscript _) = Userscript ()+  f (Userscript _)   = Userscript ()  evalExpr env (SubrefsExpr bool expr jsExpr) = do   js <- evalExpr env jsExpr >>= collectionToList >>= return . (map Subscript)@@ -340,7 +357,7 @@                 let mObjRef = refVar env (Var xs $ is ++ (take (length js) (repeat (Subscript ()))))                 case mObjRef of                   (Just objRef) -> evalRef objRef-                  Nothing -> evalExpr env expr+                  Nothing       -> evalExpr env expr               _ -> evalExpr env expr   ret <- case tensor of       (Value (ScalarData _)) -> do@@ -355,10 +372,10 @@   return ret  where   f :: Index a -> Index ()-  f (Superscript _) = Superscript ()-  f (Subscript _) = Subscript ()+  f (Superscript _)  = Superscript ()+  f (Subscript _)    = Subscript ()   f (SupSubscript _) = SupSubscript ()-  f (Userscript _) = Userscript ()+  f (Userscript _)   = Userscript ()  evalExpr env (SuprefsExpr bool expr jsExpr) = do   js <- evalExpr env jsExpr >>= collectionToList >>= return . (map Superscript)@@ -367,7 +384,7 @@                 let mObjRef = refVar env (Var xs $ is ++ (take (length js) (repeat (Superscript ()))))                 case mObjRef of                   (Just objRef) -> evalRef objRef-                  Nothing -> evalExpr env expr+                  Nothing       -> evalExpr env expr               _ -> evalExpr env expr   ret <- case tensor of       (Value (ScalarData _)) -> do@@ -382,10 +399,10 @@   return ret  where   f :: Index a -> Index ()-  f (Superscript _) = Superscript ()-  f (Subscript _) = Subscript ()+  f (Superscript _)  = Superscript ()+  f (Subscript _)    = Subscript ()   f (SupSubscript _) = SupSubscript ()-  f (Userscript _) = Userscript ()+  f (Userscript _)   = Userscript ()  evalExpr env (UserrefsExpr bool expr jsExpr) = do   val <- evalExprDeep env expr@@ -412,7 +429,7 @@  evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern -evalExpr (Env frame Nothing) (FunctionExpr args) = throwError $ Default "function symbol is not bound to a variable" +evalExpr (Env frame Nothing) (FunctionExpr args) = throwError $ Default "function symbol is not bound to a variable"  evalExpr env@(Env frame (Just name)) (FunctionExpr args) = do   args' <- mapM (\arg -> evalExprDeep env arg) args@@ -444,7 +461,7 @@  evalExpr env (LetRecExpr bindings expr) =   let bindings' = evalState (concat <$> mapM extractBindings bindings) 0-  in recursiveBind env bindings' >>= flip evalExpr expr +  in recursiveBind env bindings' >>= flip evalExpr expr  where   extractBindings :: BindingExpr -> State Int [(Var, EgisonExpr)]   extractBindings ([name], expr) = return [(name, expr)]@@ -520,8 +537,8 @@     (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)     return (Value (TensorData (Tensor s ys js)))   removeDFscripts _ whnf = return whnf-     + evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do   let body = foldr genLet (ApplyExpr expr $ TupleExpr [VarExpr $ stringToVar "#1"]) bindings   applyFunc env (Value $ Func Nothing env ["#1"] body) $ Value World@@ -539,11 +556,10 @@         Tuple [_, val'] -> return $ Value val'     _ -> throwError $ TypeMismatch "io" io -evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do+evalExpr env (MatchAllExpr target matcher clauses) = do   target <- evalExpr env target   matcher <- evalExpr env matcher >>= evalMatcherWHNF-  result <- patternMatch env pattern target matcher-  mmap (flip evalExpr expr . extendEnv env) result >>= fromMList+  f matcher target >>= fromMList  where   fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData   fromMList MNil = return . Value $ Collection Sq.empty@@ -552,6 +568,11 @@     tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)     seqRef <- liftIO . newIORef $ Sq.fromList [head, tail]     return . Intermediate $ ICollection $ seqRef+  f matcher target = do+      let tryMatchClause (pattern, expr) results = do+            result <- patternMatch env pattern target matcher+            mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results+      mfoldr tryMatchClause (return MNil) (fromList clauses)  evalExpr env (MatchExpr target matcher clauses) = do   target <- evalExpr env target@@ -563,7 +584,7 @@             result <- patternMatch env pattern target matcher             case result of               MCons bindings _ -> evalExpr (extendEnv env bindings) expr-              MNil -> cont+              MNil             -> cont       foldr tryMatchClause (throwError $ Default "failed pattern match") clauses  evalExpr env (SeqExpr expr1 expr2) = do@@ -654,16 +675,17 @@        memoizeFrame   evalExpr env expr -evalExpr env (MatcherBFSExpr info) = return $ Value $ UserMatcher env BFSMode info-evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info- +evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info BFSMode++evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env info (DFSMode "umdfs")+ evalExpr env (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do   fN <- (evalExpr env fstExpr >>= fromWHNF) :: EgisonM Integer   eN <- (evalExpr env lstExpr >>= fromWHNF) :: EgisonM Integer   xs <- mapM (\n -> (newObjectRef env (ApplyExpr fnExpr (IntegerExpr n)))) [fN..eN]   return $ Intermediate $ IArray $ Array.listArray (fN, eN) xs -evalExpr env (ArrayBoundsExpr expr) = +evalExpr env (ArrayBoundsExpr expr) =   evalExpr env expr >>= arrayBounds  evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do@@ -676,14 +698,9 @@                  Nothing -> env                  Just (VarWithIndices nameString indexList) -> Env frame (Just $ VarWithIndices nameString $ changeIndexList indexList ms)     fn <- evalExpr env' fnExpr-    applyFunc env fn (Value (makeTuple ms))) +    applyFunc env fn (Value (makeTuple ms)))                 (map (\ms -> map toEgison ms) (enumTensorIndices ns))   fromTensor (Tensor ns (V.fromList xs) [])- where -   changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]-   changeIndexList idxlist ms = map (\(i, m) -> case i of-                                                  Superscript s -> Superscript (s ++ m)-                                                  Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)  evalExpr env (TensorContractExpr fnExpr tExpr) = do   fn <- evalExpr env fnExpr@@ -764,8 +781,8 @@  where   applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue   applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF-   + evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr)@@ -828,28 +845,28 @@  applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData applyFunc env (Value (TensorData (Tensor s1 t1 i1))) tds = do-    tds <- fromTupleWHNF tds-    if (length s1) > (length i1) && (all (\(Intermediate (ITensor (Tensor s u i))) -> ((length s) - (length i) == 1)) tds)-       then do-            symId <- fresh-            let argnum = length tds-                subjs = map (\symName -> Subscript $ symbolScalarData symId (show symName)) [1 .. argnum]-                supjs = map (\symName -> Superscript $ symbolScalarData symId (show symName)) [1 .. argnum]-            dot <- evalExpr env (VarExpr $ stringToVar ".")-            makeITuple ((Value (TensorData (Tensor s1 t1 (i1 ++ supjs)))):(map Intermediate (map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)))) >>= applyFunc env dot-       else throwError $ Default "applyfunc"+  tds <- fromTupleWHNF tds+  if (length s1) > (length i1) && (all (\(Intermediate (ITensor (Tensor s u i))) -> ((length s) - (length i) == 1)) tds)+    then do+      symId <- fresh+      let argnum = length tds+          subjs = map (\symName -> Subscript $ symbolScalarData symId (show symName)) [1 .. argnum]+          supjs = map (\symName -> Superscript $ symbolScalarData symId (show symName)) [1 .. argnum]+      dot <- evalExpr env (VarExpr $ stringToVar ".")+      makeITuple ((Value (TensorData (Tensor s1 t1 (i1 ++ supjs)))):(map Intermediate (map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)))) >>= applyFunc env dot+    else throwError $ Default "applyfunc"  applyFunc env (Intermediate (ITensor (Tensor s1 t1 i1))) tds = do-    tds <- fromTupleWHNF tds-    if (length s1) > (length i1) && (all (\(Intermediate (ITensor (Tensor s u i))) -> ((length s) - (length i) == 1)) tds)-       then do-            symId <- fresh-            let argnum = length tds-                subjs = map (\symName -> Subscript $ symbolScalarData symId (show symName)) [1 .. argnum]-                supjs = map (\symName -> Superscript $ symbolScalarData symId (show symName)) [1 .. argnum]-            dot <- evalExpr env (VarExpr $ stringToVar ".")-            makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):(map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)))) >>= applyFunc env dot-       else throwError $ Default "applyfunc"+  tds <- fromTupleWHNF tds+  if (length s1) > (length i1) && (all (\(Intermediate (ITensor (Tensor s u i))) -> ((length s) - (length i) == 1)) tds)+    then do+      symId <- fresh+      let argnum = length tds+          subjs = map (\symName -> Subscript $ symbolScalarData symId (show symName)) [1 .. argnum]+          supjs = map (\symName -> Superscript $ symbolScalarData symId (show symName)) [1 .. argnum]+      dot <- evalExpr env (VarExpr $ stringToVar ".")+      makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):(map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)))) >>= applyFunc env dot+    else throwError $ Default "applyfunc"  applyFunc _ (Value (PartialFunc env n body)) arg = do   refs <- fromTuple arg@@ -891,7 +908,7 @@ applyFunc _ (Value (IOFunc m)) arg = do   case arg of      Value World -> m-     _ -> throwError $ TypeMismatch "world" arg+     _           -> throwError $ TypeMismatch "world" arg applyFunc _ (Value (QuotedFunc fn)) arg = do   args <- tupleToList arg   mExprs <- mapM extractScalar args@@ -903,12 +920,12 @@ applyFunc _ whnf _ = throwError $ TypeMismatch "function" whnf  refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData-refArray val [] = return val +refArray val [] = return val refArray (Value (Array array)) (index:indices) = do   if isInteger index     then do i <- (liftM fromInteger . fromEgison) index             if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array-              then refArray (Value (array ! i)) indices+              then refArray (Value (array Array.! i)) indices               else return  $ Value Undefined     else case index of            (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> do@@ -921,7 +938,7 @@   if isInteger index     then do i <- (liftM fromInteger . fromEgison) index             if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array-              then let ref = array ! i in+              then let ref = array Array.! i in                    evalRef ref >>= flip refArray indices               else return  $ Value Undefined     else case index of@@ -937,32 +954,32 @@   key <- fromEgison index   case HL.lookup key hash of     Just val -> refArray (Value val) indices-    Nothing -> return $ Value Undefined+    Nothing  -> return $ Value Undefined refArray (Intermediate (IIntHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of     Just ref -> evalRef ref >>= flip refArray indices-    Nothing -> return $ Value Undefined+    Nothing  -> return $ Value Undefined refArray (Value (CharHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of     Just val -> refArray (Value val) indices-    Nothing -> return $ Value Undefined+    Nothing  -> return $ Value Undefined refArray (Intermediate (ICharHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of     Just ref -> evalRef ref >>= flip refArray indices-    Nothing -> return $ Value Undefined+    Nothing  -> return $ Value Undefined refArray (Value (StrHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of     Just val -> refArray (Value val) indices-    Nothing -> return $ Value Undefined+    Nothing  -> return $ Value Undefined refArray (Intermediate (IStrHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of     Just ref -> evalRef ref >>= flip refArray indices-    Nothing -> return $ Value Undefined+    Nothing  -> return $ Value Undefined refArray val _ = throwError $ TypeMismatch "array or hash" val  arrayBounds :: WHNFData -> EgisonM WHNFData@@ -996,6 +1013,7 @@   let (names, exprs) = unzip bindings   refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr   let env' = extendEnv env $ makeBindings names refs+  let Env frame _ = env'   zipWithM_ (\ref (name,expr) -> do                case expr of                  MemoizedLambdaExpr names body -> do@@ -1010,14 +1028,14 @@                    case whnf of                      (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body))                  FunctionExpr args -> do-                   let Env frame _ = env'                    liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args-                 GenerateTensorExpr _ _ -> do-                   let Env frame _ = env'-                   liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ expr-                 _ -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr)+                 _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr+                   | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr)             refs bindings   return env'+ where+  isVarWithIndices :: Var -> Bool+  isVarWithIndices (Var _ xs) = not $ null xs  recursiveRebind :: Env -> (Var, EgisonExpr) -> EgisonM Env recursiveRebind env (name, expr) = do@@ -1042,32 +1060,46 @@ -- Pattern Match -- -patternMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) -patternMatch env pattern target matcher = processMStates [msingleton $ MState env [] [] [MAtom pattern target matcher]]+patternMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match)+patternMatch env pattern target matcher@(UserMatcher _ _ (DFSMode id)) = processMStatesAll 0 MatchingStates { _normalTree = [[(msingleton (MState BFSMode env [] [] [MAtom (DFSPat id pattern) target matcher]))]], _orderedOrTrees = M.empty, _ids = [], _bool = True }+patternMatch env pattern target matcher = processMStatesAll 0 MatchingStates { _normalTree = [[(msingleton (MState BFSMode env [] [] [MAtom pattern target matcher]))]], _orderedOrTrees = M.empty, _ids = [], _bool = topDFS pattern && not (containBFS pattern) } -processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)-processMStates [] = return MNil-processMStates streams = do-  (matches, streams') <- mapM processMStates' streams >>= extractMatches . concat-  mappend (fromList matches) $ processMStates streams'+processMStatesAll :: Int -> MatchingStates -> EgisonM (MList EgisonM Match)+processMStatesAll depth streams = do+  (matches, streams') <- (\(a, b) -> (fromList a, b)) <$> (processMStatesLine depth streams >>= extractMatches)+  if null (streams' ^. normalTree)+     then do matches' <- mapM (\id -> processMStatesAll 0 $ MatchingStates { _normalTree = map snd (toAscList $ (streams' ^. orderedOrTrees) M.! id), _orderedOrTrees = M.empty, _ids = [], _bool = streams' ^. bool }) $ streams' ^. ids+             mappend matches $ mconcat $ fromList matches'+     else mappend matches $ processMStatesAll (depth + 1) streams' -processMStates' :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]-processMStates' MNil = return []-processMStates' stream@(MCons state _) =-  case pmMode (getMatcher (topMAtom state)) of-    DFSMode -> processMStatesDFS stream-    BFSMode -> processMStatesBFS stream+processMStatesLine :: Int -> MatchingStates -> EgisonM MatchingStates+processMStatesLine depth streams = do+  (oomaps, idlist, nextlist) <- (concatTuple . unzip3) <$> mapM (processMStatesDorB (streams ^. bool) depth) (head $ streams ^. normalTree)+  let oots = unionsWith (unionWith (++)) $ streams ^. orderedOrTrees:oomaps+  let nt = mergeNT nextlist $ tail $ streams ^. normalTree+  let ids' = nub $ idlist ++ (streams ^. ids)+  return $ MatchingStates { _normalTree = nt, _orderedOrTrees = oots, _ids = ids', _bool = streams ^. bool }+ where+  concatTuple (a, b, c) = (concat a, concat b, concat c)+  mergeNT :: [MList EgisonM MatchingState] -> [[MList EgisonM MatchingState]] -> [[MList EgisonM MatchingState]]+  mergeNT [] oldnt = oldnt+  mergeNT nodes [] = [nodes]+  mergeNT nodes (x:oldnt) = (x ++ nodes):oldnt  gatherBindings :: MatchingState -> Maybe [Binding]-gatherBindings (MState _ _ bindings []) = return bindings-gatherBindings (MState _ _ bindings trees) = isResolved trees >> return bindings+gatherBindings (MState _ _ _ bindings []) = return bindings+gatherBindings (MState _ _ _ bindings trees) = isResolved trees >> return bindings   where isResolved :: [MatchingTree] -> Maybe ()         isResolved [] = return ()         isResolved (MAtom _ _ _ : _) = Nothing         isResolved (MNode _ state : rest) = gatherBindings state >> isResolved rest -extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])-extractMatches = extractMatches' ([], [])+extractMatches :: MatchingStates -> EgisonM ([Match], MatchingStates)+extractMatches streams+  | null (streams ^. normalTree) = return ([], streams)+  | otherwise = do+      (matches, s) <- extractMatches' ([], []) $ head $ streams ^. normalTree+      return (matches, streams & normalTree .~ (s:(tail $ streams ^. normalTree)))  where   extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])   extractMatches' (xs, ys) [] = return (xs, ys)@@ -1075,79 +1107,108 @@     states' <- states     extractMatches' (xs ++ [bindings], ys ++ [states']) rest   extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest-          ++processMStatesDorB :: Bool -> Int -> MList EgisonM MatchingState -> EgisonM ([Map Id (Map Int [MList EgisonM MatchingState])], [Id], [MList EgisonM MatchingState])+processMStatesDorB _ _ MNil = return ([], [], [])+processMStatesDorB b depth stream@(MCons state stream') =+  case topMAtom state of+    MAtom (OrderedOrPat id _ _) _ _ -> do+      let (state1, state2) = splitMStateOO state+      (oots, ids, newStreams) <- processMStatesDorB b depth (MCons state1 stream')+      return ((singleton id $ singleton depth [msingleton state2]):oots, ids ++ [id], newStreams)+    MAtom (DFSPat id _) _ _ -> mmap (return . (modeTo $ DFSMode id)) stream >>= processMStatesDorB b depth+    MAtom (BFSPat _) _ _ -> mmap (return . (modeTo BFSMode)) stream >>= processMStatesDorB b depth+    _ -> case pmMode state of+           DFSMode id | b -> (\x -> ([], [], x)) <$> processMStatesDFS stream+                      | otherwise -> do+                         newStreams <- processMStates (MCons state $ return MNil)+                         stream'' <- stream'+                         return ([singleton id (singleton depth [stream''])], [id], newStreams)+           BFSMode -> (\x -> ([], [], x)) <$> processMStates stream+ where+  splitMStateOO :: MatchingState -> (MatchingState, MatchingState)+  splitMStateOO (MState mode env loops bindings ((MAtom (OrderedOrPat _ pat1 pat2) target matcher) : trees)) =+    (MState mode env loops bindings ((MAtom pat1 target matcher) : trees), MState mode env loops bindings ((MAtom pat2 target matcher) : trees))+  splitMStateOO (MState mode env loops bindings ((MAtom pat target matcher) : trees)) =+    (MState mode env loops bindings [MAtom pat target matcher], MState mode env loops bindings trees)+  splitMStateOO (MState mode env loops bindings ((MNode penv state') : trees)) =+    let (state1, state2) = splitMStateOO state'+     in (MState mode env loops bindings (MNode penv state1 : trees), MState mode env loops bindings ((MNode penv state2) : trees))++modeTo :: PMMode -> MatchingState -> MatchingState+modeTo mode (MState _ env loops bindings (mtree:mtrees)) = MState mode env loops bindings $ (rmPat mtree):mtrees++rmPat :: MatchingTree -> MatchingTree+rmPat (MAtom (DFSPat _ pattern) target matcher) = MAtom pattern target matcher+rmPat (MAtom (BFSPat pattern) target matcher) = MAtom pattern target matcher+rmPat (MAtom pat target matcher) = MAtom pat target matcher+rmPat (MNode penv (MState mode env loops bindings (mtree:mtrees))) = MNode penv $ MState mode env loops bindings ((rmPat mtree):mtrees)++topMAtom :: MatchingState -> MatchingTree+topMAtom (MState _ _ _ _ (mAtom@(MAtom _ _ _):_)) = mAtom+topMAtom (MState _ _ _ _ ((MNode _ mstate):_))    = topMAtom mstate++processMStates :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]+processMStates (MCons state stream) = do+  newStream <- processMState state+  newStream' <- stream+  return [newStream, newStream']+ processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)] processMStatesDFS (MCons state stream) = do   stream' <- processMState state   newStream <- mappend stream' stream   return [newStream]-  -processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]-processMStatesBFS (MCons state stream) = do-  newStream <- processMState state-  newStream' <- stream-  return [newStream, newStream'] -topMAtom :: MatchingState -> MatchingTree-topMAtom (MState _ _ _ (mAtom@(MAtom _ _ _):_)) = mAtom-topMAtom (MState _ _ _ ((MNode _ mstate):_)) = topMAtom mstate--getMatcher :: MatchingTree -> Matcher-getMatcher (MAtom _ _ matcher) = matcher- processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState state = do-  if isNotPat state-    then do+processMState state =+  case topMAtom state of+    MAtom (NotPat _) _ _ -> do       let (state1, state2) = splitMState state-      result <- processMStates [msingleton state1]+      result <- processMStatesAll 0 $ MatchingStates { _normalTree = [[msingleton state1]], _orderedOrTrees = M.empty, _ids = [], _bool = False }       case result of         MNil -> return $ msingleton state2-        _ -> return MNil-    else processMState' state+        _    -> return MNil+    _ -> processMState' state  where-  isNotPat :: MatchingState -> Bool-  isNotPat state = case topMAtom state of-                     MAtom (NotPat _) _ _ -> True-                     _ -> False   splitMState :: MatchingState -> (MatchingState, MatchingState)-  splitMState (MState env loops bindings ((MAtom (NotPat pattern) target matcher) : trees)) =-    (MState env loops bindings [MAtom pattern target matcher], MState env loops bindings trees)-  splitMState (MState env loops bindings ((MNode penv state') : trees)) =+  splitMState (MState mode env loops bindings ((MAtom (NotPat pattern) target matcher) : trees)) =+    (MState mode env loops bindings [MAtom pattern target matcher], MState mode env loops bindings trees)+  splitMState (MState mode env loops bindings ((MNode penv state') : trees)) =     let (state1, state2) = splitMState state'-    in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees))+     in (MState mode env loops bindings [MNode penv state1], MState mode env loops bindings (MNode penv state2 : trees))  processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState' (MState _ _ _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)"+processMState' (MState _ _ _ _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)" -processMState' (MState _ _ _ ((MNode _ (MState _ _ _ [])):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)"+processMState' (MState _ _ _ _ ((MNode _ (MState _ _ _ _ [])):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)" -processMState' (MState env loops bindings (MNode penv (MState env' loops' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = do+processMState' (MState mode env loops bindings (MNode penv (MState mode' env' loops' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) =   case lookup name penv of     Just pattern ->       case trees' of-        [] -> return $ msingleton $ MState env loops bindings ((MAtom pattern target matcher):trees)-        _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target matcher):(MNode penv (MState env' loops' bindings' trees')):trees)+        [] -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target matcher):trees)+        _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target matcher):(MNode penv (MState mode' env' loops' bindings' trees')):trees)     Nothing -> throwError $ UnboundVariable name -processMState' (MState env loops bindings (MNode penv (MState env' loops' bindings' ((MAtom (IndexedPat (VarPat name) indices) target matcher):trees')):trees)) = do+processMState' (MState mode env loops bindings (MNode penv (MState mode' env' loops' bindings' ((MAtom (IndexedPat (VarPat name) indices) target matcher):trees')):trees)) =   case lookup name penv of     Just pattern -> do       let env'' = extendEnvForNonLinearPatterns env' bindings loops'       indices' <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices       let pattern' = IndexedPat pattern $ map (\i -> IntegerExpr i) indices'       case trees' of-        [] -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):trees)-        _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):(MNode penv (MState env' loops' bindings' trees')):trees)+        [] -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern' target matcher):trees)+        _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern' target matcher):(MNode penv (MState mode' env' loops' bindings' trees')):trees)     Nothing -> throwError $ UnboundVariable name -processMState' (MState env loops bindings ((MNode penv state):trees)) = do+processMState' (MState mode env loops bindings ((MNode penv state):trees)) =   processMState' state >>= mmap (\state' -> case state' of-                                              MState _ _ _ [] -> return $ MState env loops bindings trees-                                              _ -> (return . MState env loops bindings . (: trees) . MNode penv) state')+                                              MState _ _ _ _ [] -> return $ MState mode env loops bindings trees+                                              _ -> (return . MState mode env loops bindings . (: trees) . MNode penv) state') -processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)) = do-  let env' = extendEnvForNonLinearPatterns env bindings loops+processMState' (MState mode env loops bindings ((MAtom pattern target matcher):trees)) =+  let env' = extendEnvForNonLinearPatterns env bindings loops in   case pattern of     NotPat _ -> throwError $ EgisonBug "should not reach here (not pattern)"     VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern@@ -1159,12 +1220,12 @@             makeBindings names <$> (evalExpr env' expr >>= fromTuple)       in        liftM concat (mapM extractBindings bindings')-         >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern' target matcher):trees))+         >>= (\b -> return $ msingleton $ MState mode env loops (b ++ bindings) ((MAtom pattern' target matcher):trees))     PredPat predicate -> do       func <- evalExpr env' predicate       let arg = target       result <- applyFunc env func arg >>= fromWHNF-      if result then return $ msingleton $ (MState env loops bindings trees)+      if result then return $ msingleton $ (MState mode env loops bindings trees)                 else return MNil      PApplyPat func args -> do@@ -1172,25 +1233,25 @@       case func' of         Value (PatternFunc env'' names expr) ->           let penv = zip names args-          in return $ msingleton $ MState env loops bindings (MNode penv (MState env'' [] [] [MAtom expr target matcher]) : trees)+          in return $ msingleton $ MState mode env loops bindings (MNode penv (MState mode env'' [] [] [MAtom expr target matcher]) : trees)         _ -> throwError $ TypeMismatch "pattern constructor" func'      DApplyPat func args -> do-      return $ msingleton $ (MState env loops bindings ((MAtom (InductivePat "apply" [func, (toListPat args)]) target matcher):trees))+      return $ msingleton $ (MState mode env loops bindings ((MAtom (InductivePat "apply" [func, (toListPat args)]) target matcher):trees))      LoopPat name (LoopRange start ends endPat) pat pat' -> do       startNum <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer)       startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1)       ends' <- evalExpr env' ends       if isPrimitiveValue ends'-        then do +        then do           endsRef <- newEvaluatedObjectRef ends'           inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef]           endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners)))-          return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)+          return $ msingleton $ MState mode env ((LoopPatContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)         else do           endsRef <- newEvaluatedObjectRef ends'-          return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)+          return $ msingleton $ MState mode env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)     ContPat ->       case loops of         [] -> throwError $ Default "cannot use cont pattern except in loop pattern"@@ -1210,15 +1271,15 @@                 then return MNil                 else if startNum == carEndsNum                        then if b2-                              then return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees)]-                              else return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees), MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]-                       else return $ fromList [MState env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]+                              then return $ fromList [MState mode env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees)]+                              else return $ fromList [MState mode env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees), MState mode env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]+                       else return $ fromList [MState mode env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]     AndPat patterns ->       let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees-      in return $ msingleton $ MState env loops bindings trees'+      in return $ msingleton $ MState mode env loops bindings trees'     OrPat patterns ->       return $ fromList $ flip map patterns $ \pat ->-        MState env loops bindings (MAtom pat target matcher : trees)+        MState mode env loops bindings (MAtom pat target matcher : trees)      _ ->       case matcher of@@ -1227,20 +1288,20 @@           mfor targetss $ \ref -> do             targets <- evalRef ref >>= fromTupleWHNF             let trees' = zipWith3 MAtom patterns targets matchers ++ trees-            return $ MState env loops bindings trees'-            -        Tuple matchers -> do+            return $ MState mode env loops bindings trees'++        Tuple matchers ->           case pattern of-            ValuePat _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)-            WildCard -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)-            PatVar _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)-            IndexedPat _ _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)+            ValuePat _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees)+            WildCard -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees)+            PatVar _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees)+            IndexedPat _ _ -> return $ msingleton $ MState mode env loops bindings ((MAtom pattern target Something):trees)             TuplePat patterns -> do               targets <- fromTupleWHNF target               if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()               if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return ()               let trees' = zipWith3 MAtom patterns targets matchers ++ trees-              return $ msingleton $ MState env loops bindings trees'+              return $ msingleton $ MState mode env loops bindings trees'             _ ->  throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern          Something ->@@ -1249,21 +1310,21 @@               val <- evalExprDeep env' valExpr               tgtVal <- evalWHNF target               if val == tgtVal-                then return $ msingleton $ MState env loops bindings trees+                then return $ msingleton $ MState mode env loops bindings trees                 else return MNil-            WildCard -> return $ msingleton $ MState env loops bindings trees+            WildCard -> return $ msingleton $ MState mode env loops bindings trees             PatVar name -> do               targetRef <- newEvaluatedObjectRef target-              return $ msingleton $ MState env loops ((name, targetRef):bindings) trees+              return $ msingleton $ MState mode env loops ((name, targetRef):bindings) trees             IndexedPat (PatVar name) indices -> do               indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices               case lookup name bindings of                 Just ref -> do                   obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef-                  return $ msingleton $ MState env loops (subst name obj bindings) trees+                  return $ msingleton $ MState mode env loops (subst name obj bindings) trees                 Nothing  -> do                   obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef-                  return $ msingleton $ MState env loops ((name,obj):bindings) trees+                  return $ msingleton $ MState mode env loops ((name,obj):bindings) trees                where                 updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData                 updateHash [index] (Intermediate (IIntHash hash)) = do@@ -1282,18 +1343,18 @@                 subst k nv ((k', v'):xs) | k == k'   = (k', nv):(subst k nv xs)                                          | otherwise = (k', v'):(subst k nv xs)                 subst _ _ [] = []-            IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern) +            IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern)             TuplePat patterns -> do               targets <- fromTupleWHNF target               if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()               let trees' = zipWith3 MAtom patterns targets (take (length patterns) (repeat Something)) ++ trees-              return $ msingleton $ MState env loops bindings trees'-            _ -> throwError $ Default "something can only match with a pattern variable"+              return $ msingleton $ MState mode env loops bindings trees'+            _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ show pattern         _ ->  throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern  inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher ->                   EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher])-inductiveMatch env pattern target (UserMatcher matcherEnv _ clauses) = do+inductiveMatch env pattern target (UserMatcher matcherEnv clauses _) =   foldr tryPPMatchClause failPPPatternMatch clauses  where   tryPPMatchClause (pat, matchers, clauses) cont = do@@ -1333,7 +1394,7 @@ primitiveDataPatternMatch (PDPatVar name) whnf = do   ref <- lift $ newEvaluatedObjectRef whnf   return [(stringToVar name, ref)]-primitiveDataPatternMatch (PDInductivePat name patterns) whnf = do+primitiveDataPatternMatch (PDInductivePat name patterns) whnf =   case whnf of     Intermediate (IInductiveData name' refs) | name == name' -> do       whnfs <- lift $ mapM evalRef refs@@ -1342,7 +1403,7 @@       let whnfs = map Value vals       concat <$> zipWithM primitiveDataPatternMatch patterns whnfs     _ -> matchFail-primitiveDataPatternMatch (PDTuplePat patterns) whnf = do+primitiveDataPatternMatch (PDTuplePat patterns) whnf =   case whnf of     Intermediate (ITuple refs) -> do       whnfs <- lift $ mapM evalRef refs@@ -1447,7 +1508,7 @@ -- Util -- toListPat :: [EgisonPattern] -> EgisonPattern-toListPat [] = InductivePat "nil" []+toListPat []         = InductivePat "nil" [] toListPat (pat:pats) = InductivePat "cons" [pat, (toListPat pats)]  fromTuple :: WHNFData -> EgisonM [ObjectRef]@@ -1457,12 +1518,12 @@  fromTupleWHNF :: WHNFData -> EgisonM [WHNFData] fromTupleWHNF (Intermediate (ITuple refs)) = mapM evalRef refs-fromTupleWHNF (Value (Tuple vals)) = return $ map Value vals-fromTupleWHNF whnf = return [whnf]+fromTupleWHNF (Value (Tuple vals))         = return $ map Value vals+fromTupleWHNF whnf                         = return [whnf]  fromTupleValue :: EgisonValue -> [EgisonValue] fromTupleValue (Tuple vals) = vals-fromTupleValue val = [val]+fromTupleValue val          = [val]  fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef) fromCollection (Value (Collection vals)) =@@ -1484,7 +1545,7 @@   return $ tupleToList' val  where   tupleToList' (Tuple vals) = vals-  tupleToList' val = [val]+  tupleToList' val          = [val]  collectionToList :: WHNFData -> EgisonM [EgisonValue] collectionToList whnf = do@@ -1496,9 +1557,9 @@   collectionToList' val = throwError $ TypeMismatch "collection" (Value val)  makeTuple :: [EgisonValue] -> EgisonValue-makeTuple [] = Tuple []+makeTuple []  = Tuple [] makeTuple [x] = x-makeTuple xs = Tuple xs+makeTuple xs  = Tuple xs  makeITuple :: [WHNFData] -> EgisonM WHNFData makeITuple [] = return $ Intermediate (ITuple [])@@ -1535,8 +1596,10 @@ extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf  isPrimitiveValue :: WHNFData -> Bool-isPrimitiveValue (Value (Char _)) = True-isPrimitiveValue (Value (Bool _)) = True+isPrimitiveValue (Value (Char _))       = True+isPrimitiveValue (Value (Bool _))       = True isPrimitiveValue (Value (ScalarData _)) = True-isPrimitiveValue (Value (Float _ _)) = True-isPrimitiveValue _ = False+isPrimitiveValue (Value (Float _ _))    = True+isPrimitiveValue _                      = False++makeLenses ''MatchingStates

@@ -26,6 +26,7 @@ import Data.Set (Set) import Data.Char (toUpper) import Control.Monad.Except+import Control.Monad.Fail import Control.Monad.Reader import Language.Egison.Types @@ -34,6 +35,9 @@ newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ExceptT EgisonError Fresh) a }   deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst) +instance MonadFail DesugarM where+    fail = throwError . EgisonBug+ runDesugarM :: DesugarM a -> Fresh (Either EgisonError a) runDesugarM = runExceptT . flip runReaderT [] . unDesugarM @@ -68,65 +72,65 @@         body <- mapM genMatcherClause patterns         footer <- genSomethingClause         clauses <- return $ [main] ++ body ++ [footer]-        return $ MatcherDFSExpr clauses-        +        return $ MatcherExpr clauses+       genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMainClause patterns matcher = do         clauses <- genClauses patterns         return (PPValuePat "val", TupleExpr []-               ,[(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr $ stringToVar "val"), (VarExpr $ stringToVar "tgt")]) -                                             (TupleExpr [matcher, matcher]) +               ,[(PDPatVar "tgt", (MatchExpr (TupleExpr [(VarExpr $ stringToVar "val"), (VarExpr $ stringToVar "tgt")])+                                             (TupleExpr [matcher, matcher])                                              clauses))])         where           genClauses :: [(String, [EgisonExpr])] -> DesugarM [MatchClause]           genClauses patterns = (++) <$> mapM genClause patterns                                      <*> pure [((TuplePat [WildCard, WildCard]), matchingFailure)]-          +           genClause :: (String, [EgisonExpr]) -> DesugarM MatchClause           genClause pattern = do             (pat0, pat1) <- genMatchingPattern pattern             return (TuplePat [pat0, pat1], matchingSuccess)-        +           genMatchingPattern :: (String, [EgisonExpr]) -> DesugarM (EgisonPattern, EgisonPattern)           genMatchingPattern (name, patterns) = do             names <- mapM (const freshV) patterns-            return $ ((InductivePat name (map PatVar names))  +            return $ ((InductivePat name (map PatVar names))                      ,(InductivePat name (map (ValuePat . VarExpr) names)))-          +       genMatcherClause :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMatcherClause pattern = do         (ppat, matchers) <- genPrimitivePatPat pattern         (dpat, body)     <- genPrimitiveDataPat pattern         return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)])-        +         where           genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr])           genPrimitivePatPat (name, matchers) = do             patterns' <- mapM (const $ return PPPatVar) matchers             return (PPInductivePat name patterns', matchers)-          +           genPrimitiveDataPat :: (String, [EgisonExpr]) -> DesugarM (PrimitiveDataPattern, [EgisonExpr])           genPrimitiveDataPat (name, patterns) = do-            patterns' <- mapM (const freshV) patterns +            patterns' <- mapM (const freshV) patterns             return (PDInductivePat (capitalize name) $ map PDPatVar $ map show patterns', map VarExpr patterns')            capitalize :: String -> String           capitalize (x:xs) = toUpper x : xs-                                            -      ++       genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])-      genSomethingClause = +      genSomethingClause =         return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr $ stringToVar "tgt")])])-    +       matchingSuccess :: EgisonExpr       matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []]        matchingFailure :: EgisonExpr       matchingFailure = CollectionExpr [] -desugar (MatchAllLambdaExpr matcher clause) = do+desugar (MatchAllLambdaExpr matcher clauses) = do   name <- fresh-  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr $ stringToVar name) matcher clause)+  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr $ stringToVar name) matcher clauses)  desugar (MatchLambdaExpr matcher clauses) = do   name <- fresh@@ -141,16 +145,16 @@   | endWithThreeDots expr = case expr of                               (VarExpr name) -> let x = show name in desugar $ IndexedExpr False (VarExpr $ stringToVar $ take ((length x)-3) x) indices   | otherwise = case indices of-                 [MultiSubscript x y] -> case (x, y) of+                 [Subscript x, DotSubscript y] -> case (x, y) of                                            (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [x, y]))                                            (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do                                              k <- fresh                                              return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "map")                                                                                     (TupleExpr [(LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [(Subscript $ VarExpr $ stringToVar k)])),                                                                                                 (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [(fromIndexToExpr n1), (fromIndexToExpr n2)]))]))-                 [MultiSuperscript x y] -> case (x, y) of+                 [Superscript x, DotSupscript y] -> case (x, y) of                                              (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [x, y]))-                                             (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do    +                                             (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do                                                k <- fresh                                                return $ SuprefsExpr b expr (ApplyExpr (VarExpr $ stringToVar "map")                                                                                       (TupleExpr [(LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [(Subscript $ VarExpr $ stringToVar k)])),@@ -165,10 +169,10 @@   fromIndexToExpr (Superscript a) = a   fromIndexToExpr (SupSubscript a) = a -desugar (SubrefsExpr bool expr1 expr2) = +desugar (SubrefsExpr bool expr1 expr2) =   SubrefsExpr bool <$> desugar expr1 <*> desugar expr2 -desugar (SuprefsExpr bool expr1 expr2) = +desugar (SuprefsExpr bool expr1 expr2) =   SuprefsExpr bool <$> desugar expr1 <*> desugar expr2  desugar (PowerExpr expr1 expr2) = do@@ -180,7 +184,7 @@   expr' <- desugar expr   return $ ArrayBoundsExpr expr' -desugar (InductiveDataExpr name exprs) = do +desugar (InductiveDataExpr name exprs) = do   exprs' <- mapM desugar exprs   return $ InductiveDataExpr name exprs' @@ -265,10 +269,6 @@   expr' <- desugar expr   return $ ProcedureExpr names expr' ---desugar (MacroExpr names expr) = do---  expr' <- desugar expr---  return $ MacroExpr names expr'- desugar (PatternFunctionExpr names pattern) = do   pattern' <- desugarPattern pattern   return $ PatternFunctionExpr names pattern'@@ -278,12 +278,12 @@   expr1' <- desugar expr1   expr2' <- desugar expr2   return $ IfExpr expr0' expr1' expr2'-  + desugar (LetRecExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr   return $ LetRecExpr binds' expr'-  + desugar (LetExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr@@ -298,27 +298,27 @@   expr' <- desugar expr   return $ WithSymbolsExpr vars expr' -desugar (MatchExpr expr0 expr1 clauses) = do  +desugar (MatchExpr expr0 expr1 clauses) = do   expr0' <- desugar expr0   expr1' <- desugar expr1   clauses' <- desugarMatchClauses clauses   return (MatchExpr expr0' expr1' clauses') -desugar (MatchAllExpr expr0 expr1 clause) = do+desugar (MatchAllExpr expr0 expr1 clauses) = do   expr0' <- desugar expr0   expr1' <- desugar expr1-  clause' <- desugarMatchClause clause-  return $ MatchAllExpr expr0' expr1' clause'-  +  clauses' <- desugarMatchClauses clauses+  return $ MatchAllExpr expr0' expr1' clauses'+ desugar (DoExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr   return $ DoExpr binds' expr'-  + desugar (IoExpr expr) = do   expr' <- desugar expr   return $ IoExpr expr'-  + desugar (SeqExpr expr0 expr1) = do   expr0' <- desugar expr0   expr1' <- desugar expr1@@ -392,14 +392,14 @@   id <- fresh   return (VarExpr $ stringToVar (":::" ++ id)) -desugar (MatcherBFSExpr matcherInfo) = do+desugar (MatcherExpr matcherInfo) = do   matcherInfo' <- desugarMatcherInfo matcherInfo-  return $ MatcherBFSExpr matcherInfo'-  +  return $ MatcherExpr matcherInfo'+ desugar (MatcherDFSExpr matcherInfo) = do   matcherInfo' <- desugarMatcherInfo matcherInfo   return $ MatcherDFSExpr matcherInfo'-  + desugar (PartialVarExpr n) = return $ PartialVarExpr n  desugar (PartialExpr n expr) = do@@ -428,7 +428,7 @@ desugarIndex (Userscript expr) = desugar expr >>= return . Userscript  desugarPattern :: EgisonPattern -> DesugarM EgisonPattern-desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern +desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern  where    collectNames :: [EgisonPattern] -> Set String    collectNames patterns = S.unions $ map collectName patterns@@ -448,8 +448,10 @@    collectName (PlusPat patterns) = collectNames patterns    collectName (MultPat patterns) = collectNames patterns    collectName (PowerPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2+   collectName (DFSPat _ pattern) = collectName pattern+   collectName (BFSPat pattern) = collectName pattern    collectName _ = S.empty-   +    makeBinding :: String -> BindingExpr    makeBinding name = ([stringToVar name], HashExpr []) @@ -459,16 +461,13 @@ desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (OrPat patterns)  =  OrPat <$> mapM desugarPattern' patterns-desugarPattern' (OrderedOrPat [])  = return (NotPat WildCard)-desugarPattern' (OrderedOrPat (pattern:patterns)) = do-  pattern' <- desugarPattern' pattern-  pattern'' <- desugarPattern' (OrderedOrPat patterns)-  return $ OrPat [pattern', AndPat [(NotPat pattern'), pattern'']]+desugarPattern' (OrderedOrPat' [pat1, pat2])  = OrderedOrPat <$> fresh <*> desugarPattern' pat1 <*> desugarPattern' pat2+desugarPattern' (OrderedOrPat' (pat : patterns)) = OrderedOrPat <$> fresh <*> desugarPattern' pat <*> desugarPattern' (OrderedOrPat' patterns) desugarPattern' (TuplePat patterns)  = TuplePat <$> mapM desugarPattern' patterns desugarPattern' (InductivePat name patterns) = InductivePat name <$> mapM desugarPattern' patterns desugarPattern' (IndexedPat pattern exprs) = IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs-desugarPattern' (PApplyPat expr patterns) = PApplyPat <$> desugar expr <*> mapM desugarPattern' patterns -desugarPattern' (DApplyPat pattern patterns) = DApplyPat <$> desugarPattern' pattern <*> mapM desugarPattern' patterns +desugarPattern' (PApplyPat expr patterns) = PApplyPat <$> desugar expr <*> mapM desugarPattern' patterns+desugarPattern' (DApplyPat pattern patterns) = DApplyPat <$> desugarPattern' pattern <*> mapM desugarPattern' patterns desugarPattern' (LoopPat name range pattern1 pattern2) =  LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = LetPat <$> desugarBindings binds <*> desugarPattern' pattern desugarPattern' (DivPat pattern1 pattern2) = do@@ -476,14 +475,17 @@   pat2' <- desugarPattern' pattern2   return $ InductivePat "div" [pat1', pat2'] desugarPattern' (PlusPat patterns) = do-  pats' <- mapM desugarPattern' patterns+  pats' <- mapM desugarPattern' (concatMap f patterns)   case (reverse pats') of     [] -> return $ InductivePat "plus" [ValuePat (IntegerExpr 0)]     lp:hps ->       return $ InductivePat "plus" [foldr (\p r -> InductivePat "cons" [p, r]) lp (reverse hps)]+ where+   f (PlusPat xs) = concatMap f xs+   f pat = [pat] desugarPattern' (MultPat (intPat:patterns)) = do   intPat' <- desugarPattern' intPat-  pats' <- mapM desugarPattern' patterns+  pats' <- mapM desugarPattern' (concatMap f patterns)   case (reverse pats') of     [] -> return $ InductivePat "mult" [intPat', ValuePat (IntegerExpr 1)]     lp:hps ->@@ -495,9 +497,29 @@                                              (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)]                                              _ -> lp)                                           (reverse hps)]+ where+   f (MultPat xs) = concatMap f xs+   f pat = [pat] desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2+desugarPattern' (DFSPat' pattern) = desugarPattern' pattern >>= dfs+desugarPattern' (BFSPat pattern) = BFSPat <$> desugarPattern' pattern desugarPattern' pattern = return pattern +dfs :: EgisonPattern -> DesugarM EgisonPattern+dfs (NotPat pattern) = NotPat <$> dfs pattern+dfs (AndPat patterns) = DFSPat <$> fresh <*> (AndPat <$> mapM dfs patterns)+dfs (OrPat patterns)  = DFSPat <$> fresh <*> (OrPat <$> mapM dfs patterns)+dfs (OrderedOrPat id pat1 pat2)  = OrderedOrPat id <$> dfs pat1 <*> dfs pat2+dfs (TuplePat patterns)  = DFSPat <$> fresh <*> (TuplePat <$> mapM dfs patterns)+dfs (InductivePat name patterns) = DFSPat <$> fresh <*> (InductivePat name <$> mapM dfs patterns)+dfs (IndexedPat pattern exprs) = DFSPat <$> fresh <*> (flip IndexedPat exprs <$> dfs pattern)+dfs (PApplyPat expr patterns) = DFSPat <$> fresh <*> (PApplyPat expr <$> mapM dfs patterns)+dfs (DApplyPat pattern patterns) = DFSPat <$> fresh <*> (DApplyPat <$> dfs pattern <*> mapM dfs patterns)+dfs (LoopPat name range pattern1 pattern2) = DFSPat <$> fresh <*> (LoopPat name range <$> dfs pattern1 <*> dfs pattern2)+dfs (LetPat binds pattern) = DFSPat <$> fresh <*> (LetPat binds <$> dfs pattern)+dfs (PowerPat pattern1 pattern2) = DFSPat <$> fresh <*> (PowerPat <$> dfs pattern1 <*> dfs pattern2)+dfs pattern = return pattern+ desugarLoopRange :: LoopRange -> DesugarM LoopRange desugarLoopRange (LoopRange sExpr eExpr pattern) = do   sExpr' <- desugar sExpr@@ -515,7 +537,7 @@   bind' <- desugarBinding bind   rest' <- desugarBindings rest   return $ bind' : rest'-  + desugarBindings [] = return []  desugarMatchClause :: MatchClause -> DesugarM MatchClause

@@ -6,7 +6,7 @@ This module provides utility functions. -} -module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex) where+module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex, mathExprToMathematica) where  import Control.Monad import System.Environment@@ -15,18 +15,23 @@ mathExprToHaskell :: String -> String mathExprToHaskell input = case parse parseExpr "math-expr" input of                             Left err -> input-                            Right val -> "#haskell\"" ++ show val ++ "\""+                            Right val -> "#haskell|" ++ show val ++ "|#"  mathExprToAsciiMath :: String -> String mathExprToAsciiMath input = case parse parseExpr "math-expr" input of                               Left err -> input-                              Right val -> "#asciimath\"" ++ showMathExprAsciiMath val ++ "\""+                              Right val -> "#asciimath|" ++ showMathExprAsciiMath val ++ "|#"  mathExprToLatex :: String -> String mathExprToLatex input = case parse parseExpr "math-expr" input of                           Left err -> input                           Right val -> "#latex|" ++ showMathExprLatex val ++ "|#" +mathExprToMathematica :: String -> String+mathExprToMathematica input = case parse parseExpr "math-expr" input of+                          Left err -> input+                          Right val -> "#mathematica|" ++ showMathExprMathematica val ++ "|#"+ data MathExpr = Atom String [MathIndex]               | NegativeAtom String               | Plus [MathExpr]@@ -49,10 +54,6 @@ -- Show (AsciiMath) -- -showMathIndexAsciiMath :: MathIndex -> String-showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a-showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a- showMathExprAsciiMath :: MathExpr -> String showMathExprAsciiMath (Atom func []) = func showMathExprAsciiMath (NegativeAtom func) = "-" ++ func@@ -62,8 +63,9 @@   showMathExprAsciiMathForPlus :: [MathExpr] -> String   showMathExprAsciiMathForPlus [] = ""   showMathExprAsciiMathForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprAsciiMathForPlus xs+  showMathExprAsciiMathForPlus ((Multiply (NegativeAtom "1":ys)):xs) = " - " ++ showMathExprAsciiMath (Multiply ys) ++ showMathExprAsciiMathForPlus xs   showMathExprAsciiMathForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprAsciiMath (Multiply ((Atom a []):ys)) ++ " " ++ showMathExprAsciiMathForPlus xs-  showMathExprAsciiMathForPlus (x:xs) = showMathExprAsciiMath x ++ " + " ++ showMathExprAsciiMathForPlus xs+  showMathExprAsciiMathForPlus (x:xs) = " + " ++ showMathExprAsciiMath x ++ showMathExprAsciiMathForPlus xs showMathExprAsciiMath (Multiply []) = "" showMathExprAsciiMath (Multiply [a]) = showMathExprAsciiMath a showMathExprAsciiMath (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExprAsciiMath (Multiply lvs)@@ -100,6 +102,10 @@ showMathExprAsciiMathIndices [a] = showMathIndexAsciiMath a showMathExprAsciiMathIndices lvs = showMathIndexAsciiMath (head lvs) ++ showMathExprAsciiMathIndices (tail lvs) +showMathIndexAsciiMath :: MathIndex -> String+showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a+showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a+ -- -- Show (Latex) --@@ -125,6 +131,7 @@   showMathExprLatexForPlus :: [MathExpr] -> String   showMathExprLatexForPlus [] = ""   showMathExprLatexForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprLatexForPlus xs+  showMathExprLatexForPlus ((Multiply (NegativeAtom "1":ys)):xs) = " - " ++ showMathExprLatex (Multiply ys) ++ showMathExprLatexForPlus xs   showMathExprLatexForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprLatex (Multiply ((Atom a []):ys)) ++ showMathExprLatexForPlus xs   showMathExprLatexForPlus (x:xs) = " + " ++  showMathExprLatex x ++ showMathExprLatexForPlus xs showMathExprLatex (Multiply []) = ""@@ -174,6 +181,62 @@ showMathExprLatexVectors lvs = showMathExprLatexArg lvs " \\\\ " ++ "\\\\ "  --+-- Show (Mathematica)+--++showMathExprMathematica :: MathExpr -> String+showMathExprMathematica (Atom a []) = a+--showMathExprMathematica (Atom a xs) = a ++ showMathExprMathematicaScript xs+showMathExprMathematica (Partial f xs) = undefined+showMathExprMathematica (NegativeAtom a) = "-" ++ a+showMathExprMathematica (Plus []) = ""+showMathExprMathematica (Plus (x:xs)) = showMathExprMathematica x ++ showMathExprMathematicaForPlus xs+ where+  showMathExprMathematicaForPlus :: [MathExpr] -> String+  showMathExprMathematicaForPlus [] = ""+  showMathExprMathematicaForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprMathematicaForPlus xs+  showMathExprMathematicaForPlus ((Multiply (NegativeAtom "1":ys)):xs) = " - " ++ showMathExprMathematica (Multiply ys) ++ showMathExprMathematicaForPlus xs+  showMathExprMathematicaForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprMathematica (Multiply ((Atom a []):ys)) ++ showMathExprMathematicaForPlus xs+  showMathExprMathematicaForPlus (x:xs) = " + " ++  showMathExprMathematica x ++ showMathExprMathematicaForPlus xs+showMathExprMathematica (Multiply []) = ""+showMathExprMathematica (Multiply [x]) = showMathExprMathematica x+showMathExprMathematica (Multiply (Atom "1" []:xs)) = showMathExprMathematica (Multiply xs)+showMathExprMathematica (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprMathematica (Multiply xs)+showMathExprMathematica (Multiply (x:xs)) = showMathExprMathematica' x ++ " " ++ showMathExprMathematica (Multiply xs)+showMathExprMathematica (Power lv1 lv2) = showMathExprMathematica lv1 ++ "^" ++ showMathExprMathematica lv2+showMathExprMathematica (Func (Atom "sqrt" []) [x]) = "Sqrt[" ++ showMathExprMathematica x ++ "]"+showMathExprMathematica (Func (Atom "rt" []) [x, y]) = "Surd[" ++ showMathExprMathematica x ++ "," ++ showMathExprMathematica y ++ "]"+showMathExprMathematica (Func (Atom "/" []) [x, y]) = "(" ++ showMathExprMathematica x ++ ")/(" ++ showMathExprMathematica y ++ ")"+showMathExprMathematica (Func f xs) = showMathExprMathematica f ++ "(" ++ showMathExprMathematicaArg xs ++ ")"+showMathExprMathematica (Tensor lvs mis)+  | null mis = "{" ++ showMathExprMathematicaArg lvs ++ "}"+  | not (any isSub mis) = "{" ++ showMathExprMathematicaArg lvs ++ "}^(" ++ showMathExprMathematicaIndices mis ++ ")"+  | not (any (not . isSub) mis) = "{" ++ showMathExprMathematicaArg lvs ++ "}_(" ++ showMathExprMathematicaIndices mis ++ ")"+  | otherwise = "{" ++ showMathExprMathematicaArg lvs ++ "}_(" ++ showMathExprMathematicaIndices (filter isSub mis) ++ ")^(" ++ showMathExprMathematicaIndices (filter (not . isSub) mis) ++ ")"+showMathExprMathematica (Tuple xs) = "(" ++ showMathExprMathematicaArg xs ++ ")"+showMathExprMathematica (Collection xs) = "{" ++ showMathExprMathematicaArg xs ++ "}"+showMathExprMathematica (Exp x) = "e^(" ++ showMathExprMathematica x ++ ")"+showMathExprMathematica (Quote x) = "(" ++ showMathExprMathematica x ++ ")"++showMathExprMathematica' :: MathExpr -> String+showMathExprMathematica' (Plus xs) = "(" ++ showMathExprMathematica (Plus xs) ++ ")"+showMathExprMathematica' x = showMathExprMathematica x++showMathExprMathematicaArg :: [MathExpr] -> String+showMathExprMathematicaArg [] = ""+showMathExprMathematicaArg [a] = showMathExprMathematica a+showMathExprMathematicaArg lvs = showMathExprMathematica (head lvs) ++ ", " ++ (showMathExprMathematicaArg (tail lvs))++showMathExprMathematicaIndices :: [MathIndex] -> String+showMathExprMathematicaIndices [a] = showMathIndexMathematica a+showMathExprMathematicaIndices lvs = showMathIndexMathematica (head lvs) ++ showMathExprMathematicaIndices (tail lvs)++showMathIndexMathematica :: MathIndex -> String+showMathIndexMathematica (Super a) = showMathExprMathematica a+showMathIndexMathematica (Sub a) = showMathExprMathematica a+++-- -- Parser -- @@ -187,7 +250,7 @@ symbol = oneOf "!$%&*+-/:<=>?@#"  parseAtom :: Parser MathExpr-parseAtom = do +parseAtom = do     first <- letter <|> symbol <|> digit     rest <- many (letter <|> digit <|> symbol)     let atom = first : rest@@ -195,7 +258,7 @@     return $ Atom atom ys  parseAtom' :: Parser MathExpr-parseAtom' = do +parseAtom' = do     first <- letter <|> symbol <|> digit     rest <- many (letter <|> digit <|> symbol)     let atom = first : rest@@ -206,7 +269,7 @@     xs <- parseAtom     is <- many1 (char '|' >> parseAtom)     return $ Partial xs is-  + parseNegativeAtom :: Parser MathExpr parseNegativeAtom = do     char '-'

@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections, FlexibleContexts #-}  {- | Module      : Language.Egison.Parser@@ -8,7 +8,7 @@ This module provide Egison parser. -} -module Language.Egison.Parser +module Language.Egison.Parser        (        -- * Parse a string          readTopExprs@@ -105,8 +105,8 @@   exprs <- readTopExprs $ shebang input   concat <$> mapM  recursiveLoad exprs  where-  recursiveLoad (Load file) = loadLibraryFile file-  recursiveLoad (LoadFile file) = loadFile file+  recursiveLoad (Load _ file) = loadLibraryFile file+  recursiveLoad (LoadFile _ file) = loadFile file   recursiveLoad expr = return [expr]   shebang :: String -> String   shebang ('#':'!':cs) = ';':'#':'!':cs@@ -162,10 +162,10 @@ executeExpr = keywordExecute >> Execute <$> expr  loadFileExpr :: Parser EgisonTopExpr-loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral+loadFileExpr = keywordLoadFile >> LoadFile True <$> stringLiteral  loadExpr :: Parser EgisonTopExpr-loadExpr = keywordLoad >> Load <$> stringLiteral+loadExpr = keywordLoad >> Load True <$> stringLiteral  exprs :: Parser [EgisonExpr] exprs = endBy expr whiteSpace@@ -177,7 +177,7 @@                           option expr1 $ PowerExpr expr1 <$> (try $ char '^' >> expr'))                             where parseindex :: Parser [Index EgisonExpr]                                   parseindex = many1 (try (do-                                                           char '_' +                                                           char '_'                                                            e1 <- expr'                                                            string "..._"                                                            e2 <- expr'@@ -235,7 +235,6 @@                          <|> nextMatchAllLambdaExpr                          <|> nextMatchLambdaExpr                          <|> matcherExpr-                         <|> matcherBFSExpr                          <|> matcherDFSExpr                          <|> seqExpr                          <|> applyExpr@@ -319,13 +318,13 @@ quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr  matchAllExpr :: Parser EgisonExpr-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> matchClause+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses)  matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses  matchAllLambdaExpr :: Parser EgisonExpr-matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> matchClause+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses)  matchLambdaExpr :: Parser EgisonExpr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses@@ -349,10 +348,7 @@ matchClause = brackets $ (,) <$> pattern <*> expr  matcherExpr :: Parser EgisonExpr-matcherExpr = keywordMatcher >> MatcherBFSExpr <$> ppMatchClauses--matcherBFSExpr :: Parser EgisonExpr-matcherBFSExpr = keywordMatcherBFS >> MatcherBFSExpr <$> ppMatchClauses+matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses  matcherDFSExpr :: Parser EgisonExpr matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses@@ -375,7 +371,7 @@                         <|> ppValuePat                         <|> ppInductivePat                         <?> "primitive-pattren-pattern")-                       + ppWildCard :: Parser PrimitivePatPattern ppWildCard = reservedOp "_" *> pure PPWildCard @@ -395,7 +391,7 @@ pdPattern' = reservedOp "_" *> pure PDWildCard                     <|> (char '$' >> PDPatVar <$> ident)                     <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern))-                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern) +                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern)                             <|> pure PDEmptyPat)                     <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace)                     <|> brackets (PDTuplePat <$> sepEndBy pdPattern whiteSpace)@@ -463,7 +459,7 @@  varNames :: Parser [String] varNames = return <$> (char '$' >> ident)-            <|> brackets (sepEndBy (char '$' >> ident) whiteSpace) +            <|> brackets (sepEndBy (char '$' >> ident) whiteSpace)  varNames' :: Parser [Var] varNames' = return <$> (char '$' >> identVar)@@ -471,7 +467,7 @@  argNames :: Parser [Arg] argNames = return <$> argName-            <|> brackets (sepEndBy argName whiteSpace) +            <|> brackets (sepEndBy argName whiteSpace)  argName :: Parser Arg argName = try (char '$' >> ident >>= return . ScalarArg)@@ -485,10 +481,10 @@ seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr  cApplyExpr :: Parser EgisonExpr-cApplyExpr = (keywordCApply >> CApplyExpr <$> expr <*> expr) +cApplyExpr = (keywordCApply >> CApplyExpr <$> expr <*> expr)  applyExpr :: Parser EgisonExpr-applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr) +applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr)              <|> applyExpr'  applyExpr' :: Parser EgisonExpr@@ -610,10 +606,13 @@             <|> tuplePat             <|> inductivePat             <|> parens (andPat+                    <|> notPat'                     <|> orderedOrPat                     <|> orPat                     <|> loopPat                     <|> letPat+                    <|> bfsPat+                    <|> dfsPat                     <|> try divPat                     <|> try plusPat                     <|> try multPat@@ -648,6 +647,9 @@ notPat :: Parser EgisonPattern notPat = char '!' >> NotPat <$> pattern +notPat' :: Parser EgisonPattern+notPat' = keywordNot >> NotPat <$> pattern+ tuplePat :: Parser EgisonPattern tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace @@ -658,19 +660,19 @@ contPat = keywordCont >> pure ContPat  andPat :: Parser EgisonPattern-andPat = reservedOp "&" >> AndPat <$> sepEndBy pattern whiteSpace+andPat = (reservedOp "&" <|> keywordAnd) >> AndPat <$> sepEndBy pattern whiteSpace  orPat :: Parser EgisonPattern-orPat = reservedOp "|" >> OrPat <$> sepEndBy pattern whiteSpace+orPat = (reservedOp "|" <|> keywordOr) >> OrPat <$> sepEndBy pattern whiteSpace  orderedOrPat :: Parser EgisonPattern-orderedOrPat = reservedOp "|*" >> OrderedOrPat <$> sepEndBy pattern whiteSpace+orderedOrPat = reservedOp "|*" >> OrderedOrPat' <$> sepEndBy pattern whiteSpace  pApplyPat :: Parser EgisonPattern-pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace +pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace  dApplyPat :: Parser EgisonPattern-dApplyPat = DApplyPat <$> pattern'' <*> sepEndBy pattern whiteSpace +dApplyPat = DApplyPat <$> pattern'' <*> sepEndBy pattern whiteSpace  loopPat :: Parser EgisonPattern loopPat = keywordLoop >> char '$' >> LoopPat <$> identVarWithoutIndex <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern@@ -700,6 +702,12 @@                    return $ PowerPat pat1 pat2)        <|> pattern +dfsPat :: Parser EgisonPattern+dfsPat = keywordDFS >> DFSPat' <$> pattern++bfsPat :: Parser EgisonPattern+bfsPat = keywordBFS >> BFSPat <$> pattern+ -- Constants  constantExpr :: Parser EgisonExpr@@ -762,7 +770,7 @@ --  egisonDef :: P.GenLanguageDef String () Identity-egisonDef = +egisonDef =   P.LanguageDef { P.commentStart       = "#|"                 , P.commentEnd         = "|#"                 , P.commentLine        = ";"@@ -777,13 +785,13 @@  symbol0 = oneOf "^" symbol1 = oneOf "+-*/.=∂∇"-symbol2 = symbol1 <|> oneOf "'!?"+symbol2 = symbol1 <|> oneOf "'!?₀₁₂₃₄₅₆₇₈₉"  lexer :: P.GenTokenParser String () Identity lexer = P.makeTokenParser egisonDef  reservedKeywords :: [String]-reservedKeywords = +reservedKeywords =   [ "define"   , "redefine"   , "set!"@@ -812,8 +820,6 @@   , "match-all-lambda"   , "match-lambda"   , "matcher"-  , "matcher-bfs"-  , "matcher-dfs"   , "do"   , "io"   , "algebraic-data-matcher"@@ -839,9 +845,9 @@   , "symbolic-tensor"   , "something"   , "undefined"]-  + reservedOperators :: [String]-reservedOperators = +reservedOperators =   [ "$"   , ",$"   , "_"@@ -871,6 +877,9 @@ keywordIf                   = reserved "if" keywordThen                 = reserved "then" keywordElse                 = reserved "else"+keywordNot                  = reserved "not"+keywordAnd                  = reserved "and"+keywordOr                   = reserved "or" keywordSeq                  = reserved "seq" keywordApply                = reserved "apply" keywordCApply               = reserved "capply"@@ -896,7 +905,6 @@ keywordNextMatch            = reserved "next-match" keywordNextMatchLambda      = reserved "next-match-lambda" keywordMatcher              = reserved "matcher"-keywordMatcherBFS           = reserved "matcher-bfs" keywordMatcherDFS           = reserved "matcher-dfs" keywordDo                   = reserved "do" keywordIo                   = reserved "io"@@ -923,6 +931,8 @@ keywordUserrefsNew          = reserved "user-refs!" keywordFunction             = reserved "function" keywordSymbolicTensor       = reserved "symbolic-tensor"+keywordDFS                  = reserved "dfs"+keywordBFS                  = reserved "bfs"  sign :: Num a => Parser (a -> a) sign = (char '-' >> return negate)@@ -1011,7 +1021,7 @@ upperName' :: Parser String upperName' = (:) <$> upper <*> option "" ident  where-  upper :: Parser Char +  upper :: Parser Char   upper = satisfy isUpper  lowerName :: Parser String@@ -1020,5 +1030,5 @@ lowerName' :: Parser String lowerName' = (:) <$> lower <*> option "" ident  where-  lower :: Parser Char +  lower :: Parser Char   lower = satisfy isLower

@@ -0,0 +1,986 @@+{-# LANGUAGE TupleSections, FlexibleContexts #-}++{- |+Module      : Language.Egison.ParserNonS+Copyright   : Satoshi Egi+Licence     : MIT++This module provide Egison parser.+-}++module Language.Egison.ParserNonS+       (+       -- * Parse a string+         readTopExprs+       , readTopExpr+       , readExprs+       , readExpr+       , parseTopExprs+       , parseTopExpr+       , parseExprs+       , parseExpr+       -- * Parse a file+       , loadLibraryFile+       , loadFile+       ) where++import Prelude hiding (mapM)+import Control.Monad.Identity hiding (mapM)+import Control.Monad.Except hiding (mapM)+import Control.Monad.State hiding (mapM)+import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)++import System.Directory (doesFileExist, getHomeDirectory)++import qualified Data.Sequence as Sq+import Data.Either+import Data.Char (isLower, isUpper, toLower)+import qualified Data.Set as Set+import Data.Traversable (mapM)+import Data.Ratio+import Data.List (intercalate)+import Data.List.Split (split, splitOn, startsWithOneOf)++import Text.Parsec+import Text.Parsec.String+import Text.Parsec.Expr+import qualified Text.Parsec.Token as P++import qualified Data.Text as T+import Text.Regex.TDFA++import Language.Egison.Types+import Language.Egison.Desugar+import Paths_egison (getDataFileName)++readTopExprs :: String -> EgisonM [EgisonTopExpr]+readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs++readTopExpr :: String -> EgisonM EgisonTopExpr+readTopExpr = either throwError desugarTopExpr . parseTopExpr++readExprs :: String -> EgisonM [EgisonExpr]+readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs++readExpr :: String -> EgisonM EgisonExpr+readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr++parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = doParse $ do+  ret <- whiteSpace >> endBy topExpr whiteSpace+  eof+  return ret++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = doParse $ do+  ret <- whiteSpace >> topExpr+  whiteSpace >> eof+  return ret++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = doParse $ do+  ret <- whiteSpace >> endBy expr whiteSpace+  eof+  return ret++parseExpr :: String -> Either EgisonError EgisonExpr+parseExpr = doParse $ do+  ret <- whiteSpace >> expr+  whiteSpace >> eof+  return ret++-- |Load a libary file+loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile file = do+  homeDir <- liftIO $ getHomeDirectory+  doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file+  if doesExist+    then loadFile $ homeDir ++ "/.egison/" ++ file+    else liftIO (getDataFileName file) >>= loadFile++-- |Load a file+loadFile :: FilePath -> EgisonM [EgisonTopExpr]+loadFile file = do+  doesExist <- liftIO $ doesFileExist file+  unless doesExist $ throwError $ Default ("file does not exist: " ++ file)+  input <- liftIO $ readUTF8File file+  exprs <- readTopExprs $ shebang input+  concat <$> mapM  recursiveLoad exprs+ where+  recursiveLoad (Load _ file) = loadLibraryFile file+  recursiveLoad (LoadFile _ file) = loadFile file+  recursiveLoad expr = return [expr]+  shebang :: String -> String+  shebang ('#':'!':cs) = ';':'#':'!':cs+  shebang cs = cs++--+-- Parser+--++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++--+-- Expressions+--++topExpr :: Parser EgisonTopExpr+topExpr = try defineExpr+          <|> try (Test <$> expr)+          <|> testExpr+          <|> loadFileExpr+          <|> loadExpr+          <?> "top-level expression"++defineExpr :: Parser EgisonTopExpr+defineExpr = try (Define <$> identVar <*> (LambdaExpr <$> (parens argNames') <* (inSpaces $ string "=") <* notFollowedBy (string "=") <*> expr))+             <|> try (Define <$> identVar <* (inSpaces $ string "=") <* notFollowedBy (string "=") <*> expr)+             <|> try (do (VarWithIndices name is) <- identVarWithIndices+                         inSpaces $ string "=" >> notFollowedBy (string "=")+                         body <- expr+                         return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . h) is)) body)))+ where+  argNames' :: Parser [Arg]+  argNames' = sepEndBy argName' comma+  argName' :: Parser Arg+  argName' = try (ident >>= return . ScalarArg)+        <|> try (char '*' >> ident >>= return . InvertedScalarArg)+        <|> try (char '%' >> ident >>= return . TensorArg)+  f (Superscript _) = Superscript ()+  f (Subscript _) = Subscript ()+  f (SupSubscript _) = SupSubscript ()+  g (Superscript i) = i+  g (Subscript i) = i+  g (SupSubscript i) = i+  h (Superscript i) = (VarExpr $ stringToVar i)+  h (Subscript i) = (VarExpr $ stringToVar i)+  h (SupSubscript i) = (VarExpr $ stringToVar i)++testExpr :: Parser EgisonTopExpr+testExpr = keywordTest >> Test <$> parens expr++loadFileExpr :: Parser EgisonTopExpr+loadFileExpr = keywordLoadFile >> LoadFile False <$> parens stringLiteral++loadExpr :: Parser EgisonTopExpr+loadExpr = keywordLoad >> Load False <$> parens stringLiteral++exprs :: Parser [EgisonExpr]+exprs = endBy expr whiteSpace++expr :: Parser EgisonExpr+expr = (try applyInfixExpr+        <|> try exprWithSymbol+        <|> try (buildExpressionParser table arg)+        <|> try ifExpr+        <|> try term)+        <?> "expression"+ where+  arg = (char '$' *> notFollowedBy varExpr *> (LambdaArgExpr <$> option "" index))+        <|> term+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit+  table = [ [unary "not" AssocRight]+          , [binary "^" "**" AssocLeft]+          , [unary "-" AssocLeft]+          , [binary "*" "*" AssocLeft, binary "/" "/" AssocLeft, binary "." "." AssocLeft]+          , [binary "+" "+" AssocLeft, binary "-" "-" AssocLeft, binary "%" "remainder" AssocLeft]+          , [binary "==" "eq?" AssocLeft, binary "<=" "lte?" AssocLeft, binary "<" "lt?" AssocLeft, binary ">=" "gte?" AssocLeft, binary ">" "gt?" AssocLeft]+          , [binary ":" "cons" AssocLeft, binary ".." "between" AssocLeft]+          , [binary "and" "and" AssocLeft, binary "or" "or" AssocLeft]+          , [binary "++" "join" AssocRight]+          ]+  unary "-" assoc = Prefix (try $ inSpaces (string "-") >> (return $ \x -> (makeApply (VarExpr $ stringToVar "*") [IntegerExpr (-1), x])))+  unary op assoc = Prefix (try $ inSpaces (string op) >> (return $ \x -> makeApply (VarExpr $ stringToVar op) [x]))+  binary op name assoc+    | op == "/" = Infix (try $ (try (inSpaces1 $ string op) <|> ((inSpaces $ string op) >> notFollowedBy (string "m" <|> string "fn"))) >> (return $ \x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc+    | (op == "." || op == "%") = Infix (try $ (inSpaces1 $ string op) >> (return $ \x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc+    | otherwise = Infix (try $ inSpaces (string op) >> (return $ \x y -> makeApply (VarExpr $ stringToVar name) [x, y])) assoc++inSpaces :: Parser a -> Parser ()+inSpaces p = skipMany (space <|> newline) >> p >> skipMany (space <|> newline)++inSpaces1 :: Parser a -> Parser ()+inSpaces1 p = skipMany (space <|> newline) >> p >> skipMany1 (space <|> newline)++exprWithSymbol :: Parser EgisonExpr+exprWithSymbol = (string "d/d" >> applyExpr'' (VarExpr $ stringToVar "d/d"))+                 <|> (string "V.*" >> applyExpr'' (VarExpr $ stringToVar "V.*"))+                 <|> (string "M.*" >> applyExpr'' (VarExpr $ stringToVar "M.*"))+                 <|> (lookAhead (string "let*") >> letStarExpr)++term :: Parser EgisonExpr+term = P.lexeme lexer+        (do term0 <- term'+            option term0 $ try (IndexedExpr False term0 <$ string "..." <*> parseindex+                           <|> IndexedExpr True term0 <$> parseindex))+ where+  parseindex :: Parser [Index EgisonExpr]+  parseindex = many1 $ try (MultiSubscript <$ char '_' <*> term' <* string "..._" <*> term')+                       <|> try (MultiSuperscript <$ char '~' <*> term' <* string "...~" <*> term')+                       <|> try (char '_' >> Subscript <$> term')+                       <|> try (char '~' >> Superscript <$> term')+                       <|> try (string "~_" >> SupSubscript <$> term')+                       <|> try (char '|' >> Userscript <$> term')++term' :: Parser EgisonExpr+term' = matchExpr+        <|> matchAllExpr+        <|> matchLambdaExpr+        <|> matchAllLambdaExpr+        <|> matcherExpr+        <|> matcherDFSExpr+        <|> functionWithArgExpr+        <|> userrefsExpr+        <|> algebraicDataMatcherExpr+        <|> try applyExpr+        <|> cApplyExpr+        <|> try partialExpr+        <|> try partialVarExpr+        <|> try constantExpr+        <|> try freshVarExpr+        <|> try lambdaExpr+        <|> try cambdaExpr+        <|> try withSymbolsExpr+        <|> try varExpr+        <|> try vectorExpr+        <|> try tupleExpr+        <|> try hashExpr+        <|> try collectionExpr+        <|> inductiveDataExpr+        <|> try doExpr+        <|> generateTensorExpr+        <|> tensorExpr+        <|> letExpr+        <|> letRecExpr+        <|> letStarExpr+        <|> patternFunctionExpr+        <|> quoteExpr+        <|> quoteSymbolExpr+        <|> tensorContractExpr+        <|> subrefsExpr+        <|> suprefsExpr+        <|> macroExpr+        <|> ioExpr+        <|> seqExpr+        <|> memoizedLambdaExpr+        <|> procedureExpr+        <|> wedgeExpr+        <|> parens expr+        <?> "simple expression"++varExpr :: Parser EgisonExpr+varExpr = VarExpr <$> identVarWithoutIndex++freshVarExpr :: Parser EgisonExpr+freshVarExpr = char '#' >> return FreshVarExpr++inductiveDataExpr :: Parser EgisonExpr+inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace++tupleExpr :: Parser EgisonExpr+tupleExpr = parens $ TupleExpr <$> sepEndBy expr comma++collectionExpr :: Parser EgisonExpr+collectionExpr = brackets (CollectionExpr <$> sepEndBy innerExpr comma)+                 <|> braces (CollectionExpr <$> sepEndBy innerExpr comma)+ where+  innerExpr :: Parser InnerExpr+  innerExpr = (char '@' >> SubCollectionExpr <$> expr)+               <|> ElementExpr <$> expr++vectorExpr :: Parser EgisonExpr+vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr comma+  where+    lp = P.lexeme lexer (string "[|")+    rp = string "|]"++hashExpr :: Parser EgisonExpr+hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr comma+  where+    lp = P.lexeme lexer (string "{|")+    rp = string "|}"+    pairExpr :: Parser (EgisonExpr, EgisonExpr)+    pairExpr = brackets $ (,) <$> expr <* comma <*> expr++quoteExpr :: Parser EgisonExpr+quoteExpr = char '\'' >> QuoteExpr <$> expr++wedgeExpr :: Parser EgisonExpr+wedgeExpr = char '!' >> WedgeExpr <$> expr++functionWithArgExpr :: Parser EgisonExpr+functionWithArgExpr = keywordFunction >> FunctionExpr <$> (parens $ sepEndBy expr comma)++quoteSymbolExpr :: Parser EgisonExpr+quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr++matchAllExpr :: Parser EgisonExpr+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses++matchExpr :: Parser EgisonExpr+matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses++matchLambdaExpr :: Parser EgisonExpr+matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$ keywordAs <*> expr <*> matchClauses++matchAllLambdaExpr :: Parser EgisonExpr+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$ keywordAs <*> expr <*> matchClauses++matchClauses :: Parser [MatchClause]+matchClauses = many1 matchClause++matchClause :: Parser MatchClause+matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* (reservedOp "->") <*> expr++matcherExpr :: Parser EgisonExpr+matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses++matcherDFSExpr :: Parser EgisonExpr+matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses++ppMatchClauses :: Parser MatcherInfo+ppMatchClauses = many1 ppMatchClause++ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ppMatchClause = inSpaces (string "|") >> (,,) <$> ppPattern <* keywordAs <*> expr <* (reservedOp "->") <*> pdMatchClauses++pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]+pdMatchClauses = many1 pdMatchClause++pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)+pdMatchClause = try $ inSpaces (string "|") >> (,) <$> pdPattern <* (reservedOp "->") <*> expr++ppPattern :: Parser PrimitivePatPattern+ppPattern = P.lexeme lexer (ppWildCard+                        <|> ppPatVar+                        <|> ppValuePat+                        <|> ppInductivePat+                        <?> "primitive-pattren-pattern")++ppWildCard :: Parser PrimitivePatPattern+ppWildCard = reservedOp "_" *> pure PPWildCard++ppPatVar :: Parser PrimitivePatPattern+ppPatVar = reservedOp "$" *> pure PPPatVar++ppValuePat :: Parser PrimitivePatPattern+ppValuePat = reservedOp ",$" >> PPValuePat <$> ident++ppInductivePat :: Parser PrimitivePatPattern+ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)++pdPattern :: Parser PrimitiveDataPattern+pdPattern = P.lexeme lexer pdPattern'++pdPattern' :: Parser PrimitiveDataPattern+pdPattern' = reservedOp "_" *> pure PDWildCard+                    <|> (char '$' >> PDPatVar <$> ident)+                    <|> brackets ((PDConsPat <$> pdPattern <* comma <*> (char '@' *> pdPattern))+                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <* comma <*> pdPattern)+                            <|> pure PDEmptyPat)+                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern comma)+                    <|> parens (PDTuplePat <$> sepEndBy pdPattern comma)+                    <|> PDConstantPat <$> constantExpr+                    <?> "primitive-data-pattern"++ifExpr :: Parser EgisonExpr+ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr++lambdaExpr :: Parser EgisonExpr+lambdaExpr = LambdaExpr <$> argNames <* reservedOp "->" <*> expr++memoizedLambdaExpr :: Parser EgisonExpr+memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <* reservedOp "->" <*> expr++memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)]+memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace++memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr)+memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr++cambdaExpr :: Parser EgisonExpr+cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <* reservedOp "->" <*> expr++procedureExpr :: Parser EgisonExpr+procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <* reservedOp "->" <*> expr++macroExpr :: Parser EgisonExpr+macroExpr = keywordMacro >> MacroExpr <$> varNames <* reservedOp "->" <*> expr++patternFunctionExpr :: Parser EgisonExpr+patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> (brackets $ sepEndBy ident comma) <* comma <*> pattern)++letRecExpr :: Parser EgisonExpr+letRecExpr =  keywordLetRec >> LetRecExpr <$> bindings <* keywordLetIn <*> expr++letExpr :: Parser EgisonExpr+letExpr = keywordLet >> LetExpr <$> bindings <* keywordLetIn <*> expr++letStarExpr :: Parser EgisonExpr+letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <* keywordLetIn <*> expr++withSymbolsExpr :: Parser EgisonExpr+withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident comma) <*> expr++doExpr :: Parser EgisonExpr+doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr++statements :: Parser [BindingExpr]+statements = braces $ sepEndBy statement comma++statement :: Parser BindingExpr+statement = try binding+        <|> (([],) <$> expr)++bindings :: Parser [BindingExpr]+bindings = sepEndBy binding comma++binding :: Parser BindingExpr+binding = (,) <$> varNames' <* inSpaces (string "=") <*> expr++varNames :: Parser [String]+varNames = sepEndBy (char '$' >> ident) spaces++varNames' :: Parser [Var]+varNames' = return <$> identVar+            <|> parens (sepEndBy identVar comma)++argNames :: Parser [Arg]+argNames = sepEndBy argName spaces++argName :: Parser Arg+argName = try (char '$' >> ident >>= return . ScalarArg)+      <|> try (string "*$" >> ident >>= return . InvertedScalarArg)+      <|> try (char '%' >> ident >>= return . TensorArg)++ioExpr :: Parser EgisonExpr+ioExpr = keywordIo >> parens (IoExpr <$> expr)++seqExpr :: Parser EgisonExpr+seqExpr = keywordSeq >> parens (SeqExpr <$> expr <* comma <*> expr)++cApplyExpr :: Parser EgisonExpr+cApplyExpr = keywordCApply >> parens (CApplyExpr <$> expr <* comma <*> expr)++applyExpr :: Parser EgisonExpr+applyExpr = (keywordApply >> parens (ApplyExpr <$> expr <* comma <*> expr))+            <|> try applyExpr'++applyExpr' :: Parser EgisonExpr+applyExpr' = do+  func <- try varExpr <|> try partialExpr <|> try partialVarExpr <|> (parens expr)+  applyExpr'' func++applyExpr'' :: EgisonExpr -> Parser EgisonExpr+applyExpr'' func = do+  argslist <- many1 $ parens args+  return $ foldl (\acc xs -> makeApply acc xs) func argslist+ where+  args = sepEndBy arg $ comma+  arg = try expr+        <|> char '$' *> (LambdaArgExpr <$> option "" index)+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit++applyInfixExpr :: Parser EgisonExpr+applyInfixExpr = do+  arg1 <- arg+  spaces+  func <- (char '`' *> varExpr <* char '`')+  spaces+  arg2 <- arg+  return $ makeApply func [arg1, arg2]+ where+  arg = try term+        <|> char '$' *> (LambdaArgExpr <$> option "" index)+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit++makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr+makeApply func xs = do+  let args = map (\x -> case x of+                          LambdaArgExpr s -> Left s+                          _ -> Right x) xs+  let vars = lefts args+  case vars of+    [] -> ApplyExpr func . TupleExpr $ rights args+    _ | all null vars ->+        let args' = rights args+            args'' = map f (zip args (annonVars 1 (length args)))+            args''' = map (VarExpr . stringToVar . (either id id)) args''+        in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'+      | all (not . null) vars ->+        let n = Set.size $ Set.fromList vars+            args' = rights args+            args'' = map g (zip args (annonVars (n + 1) (length args)))+            args''' = map (VarExpr . stringToVar . (either id id)) args''+        in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'+ where+  annonVars m n = take n $ map ((':':) . show) [m..]+  f ((Left _), var) = Left var+  f ((Right _), var) = Right var+  g ((Left arg), _) = Left (':':arg)+  g ((Right _), var) = Right var++partialExpr :: Parser EgisonExpr+partialExpr = PartialExpr <$> read <$> index <*> (char '#' >> (try (parens expr) <|> expr))+ where+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit++partialVarExpr :: Parser EgisonExpr+partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral++algebraicDataMatcherExpr :: Parser EgisonExpr+algebraicDataMatcherExpr = keywordAlgebraicDataMatcher+                                >> AlgebraicDataMatcherExpr <$> parens (sepEndBy1 inductivePat' comma)+  where+    inductivePat' :: Parser (String, [EgisonExpr])+    inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace++generateTensorExpr :: Parser EgisonExpr+generateTensorExpr = keywordGenerateTensor >> parens (GenerateTensorExpr <$> expr <* comma <*> expr)++tensorExpr :: Parser EgisonExpr+tensorExpr = keywordTensor >> parens (TensorExpr <$> expr <* comma <*> expr <*> option (CollectionExpr []) (comma *> expr) <*> option (CollectionExpr []) (comma *> expr))++tensorContractExpr :: Parser EgisonExpr+tensorContractExpr = keywordTensorContract >> parens (TensorContractExpr <$> expr <* comma <*> expr)++subrefsExpr :: Parser EgisonExpr+subrefsExpr = (keywordSubrefs >> parens (SubrefsExpr False <$> expr <* comma <*> expr))+               <|> (keywordSubrefsNew >> parens (SubrefsExpr True <$> expr <* comma <*> expr))++suprefsExpr :: Parser EgisonExpr+suprefsExpr = (keywordSuprefs >> SuprefsExpr False <$> expr <*> expr)+               <|> (keywordSuprefsNew >> SuprefsExpr True <$> expr <*> expr)++userrefsExpr :: Parser EgisonExpr+userrefsExpr = (do keywordUserrefs+                   xs <- parens $ sepEndBy expr comma+                   case xs of+                     [x, y] -> return $ UserrefsExpr False x y+                     _ -> unexpected "number of arguments (expected 2)")+                <|> (do keywordUserrefsNew+                        xs <- parens $ sepEndBy expr comma+                        case xs of+                          [x, y] -> return $ UserrefsExpr True x y+                          _ -> unexpected "number of arguments (expected 2)")++-- Patterns++pattern :: Parser EgisonPattern+pattern = P.lexeme lexer+            (try (buildExpressionParser table pattern')+             <|> try pattern'+             <?> "expression")++ where+  table = [ [unary "!" AssocRight, unary "not" AssocRight]+          , [binary'' "^" PowerPat AssocLeft]+          , [binary' "*" MultPat AssocRight, binary'' "/" DivPat AssocRight]+          , [binary' "+" PlusPat AssocRight]+          , [binary "<:>" "cons" AssocRight]+          , [binary' "and" AndPat AssocLeft, binary' "or*" OrderedOrPat' AssocLeft, binary' "or" OrPat AssocLeft]+          , [binary "<++>" "join" AssocRight]+          ]+  unary op assoc = Prefix (try $ inSpaces (string op) >> (return $ \x -> NotPat x))+  binary op name assoc = Infix (try $ inSpaces (string op) >> (return $ \x y -> InductivePat name [x, y])) assoc+  binary' op epr assoc = Infix (try $ inSpaces (string op) >> (return $ \x y -> epr [x, y])) assoc+  binary'' op epr assoc = Infix (try $ inSpaces (string op) >> (return $ \x y -> epr x y)) assoc++pattern' :: Parser EgisonPattern+pattern' = wildCard+           <|> contPat+           <|> try indexedPat+           <|> patVar+           <|> try dfsPat+           <|> try bfsPat+           <|> try loopPat+           <|> try pApplyPat+           <|> try dApplyPat+           <|> try varPat+           <|> valuePat+           <|> predPat+           <|> try tuplePat+           <|> inductivePat+           <|> letPat+           <|> parens pattern++pattern'' :: Parser EgisonPattern+pattern'' = wildCard+            <|> patVar+            <|> valuePat++wildCard :: Parser EgisonPattern+wildCard = reservedOp "_" >> pure WildCard++indexedPat :: Parser EgisonPattern+indexedPat = IndexedPat <$> (patVar <|> varPat) <*> many1 (try $ char '_' >> term')++patVar :: Parser EgisonPattern+patVar = char '$' >> PatVar <$> identVarWithoutIndex++varPat :: Parser EgisonPattern+varPat = char '\'' >> VarPat <$> ident++valuePat :: Parser EgisonPattern+valuePat = ValuePat <$> expr++predPat :: Parser EgisonPattern+predPat = char '?' >> PredPat <$> expr++letPat :: Parser EgisonPattern+letPat = keywordLet >> LetPat <$> bindings <* keywordLetIn <*> pattern++tuplePat :: Parser EgisonPattern+tuplePat = TuplePat <$> parens ((:) <$> pattern <* comma <*> sepEndBy1 pattern comma)++inductivePat :: Parser EgisonPattern+inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace++contPat :: Parser EgisonPattern+contPat = keywordCont >> pure ContPat++pApplyPat :: Parser EgisonPattern+pApplyPat = PApplyPat <$> expr <*> brackets (sepEndBy pattern comma)++dApplyPat :: Parser EgisonPattern+dApplyPat = DApplyPat <$> pattern'' <*> parens (sepEndBy pattern comma)++loopPat :: Parser EgisonPattern+loopPat = keywordLoop >> parens (char '$' >> LoopPat <$> identVarWithoutIndex <*> (comma >> loopRange) <*> (comma >> pattern) <*> (comma >> option (NotPat WildCard) pattern))++loopRange :: Parser LoopRange+loopRange = brackets (try (do s <- expr+                              comma+                              e <- expr+                              comma+                              ep <- option WildCard pattern+                              return (LoopRange s e ep))+                 <|> (do s <- expr+                         comma+                         ep <- option WildCard pattern+                         return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep)))++dfsPat :: Parser EgisonPattern+dfsPat = keywordDFS >> DFSPat' <$> parens pattern++bfsPat :: Parser EgisonPattern+bfsPat = keywordBFS >> BFSPat <$> parens pattern++-- Constants++constantExpr :: Parser EgisonExpr+constantExpr = stringExpr+                 <|> boolExpr+                 <|> try charExpr+                 <|> try floatExpr+                 <|> try integerExpr+                 <|> (keywordSomething *> pure SomethingExpr)+                 <|> (keywordUndefined *> pure UndefinedExpr)+                 <?> "constant"++charExpr :: Parser EgisonExpr+charExpr = CharExpr <$> charLiteral++stringExpr :: Parser EgisonExpr+stringExpr = StringExpr . T.pack <$> stringLiteral++boolExpr :: Parser EgisonExpr+boolExpr = BoolExpr <$> boolLiteral++floatExpr :: Parser EgisonExpr+floatExpr = do+  (x,y) <- try (do x <- floatLiteral'+                   y <- sign' <*> positiveFloatLiteral+                   char 'i'+                   return (x,y))+            <|> try (do y <- floatLiteral'+                        char 'i'+                        return (0,y))+            <|> try (do x <- floatLiteral'+                        return (x,0))+  return $ FloatExpr x y++integerExpr :: Parser EgisonExpr+integerExpr = do+  n <- integerLiteral'+  return $ IntegerExpr n++integerLiteral' :: Parser Integer+integerLiteral' = sign <*> positiveIntegerLiteral++positiveIntegerLiteral :: Parser Integer+positiveIntegerLiteral = read <$> many1 digit++positiveFloatLiteral :: Parser Double+positiveFloatLiteral = do+  n <- positiveIntegerLiteral+  char '.'+  mStr <- many1 digit+  let m = read mStr+  let l = m % (10 ^ (fromIntegral (length mStr)))+  return (fromRational ((fromIntegral n) + l) :: Double)++floatLiteral' :: Parser Double+floatLiteral' = sign <*> positiveFloatLiteral++--+-- Tokens+--++egisonDef :: P.GenLanguageDef String () Identity+egisonDef =+  P.LanguageDef { P.commentStart       = "#|"+                , P.commentEnd         = "|#"+                , P.commentLine        = ";"+                , P.identStart         = letter <|> symbol1+                , P.identLetter        = letter <|> digit <|> symbol0 <|> symbol2+                , P.opStart            = symbol1+                , P.opLetter           = symbol0 <|> symbol1+                , P.reservedNames      = reservedKeywords+                , P.reservedOpNames    = reservedOperators+                , P.nestedComments     = True+                , P.caseSensitive      = True }++symbol0 = oneOf "/."+symbol1' = oneOf "∂∇"+symbol1 = symbol1' <|> oneOf "+-"+symbol2 = symbol1' <|> oneOf "'!?"++lexer :: P.GenTokenParser String () Identity+lexer = P.makeTokenParser egisonDef++reservedKeywords :: [String]+reservedKeywords =+  [ "define"+  , "set!"+  , "test"+  , "loadFile"+  , "load"+  , "if"+  , "then"+  , "else"+  , "as"+  , "seq"+  , "apply"+  , "capply"+  , "lambda"+  , "memoizedLambda"+  , "cambda"+  , "procedure"+  , "macro"+  , "patternFunction"+  , "letrec"+  , "let"+  , "let*"+  , "in"+  , "withSymbols"+  , "loop"+  , "matchAll"+  , "matchAllLambda"+  , "match"+  , "matchLambda"+  , "matcher"+  , "matcherDFS"+  , "do"+  , "io"+  , "something"+  , "undefined"+  , "algebraicDataMatcher"+  , "generateTensor"+  , "tensor"+  , "contract"+  , "subrefs"+  , "subrefs!"+  , "suprefs"+  , "suprefs!"+  , "userRefs"+  , "userRefs!"+  , "function"+  , "dfs"+  , "bfs"]++reservedOperators :: [String]+reservedOperators =+  [ "$"+  , ",$"+  , "_"+  , "^"+  , "&"+  , "|*"+  , "("+  , ")"+  , "->"+  , "`"+--  , "'"+--  , "~"+--  , "!"+--  , ","+--  , "@"+  , "..."]++reserved :: String -> Parser ()+reserved = P.reserved lexer++reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer++keywordDefine               = reserved "define"+keywordSet                  = reserved "set!"+keywordTest                 = reserved "test"+keywordLoadFile             = reserved "loadFile"+keywordLoad                 = reserved "load"+keywordIf                   = reserved "if"+keywordThen                 = reserved "then"+keywordElse                 = reserved "else"+keywordAs                   = reserved "as"+keywordSeq                  = reserved "seq"+keywordApply                = reserved "apply"+keywordCApply               = reserved "capply"+keywordLambda               = reserved "lambda"+keywordMemoizedLambda       = reserved "memoizedLambda"+keywordCambda               = reserved "cambda"+keywordProcedure            = reserved "procedure"+keywordMacro                = reserved "macro"+keywordPatternFunction      = reserved "patternFunction"+keywordLetRec               = reserved "letrec"+keywordLet                  = reserved "let"+keywordLetStar              = reserved "let*"+keywordLetIn                = reserved "in"+keywordWithSymbols          = reserved "withSymbols"+keywordLoop                 = reserved "loop"+keywordCont                 = reserved "..."+keywordMatchAll             = reserved "matchAll"+keywordMatchAllLambda       = reserved "matchAllLambda"+keywordMatch                = reserved "match"+keywordMatchLambda          = reserved "matchLambda"+keywordMatcher              = reserved "matcher"+keywordMatcherDFS           = reserved "matcherDFS"+keywordDo                   = reserved "do"+keywordIo                   = reserved "io"+keywordSomething            = reserved "something"+keywordUndefined            = reserved "undefined"+keywordAlgebraicDataMatcher = reserved "algebraicDataMatcher"+keywordGenerateTensor       = reserved "generateTensor"+keywordTensor               = reserved "tensor"+keywordTensorContract       = reserved "contract"+keywordSubrefs              = reserved "subrefs"+keywordSubrefsNew           = reserved "subrefs!"+keywordSuprefs              = reserved "suprefs"+keywordSuprefsNew           = reserved "suprefs!"+keywordUserrefs             = reserved "userRefs"+keywordUserrefsNew          = reserved "userRefs!"+keywordFunction             = reserved "function"+keywordDFS                  = reserved "dfs"+keywordBFS                  = reserved "bfs"++sign :: Num a => Parser (a -> a)+sign = (char '-' >> return negate)+   <|> (char '+' >> return id)+   <|> return id++sign' :: Num a => Parser (a -> a)+sign' = (char '-' >> return negate)+    <|> (char '+' >> return id)++naturalLiteral :: Parser Integer+naturalLiteral = P.natural lexer++integerLiteral :: Parser Integer+integerLiteral = sign <*> P.natural lexer++floatLiteral :: Parser Double+floatLiteral = sign <*> P.float lexer++stringLiteral :: Parser String+stringLiteral = P.stringLiteral lexer++--charLiteral :: Parser Char+--charLiteral = P.charLiteral lexer+charLiteral :: Parser Char+charLiteral = string "c#" >> anyChar++boolLiteral :: Parser Bool+boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)++whiteSpace :: Parser ()+whiteSpace = P.whiteSpace lexer++parens :: Parser a -> Parser a+parens = P.parens lexer++brackets :: Parser a -> Parser a+brackets = P.brackets lexer++braces :: Parser a -> Parser a+braces = P.braces lexer++angles :: Parser a -> Parser a+angles = P.angles lexer++colon :: Parser String+colon = P.colon lexer++comma :: Parser String+comma = P.comma lexer++dot :: Parser String+dot = P.dot lexer++ident :: Parser String+ident = do+  idt <- P.identifier lexer+  let (f, s) = splitLast idt '.'+  case s of+    [] -> return f+    x:xs | isLower x -> return $ f ++ (map toLower $ intercalate "-" $ split (startsWithOneOf ['A'..'Z']) s)+         | otherwise -> return $ f ++ [x] ++ (map toLower $ intercalate "-" $ split (startsWithOneOf ['A'..'Z']) xs)+ where+  splitLast list elem = let (f, s) = span (/= elem) $ reverse list+                          in (reverse s, reverse f)++identVar :: Parser Var+identVar = P.lexeme lexer (do+  name <- ident+  is <- many indexType+  return $ Var (splitOn "." name) is)++identVarWithoutIndex :: Parser Var+identVarWithoutIndex = do+  x <- ident+  return $ stringToVar x++identVarWithIndices :: Parser VarWithIndices+identVarWithIndices = P.lexeme lexer (do+  name <- ident+  is <- many indexForVar+  return $ VarWithIndices (splitOn "." name) is)++indexForVar :: Parser (Index String)+indexForVar = try (char '~' >> Superscript <$> ident)+        <|> try (char '_' >> Subscript <$> ident)++indexType :: Parser (Index ())+indexType = try (char '~' >> return (Superscript ()))+        <|> try (char '_' >> return (Subscript ()))++upperName :: Parser String+upperName = P.lexeme lexer $ upperName'++upperName' :: Parser String+upperName' = (:) <$> upper <*> option "" ident+ where+  upper :: Parser Char+  upper = satisfy isUpper++lowerName :: Parser String+lowerName = P.lexeme lexer $ lowerName'++lowerName' :: Parser String+lowerName' = (:) <$> lower <*> option "" ident+ where+  lower :: Parser Char+  lower = satisfy isLower

@@ -84,7 +84,7 @@ twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc twoArgs f args = do   args' <- tupleToList args-  case args' of +  case args' of     [TensorData t1@(Tensor _ _ _), TensorData t2@(Tensor _ _ _)] -> Value <$> (tProduct f t1 t2 >>= fromTensor)     [TensorData(Tensor ns ds js), val] -> do       ds' <- V.mapM (\d -> f d val) ds@@ -99,7 +99,7 @@ twoArgs' :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc twoArgs' f args = do   args' <- tupleToList args-  case args' of +  case args' of     [val, val'] -> Value <$> f val val'     _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' @@ -107,7 +107,7 @@ threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc threeArgs' f args = do   args' <- tupleToList args-  case args' of +  case args' of     [val, val', val''] -> Value <$> f val val' val''     _ -> throwError $ ArgumentsNumPrimitive 3 $ length args' @@ -149,20 +149,20 @@              , ("remainder", integerBinaryOp rem)              , ("b.abs", rationalUnaryOp abs)              , ("b.neg", rationalUnaryOp negate)-               +              , ("eq?",  eq)              , ("lt?",  lt)              , ("lte?", lte)              , ("gt?",  gt)              , ("gte?", gte)-               +              , ("round",    floatToIntegerOp round)              , ("floor",    floatToIntegerOp floor)              , ("ceiling",  floatToIntegerOp ceiling)              , ("truncate", truncate')              , ("real-part", realPart)              , ("imaginary-part", imaginaryPart)-               +              , ("b.sqrt", floatUnaryOp sqrt)              , ("b.sqrt'", floatUnaryOp sqrt)              , ("b.exp", floatUnaryOp exp)@@ -203,7 +203,7 @@              , ("add-superscript", addSuperscript)               , ("read-process", readProcess')-               +              , ("read", read')              , ("read-tsv", readTSV)              , ("show", show')@@ -235,7 +235,7 @@   r <- fromEgison val   let r' =  op r   return $ toEgison r'-  + rationalBinaryOp :: (Rational -> Rational -> Rational) -> PrimitiveFunc rationalBinaryOp op = twoArgs $ \val val' -> do   r <- fromEgison val :: EgisonM Rational@@ -362,7 +362,7 @@   scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   scalarBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)   scalarBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)-  + lte :: PrimitiveFunc lte = twoArgs' $ \val val' -> scalarBinaryPred' val val'  where@@ -374,7 +374,7 @@   scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   scalarBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)   scalarBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)-  + gt :: PrimitiveFunc gt = twoArgs' $ \val val' -> scalarBinaryPred' val val'  where@@ -386,7 +386,7 @@   scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   scalarBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)   scalarBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)-  + gte :: PrimitiveFunc gte = twoArgs' $ \val val' -> scalarBinaryPred' val val'  where@@ -398,7 +398,7 @@   scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   scalarBinaryPred' (Float _ _)    val           = throwError $ TypeMismatch "float" (Value val)   scalarBinaryPred' val            _             = throwError $ TypeMismatch "number" (Value val)-  + truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val  where@@ -528,7 +528,7 @@ regexStringCaptureGroup = twoArgs $ \pat src -> case (pat, src) of                                                   (String patStr, String srcStr) -> do                                                     let ret = (T.unpack srcStr =~ T.unpack patStr) :: [[String]]-                                                    case ret of +                                                    case ret of                                                       [] -> return . Collection . Sq.fromList $ []                                                       ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr                                                                        return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]]@@ -645,18 +645,18 @@                , ("read-line", readLine)                , ("write-char", writeChar)                , ("write", writeString)-                 +                , ("read-char-from-port", readCharFromPort)                , ("read-line-from-port", readLineFromPort)                , ("write-char-to-port", writeCharToPort)                , ("write-to-port", writeStringToPort)-                 +                , ("eof?", isEOFStdin)                , ("flush", flushStdout)                , ("eof-port?", isEOFPort)                , ("flush-port", flushPort)                , ("read-file", readFile')-                 +                , ("rand", randRange) --               , ("sqlite", sqlite)                ]@@ -696,7 +696,7 @@ writeString = oneArg' $ \val -> do   s <- fromEgison val   return $ makeIO' $ liftIO $ T.putStr s-  + writeStringToPort :: PrimitiveFunc writeStringToPort = twoArgs' $ \val val' -> do   port <- fromEgison val@@ -734,7 +734,7 @@   filename <- fromEgison val   s <- liftIO $ T.readFile $ T.unpack filename   return $ makeIO $ return $ toEgison s-  + isEOFStdin :: PrimitiveFunc isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF 

@@ -1,6 +1,6 @@ {-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving,              MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable,-             TypeFamilies, TupleSections, DeriveGeneric #-}+             TypeFamilies, TupleSections, DeriveGeneric, TemplateHaskell #-} {- | Module      : Language.Egison.Types Copyright   : Satoshi Egi@@ -43,6 +43,7 @@     , tIndex     , tref     , enumTensorIndices+    , changeIndexList     , tTranspose     , tTranspose'     , tFlipIndices@@ -88,6 +89,7 @@     , Var (..)     , VarWithIndices (..)     , Binding (..)+    , Id     , nullEnv     , extendEnv     , refVar@@ -95,10 +97,18 @@     , Match     , PMMode (..)     , pmMode-    , MatchingState (..)     , MatchingTree (..)+    , MatchingState (..)+    , MatchingStates (..)     , PatternBinding (..)     , LoopPatContext (..)+    , topDFS+    , containBFS+    -- * makeLenses+    , normalTree+    , orderedOrTrees+    , ids+    , bool     -- * Errors     , EgisonError (..)     , liftError@@ -154,11 +164,13 @@  import Control.Exception import Control.Parallel+import Control.Lens (makeLenses) import Data.Typeable  import Control.Applicative import Control.Monad.Except import Control.Monad.State+import Control.Monad.Fail import Control.Monad.Reader (ReaderT) import Control.Monad.Writer (WriterT) import Control.Monad.Identity@@ -175,6 +187,7 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map)  import Data.List (intercalate, sort, sortBy, find, findIndex, splitAt, (\\), elem, delete, deleteBy, any, partition, intercalate, elemIndex) import Data.List.Split (splitOn)@@ -199,8 +212,8 @@   | Test EgisonExpr   | Execute EgisonExpr     -- temporary : we will replace load to import and export-  | LoadFile String-  | Load String+  | LoadFile Bool String+  | Load Bool String  deriving (Show, Eq)  data EgisonExpr =@@ -224,13 +237,14 @@   | VectorExpr [EgisonExpr]    | LambdaExpr [Arg] EgisonExpr+  | LambdaArgExpr [Char]   | MemoizedLambdaExpr [String] EgisonExpr   | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr   | CambdaExpr String EgisonExpr   | ProcedureExpr [String] EgisonExpr   | MacroExpr [String] EgisonExpr   | PatternFunctionExpr [String] EgisonPattern-  +   | IfExpr EgisonExpr EgisonExpr EgisonExpr   | LetRecExpr [BindingExpr] EgisonExpr   | LetExpr [BindingExpr] EgisonExpr@@ -238,28 +252,28 @@   | WithSymbolsExpr [String] EgisonExpr    | MatchExpr EgisonExpr EgisonExpr [MatchClause]-  | MatchAllExpr EgisonExpr EgisonExpr MatchClause+  | MatchAllExpr EgisonExpr EgisonExpr [MatchClause]   | MatchLambdaExpr EgisonExpr [MatchClause]-  | MatchAllLambdaExpr EgisonExpr MatchClause+  | MatchAllLambdaExpr EgisonExpr [MatchClause]    | NextMatchExpr EgisonExpr EgisonExpr [MatchClause]   | NextMatchAllExpr EgisonExpr EgisonExpr MatchClause   | NextMatchLambdaExpr EgisonExpr [MatchClause]   | NextMatchAllLambdaExpr EgisonExpr MatchClause -  | MatcherBFSExpr MatcherInfo+  | MatcherExpr MatcherInfo   | MatcherDFSExpr MatcherInfo   | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]    | QuoteExpr EgisonExpr   | QuoteSymbolExpr EgisonExpr-  +   | WedgeExpr EgisonExpr   | WedgeApplyExpr EgisonExpr EgisonExpr    | DoExpr [BindingExpr] EgisonExpr   | IoExpr EgisonExpr-    +   | SeqExpr EgisonExpr EgisonExpr   | ApplyExpr EgisonExpr EgisonExpr   | CApplyExpr EgisonExpr EgisonExpr@@ -304,6 +318,8 @@   | MultiSuperscript a a   | DFscript Integer Integer -- DifferentialForm   | Userscript a+  | DotSubscript a+  | DotSupscript a  deriving (Eq, Generic)  data InnerExpr =@@ -325,7 +341,8 @@   | NotPat EgisonPattern   | AndPat [EgisonPattern]   | OrPat [EgisonPattern]-  | OrderedOrPat [EgisonPattern]+  | OrderedOrPat' [EgisonPattern]+  | OrderedOrPat Id EgisonPattern EgisonPattern   | TuplePat [EgisonPattern]   | InductivePat String [EgisonPattern]   | LoopPat Var LoopRange EgisonPattern EgisonPattern@@ -338,6 +355,9 @@   | PlusPat [EgisonPattern]   | MultPat [EgisonPattern]   | PowerPat EgisonPattern EgisonPattern+  | DFSPat' EgisonPattern+  | DFSPat Id EgisonPattern+  | BFSPat EgisonPattern  deriving (Show, Eq)  data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern@@ -380,7 +400,7 @@   | IntHash (HashMap Integer EgisonValue)   | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)-  | UserMatcher Env PMMode MatcherInfo+  | UserMatcher Env MatcherInfo PMMode   | Func (Maybe Var) Env [String] EgisonExpr   | PartialFunc Env Integer EgisonExpr   | CFunc (Maybe Var) Env String EgisonExpr@@ -411,10 +431,10 @@     Term Integer [(SymbolExpr, Integer)]  data SymbolExpr =-    Symbol String String [Index ScalarData] -- ID, Name, Indices+    Symbol Id String [Index ScalarData]   | Apply EgisonValue [ScalarData]   | Quote ScalarData-  | FunctionData (Maybe EgisonValue) [EgisonValue] [EgisonValue] [Index ScalarData] -- fnname argnames arg indices+  | FunctionData (Maybe EgisonValue) [EgisonValue] [EgisonValue] [Index ScalarData] -- fnname argnames args indices  deriving (Eq)  instance Eq PolyExpr where@@ -619,7 +639,6 @@ mathDivide (Div (Plus ts1) (Plus ts2)) =   let z = termsGcd (ts1 ++ ts2) in   case z of---    (Term 1 []) -> (Div (Plus ts1) (Plus ts2))     (Term c zs) -> case ts2 of       [Term a _] -> if a < 0                       then (Div (Plus (map (\t -> mathDivideTerm t (Term (-1 * c) zs)) ts1)) (Plus (map (\t -> mathDivideTerm t (Term (-1 * c) zs)) ts2)))@@ -645,7 +664,7 @@     if x == y     then (1, (x, n - m))     else (1, (x, n))-              + mathRemoveZeroSymbol :: ScalarData -> ScalarData mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =   let p x = case x of@@ -711,7 +730,7 @@   p sgn [] _ = (False, 0)   p sgn ((x, n):xs) ys =     let (b, ys', sgn2) = q (x, n) [] ys in-      if b +      if b         then p (sgn * sgn2) xs ys'         else (False, 0)   q :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, [(SymbolExpr, Integer)], Integer)@@ -794,9 +813,7 @@ tIndex (Scalar _) = []  tIntRef' :: HasTensor a => Integer -> Tensor a -> EgisonM a-tIntRef' i (Tensor [ary] xs _) = let n = fromIntegral (length [ary]) in-                                     if (0 < i) && (i <= (n + 3)) then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1)-                                                                  else throwError $ TensorIndexOutOfBounds i (n + 3)+tIntRef' i (Tensor [_] xs _) = fromTensor $ Scalar $ xs V.! (fromIntegral (i - 1)) tIntRef' i (Tensor (n:ns) xs js) =   if (0 < i) && (i <= n)    then let w = fromIntegral (product ns) in@@ -804,13 +821,13 @@           fromTensor $ Tensor ns ys (cdr js)    else throwError $ TensorIndexOutOfBounds i n tIntRef' i _ = throwError $ Default "More indices than the order of the tensor"- + tIntRef :: HasTensor a => [Integer] -> Tensor a -> EgisonM (Tensor a) tIntRef [] (Tensor [] xs _)   | V.length xs == 1 = return $ Scalar (xs V.! 0)   | otherwise = throwError $ EgisonBug "sevaral elements in scalar tensor" tIntRef [] t = return t-tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms +tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms  tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM a tref [] (Tensor [] xs _)@@ -863,6 +880,11 @@ enumTensorIndices [] = [[]] enumTensorIndices (n:ns) = concatMap (\i -> (map (\is -> i:is) (enumTensorIndices ns))) [1..n] +changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]+changeIndexList idxlist ms = map (\(i, m) -> case i of+                                              Superscript s -> Superscript (s ++ m)+                                              Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)+ transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer] transIndex [] [] is = return is transIndex (j1:js1) js2 is = do@@ -1180,12 +1202,15 @@   show (VarExpr name) = show name   show (PartialVarExpr n) = "%" ++ show n   show (FunctionExpr args) = "(function [" ++ unwords (map show args) ++ "])"-  show (IndexedExpr b expr idxs) = show expr ++ concatMap show idxs+  show (IndexedExpr True expr idxs) = show expr ++ concatMap show idxs+  show (IndexedExpr False expr idxs) = show expr ++ "..." ++ concatMap show idxs   show (TupleExpr exprs) = "[" ++ unwords (map show exprs) ++ "]"+  show (CollectionExpr ls) = "{" ++ unwords (map show ls) ++ "}"    show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")"   show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")"   show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")"+  show (VectorExpr xs) = "[| " ++ unwords (map show xs) ++ " |]"   show _ = "(not supported)"  instance Show EgisonValue where@@ -1213,8 +1238,7 @@   show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ T.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"-  show (UserMatcher _ BFSMode _) = "#<matcher-bfs>"-  show (UserMatcher _ DFSMode _) = "#<matcher-dfs>"+  show (UserMatcher _ _ _) = "#<user-matcher>"   show (Func Nothing _ args _) = "(lambda [" ++ unwords (map show args) ++ "] ...)"   show (Func (Just name) _ _ _) = show name   show (PartialFunc _ n expr) = show n ++ "#" ++ show expr@@ -1436,18 +1460,18 @@ data Inner =     IElement ObjectRef   | ISubCollection ObjectRef-    + instance Show WHNFData where-  show (Value val) = show val +  show (Value val) = show val   show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"   show (Intermediate (ITuple _)) = "[...]"   show (Intermediate (ICollection _)) = "{...}"-  show (Intermediate (IArray _)) = "(|...|)" -  show (Intermediate (IIntHash _)) = "{|...|}" -  show (Intermediate (ICharHash _)) = "{|...|}" -  show (Intermediate (IStrHash _)) = "{|...|}" ---  show (Intermediate (ITensor _)) = "[|...|]" -  show (Intermediate (ITensor (Tensor ns xs _))) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]" +  show (Intermediate (IArray _)) = "(|...|)"+  show (Intermediate (IIntHash _)) = "{|...|}"+  show (Intermediate (ICharHash _)) = "{|...|}"+  show (Intermediate (IStrHash _)) = "{|...|}"+--  show (Intermediate (ITensor _)) = "[|...|]"+  show (Intermediate (ITensor (Tensor ns xs _))) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]"  instance Show Object where   show (Thunk _) = "#<thunk>"@@ -1463,25 +1487,25 @@   toWHNF :: a -> WHNFData   fromWHNF :: WHNFData -> EgisonM a   toWHNF = Value . toEgison-  + instance EgisonWHNF Char where   fromWHNF = liftError . fromCharWHNF-  + instance EgisonWHNF Text where   fromWHNF = liftError . fromStringWHNF-  + instance EgisonWHNF Bool where   fromWHNF = liftError . fromBoolWHNF-  + instance EgisonWHNF Integer where   fromWHNF = liftError . fromIntegerWHNF-  + instance EgisonWHNF Double where   fromWHNF = liftError . fromFloatWHNF-  + instance EgisonWHNF Handle where   fromWHNF = liftError . fromPortWHNF-  + fromCharWHNF :: WHNFData -> Either EgisonError Char fromCharWHNF (Value (Char c)) = return c fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf@@ -1510,7 +1534,7 @@ class (EgisonWHNF a) => EgisonObject a where   toObject :: a -> Object   toObject = WHNF . toWHNF-  + -- -- Environment --@@ -1529,6 +1553,8 @@  type Binding = (Var, ObjectRef) +type Id = String+ instance Show Var where   show (Var xs is) = intercalate "." xs ++ concatMap show is @@ -1591,27 +1617,57 @@  type Match = [Binding] -data PMMode = BFSMode | DFSMode+data PMMode = BFSMode | DFSMode Id  deriving (Show) -pmMode :: Matcher -> PMMode-pmMode (UserMatcher _ mode _) = mode-pmMode (Tuple _) = DFSMode-pmMode Something = DFSMode+data MatchingState = MState PMMode Env [LoopPatContext] [Binding] [MatchingTree] -data MatchingState = MState Env [LoopPatContext] [Binding] [MatchingTree]- deriving (Show)+instance Show MatchingState where+  show (MState mode _ _ bindings mtrees) = "(MState " ++ intercalate " " [show mode, "_", "_", show bindings, show mtrees] ++ ")" +pmMode :: MatchingState -> PMMode+pmMode (MState mode _ _ _ _) = mode+ data MatchingTree =     MAtom EgisonPattern WHNFData Matcher   | MNode [PatternBinding] MatchingState  deriving (Show) +data MatchingStates = MatchingStates { _normalTree :: [[MList EgisonM MatchingState]],+                                       _orderedOrTrees :: Map Id (Map Int [MList EgisonM MatchingState]),+                                       _ids :: [Id],+                                       _bool :: Bool+                                      } deriving (Show)+ type PatternBinding = (String, EgisonPattern)  data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern  deriving (Show) +topDFS :: EgisonPattern -> Bool+topDFS (DFSPat _ _) = True+topDFS (InductivePat _ patterns) = any topDFS patterns+topDFS _ = False++containBFS :: EgisonPattern -> Bool+containBFS (BFSPat _) = True+containBFS (IndexedPat pattern _) = containBFS pattern+containBFS (NotPat pattern) = containBFS pattern+containBFS (AndPat patterns) = any containBFS patterns+containBFS (OrPat patterns) = any containBFS patterns+containBFS (OrderedOrPat _ pat1 pat2) = containBFS pat1 || containBFS pat2+containBFS (TuplePat patterns) = any containBFS patterns+containBFS (InductivePat _ patterns) = any containBFS patterns+containBFS (LoopPat _ _ pat1 pat2) = containBFS pat1 || containBFS pat2+containBFS (PApplyPat _ patterns) = any containBFS patterns+containBFS (DApplyPat pat patterns) = any containBFS (pat:patterns)+containBFS (DivPat pat1 pat2) = containBFS pat1 || containBFS pat2+containBFS (PlusPat patterns) = any containBFS patterns+containBFS (MultPat patterns) = any containBFS patterns+containBFS (PowerPat pat1 pat2) = containBFS pat1 || containBFS pat2+containBFS (DFSPat _ pattern) = containBFS pattern+containBFS _ = False+ -- -- Errors --@@ -1633,7 +1689,7 @@   | EgisonBug String   | Default String   deriving Typeable-    + instance Show EgisonError where   show (Parser err) = "Parse error at: " ++ err   show (UnboundVariable var) = "Unbound variable: " ++ show var@@ -1667,6 +1723,9 @@     unEgisonM :: ExceptT EgisonError (FreshT IO) a   } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh) +instance MonadFail EgisonM where+    fail = throwError . EgisonBug+ parallelMapM :: (a -> EgisonM b) -> [a] -> EgisonM [b] parallelMapM f [] = return [] parallelMapM f (x:xs) = do@@ -1691,8 +1750,8 @@   s <- get   (a, s') <- return $ runFresh s m   put s'-  return $ either throwError return a   -  +  return $ either throwError return a+ fromEgisonM :: EgisonM a -> IO (Either EgisonError a) fromEgisonM = modifyCounter . runEgisonM @@ -1708,9 +1767,9 @@ modifyCounter :: FreshT IO a -> IO a modifyCounter m = do   seed <- readCounter-  (result, seed) <- runFreshT seed m +  (result, seed) <- runFreshT seed m   updateCounter seed-  return result  +  return result  newtype FreshT m a = FreshT { unFreshT :: StateT (Int, Int) m a }   deriving (Functor, Applicative, Monad, MonadState (Int, Int), MonadTrans)@@ -1767,9 +1826,9 @@  data MList m a = MNil | MCons a (m (MList m a)) -instance Show (MList m a) where+instance Show a => Show (MList m a) where   show MNil = "MNil"-  show (MCons _ _) = "(MCons ... ...)"+  show (MCons x _) = "(MCons " ++ show x ++ " ...)"  fromList :: Monad m => [a] -> MList m a fromList = foldr f MNil@@ -1900,8 +1959,10 @@  varToVarWithIndices :: Var -> VarWithIndices varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is- where + where    f :: Index () -> Index String    f (Superscript ()) = Superscript ""    f (Subscript ()) = Subscript ""    f (SupSubscript ()) = SupSubscript ""++makeLenses ''MatchingStates

@@ -14,14 +14,15 @@ import Control.Monad.Except (liftIO)  import Language.Egison.Types-import Language.Egison.Parser+import Language.Egison.Parser as Parser+import Language.Egison.ParserNonS as ParserNonS  -- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExpr :: String -> InputT IO (Maybe (String, EgisonTopExpr))-getEgisonExpr prompt = getEgisonExpr' prompt ""+getEgisonExpr :: Bool -> String -> InputT IO (Maybe (String, EgisonTopExpr))+getEgisonExpr isSExpr prompt = getEgisonExpr' isSExpr prompt "" -getEgisonExpr' :: String -> String -> InputT IO (Maybe (String, EgisonTopExpr))-getEgisonExpr' prompt prev = do+getEgisonExpr' :: Bool -> String -> String -> InputT IO (Maybe (String, EgisonTopExpr))+getEgisonExpr' isSExpr prompt prev = do   mLine <- case prev of              "" -> getInputLine prompt              _ -> getInputLine $ take (length prompt) (repeat ' ')@@ -29,24 +30,24 @@     Nothing -> return Nothing     Just [] -> do       if null prev-        then getEgisonExpr prompt-        else getEgisonExpr' prompt prev+        then getEgisonExpr isSExpr prompt+        else getEgisonExpr' isSExpr prompt prev     Just line -> do       let input = prev ++ line-      case parseTopExpr input of+      case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of         Left err | show err =~ "unexpected end of input" -> do-          getEgisonExpr' prompt $ input ++ "\n"+          getEgisonExpr' isSExpr prompt $ input ++ "\n"         Left err -> do           liftIO $ putStrLn $ show err-          getEgisonExpr prompt+          getEgisonExpr isSExpr prompt         Right topExpr -> return $ Just (input, topExpr)  -- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExprOrNewLine :: String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))-getEgisonExprOrNewLine prompt = getEgisonExprOrNewLine' prompt ""+getEgisonExprOrNewLine :: Bool -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))+getEgisonExprOrNewLine isSExpr prompt = getEgisonExprOrNewLine' isSExpr prompt "" -getEgisonExprOrNewLine' :: String -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))-getEgisonExprOrNewLine' prompt prev = do+getEgisonExprOrNewLine' :: Bool -> String -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))+getEgisonExprOrNewLine' isSExpr prompt prev = do   mLine <- case prev of              "" -> getInputLine prompt              _ -> getInputLine $ take (length prompt) (repeat ' ')@@ -55,12 +56,12 @@     Just [] -> return $ Left $ Just ""     Just line -> do       let input = prev ++ line-      case parseTopExpr input of+      case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of         Left err | show err =~ "unexpected end of input" -> do-          getEgisonExprOrNewLine' prompt $ input ++ "\n"+          getEgisonExprOrNewLine' isSExpr prompt $ input ++ "\n"         Left err -> do           liftIO $ putStrLn $ show err-          getEgisonExprOrNewLine prompt+          getEgisonExprOrNewLine isSExpr prompt         Right topExpr -> return $ Right (input, topExpr)  -- |Complete Egison keywords

@@ -5,7 +5,7 @@ ;;;;;  (define $eq-  (matcher-dfs+  (matcher     {[,$val []       {[$tgt (if (eq? val tgt)                  {[]}

@@ -311,11 +311,9 @@  (define $find-cycle   (lambda [$xs]-    (car (concat (match-all xs (list something)-                   [<join $ys <cons $x _>>-                    (match-all ys (list something)-                      [<join $hs <cons ,x $ms>>-                       [hs {x @ms}]])])))))+    (car (match-all xs (list something)+           [<join $ys <join (& <cons _ _> $cs) <join ,cs _>>>+            [ys cs]]))))  (define $repeat   (lambda [%xs]

@@ -33,8 +33,9 @@ (define $fibs {1 1 @(map2 + fibs (cdr fibs))})  (define $prime?-  (lambda [$n]-    (eq? n (find-factor n))))+  (match-lambda integer+    {[?(lt? $ 2) #f]+     [$n (eq? n (find-factor n))]}))  (define $primes {2 @(filter prime? (drop 2 nats))}) 

@@ -1,6 +1,6 @@ ;;;;; ;;;;;-;;;;; String+;;;;; S.ring ;;;;; ;;;;; @@ -40,7 +40,7 @@      }))  ;;;-;;; String as collection+;;; S.ring as collection ;;; (define $S.empty?   (lambda [$xs]@@ -92,24 +92,24 @@ (define $S.replace   (lambda [$before $after $str]     (S.intercalate after (S.split before str))))-     + ;; ;; Alphabet ;;-(define $C.between+(define $c.between   (lambda [$c1 $c2]     (map itoc (between (ctoi c1) (ctoi c2))))) -(define $C.between?+(define $c.between?   (lambda [$c1 $c2 $c]     (and (gte? (ctoi c) (ctoi c1))          (lte? (ctoi c) (ctoi c2)))))  (define $alphabet?   (lambda [$c]-    (or (C.between? c#a c#z c)-        (C.between? c#A c#Z c))))+    (or (c.between? c#a c#z c)+        (c.between? c#A c#Z c))))  (define $alphabets?   (lambda [$s]@@ -117,12 +117,12 @@  (define $upper-case   (lambda [$c]-    (if (C.between? c#a c#z c)+    (if (c.between? c#a c#z c)       (itoc (- (ctoi c) 32))       c)))  (define $lower-case   (lambda [$c]-    (if (C.between? c#A c#Z c)+    (if (c.between? c#A c#Z c)       (itoc (+ (ctoi c) 32))       c)))

@@ -11,15 +11,32 @@ (define $*' (cambda $xs (foldl b.*' (car xs) (cdr xs)))) (define $/' b./') -(define $+ (cambda $xs (math-normalize1 (capply +' xs))))-(define $- (cambda $xs (math-normalize1 (capply -' xs))))-(define $* (cambda $xs (math-normalize1 (capply *' xs))))-(define $/ b./)+(define $f.+' (cambda $xs (foldl f.+ (car xs) (cdr xs))))+(define $f.-' (cambda $xs (foldl f.- (car xs) (cdr xs))))+(define $f.*' (cambda $xs (foldl f.* (car xs) (cdr xs))))+(define $f./' f./) -;(define $+ +')-;(define $- -')-;(define $* *')-;(define $/ b./')+(define $++  (cambda $xs (if (capply or (map float? xs))+                  (capply f.+' (map (lambda [$x] (if (float? x) x (itof x))) xs))+                  (math-normalize1 (capply +' xs)))))+(define $-+  (cambda $xs (if (capply or (map float? xs))+                  (capply f.-' (map (lambda [$x] (if (float? x) x (itof x))) xs))+                  (math-normalize1 (capply -' xs)))))+(define $*+  (cambda $xs (if (capply or (map float? xs))+                  (capply f.*' (map (lambda [$x] (if (float? x) x (itof x))) xs))+                  (math-normalize1 (capply *' xs)))))+(define $/+  (lambda [$x $y]+    (if (and (float? x) (float? y))+        (f./ x y)+        (if (float? x)+            (f./ x (itof y))+            (if (float? y)+                (f./ (itof x) y)+                (b./ x y))))))  (define $reduce-fraction id) 

@@ -39,7 +39,7 @@        [_ {}]}]      [<apply $ $> [eq (list math-expr)]       {[<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}>-             <Plus {<Term 1 {}> @{}}>> +             <Plus {<Term 1 {}> @{}}>>         {[v (map to-math-expr' mexprs)]}]        [_ {}]}]      [<quote $> [math-expr]@@ -281,7 +281,7 @@                                              [_ #f]})                                         xs))]}))                      {@ts1 @ts2})]}))))-  + (define $find-symbols-from-poly   (lambda [$poly]     (match-all poly math-expr@@ -301,7 +301,7 @@   (lambda [$x $a $mexpr]     (map-symbols (rewrite-symbol x a $) mexpr))) -(define $rewrite-symbol +(define $rewrite-symbol   (lambda [$x $a $sexpr]     (match sexpr symbol-expr       {[,x a]

@@ -0,0 +1,14 @@+(match (between 1 n) (multiset integer)+  {[<cons $x <cons ,x _>> "Matched"]+   [_ "Not matched"]})+; Returns "Not matched" in O(n^2).++(match (between 1 n) (multiset integer)+  {[<cons $x <cons ,x <cons ,x _>>> "Matched"]+   [_ "Not matched"]})+; Returns "Not matched" in O(n^2).++(match (between 1 n) (multiset integer)+  {[<cons $x <cons ,x <cons ,x <cons ,x _>>>> "Matched"]+   [_ "Not matched"]})+; Returns "Not matched" in O(n^2).

@@ -0,0 +1,85 @@+(define $x~ [| θ₁ θ₂ θ₃ θ₄ |])++(define $g__ +  [|[| 1 0 0 0 |]+    [| 0 1 0 0 |]+    [| 0 0 (/ κ (sqrt β)) (/ (* -1 θ₂ κ) (sqrt β))  |]+    [| 0 0 (/ (* -1 θ₂ κ) (sqrt β)) (/ (* '(+ 1 θ₂) κ) (sqrt β)) |]|])++;(define $g~~ (M.inverse g_#_#))+(define $g~~+  [|[| 1 0 0 0 |]+    [| 0 1 0 0 |]+    [| 0 0 (/ '(+ 1 θ₂) (* κ (sqrt β))) (/ θ₂ (* (sqrt β) κ)) |]+    [| 0 0 (/ θ₂ (* (sqrt β) κ)) (/ 1 (* (sqrt β) κ)) |]|])++(define $β '(+ 1 θ₂ (* -1 (** θ₂ 2))))+;(define $β (function [θ₂]))++(define $Γ~c_a_b+  (. (/ 1 2)+     g~c~e+     (+ (∂/∂ g_b_e x~a)+        (∂/∂ g_a_e x~b)+        (* -1 (∂/∂ g_a_b x~e)))))+Γ~1_#_#+Γ~2_#_#++(define $R_i_j_k~l+  (with-symbols {a}+    (+ (- (∂/∂ Γ~l_j_k x~i) (∂/∂ Γ~l_i_k x~j))+       (- (. Γ~l_i_a Γ~a_j_k) (. Γ~l_j_a Γ~a_i_k)))))++(define $J__+  [|[| 0 1 0 0 |]+    [| -1 0 0 0 |]+    [| 0 0 0 κ |]+    [| 0 0 (* -1 κ) 0 |]|])++(define $J_a~c (. J_a_b g~b~c))++(define $∇J_a_b_m+  (with-symbols {n}+    (- (∂/∂ J_a_b x~m)+       (. Γ~n_m_a J_n_b)+       (. Γ~n_m_b J_a_n))))++(define $∇J_a_b~c+  (with-symbols {n}+    (. ∇J_a_b_m g~m~c)))++(define $δ+  (generate-tensor+    (match-lambda [integer integer]+      {[[$n ,n] 1]+       [[_ _] 0]})+    {5 5}))++(define $R'___~+  (generate-tensor+    (match-lambda [integer integer integer integer]+      {+       [[,1 ,1 _ _] 0]+       [[_ _ ,1 ,1] 0]+       [[,1 $b ,1 $d] (* -1 p^2 δ~(- b 1)_(- d 1))]+       [[$a ,1 ,1 $d] (*    p^2 δ~(- a 1)_(- d 1))] ; complemented by Egi+       [[,1 $b $c ,1] (* -1 p^2 g_(- b 1)_(- c 1))]+       [[$a ,1 $c ,1] (*    p^2 g_(- a 1)_(- c 1))] ; complemented by Egi+       [[,1 $b $c $d] (* -1 p ∇J_(- b 1)_(- c 1)_(- d 1))]+       [[$a ,1 $c $d] (*    p ∇J_(- a 1)_(- c 1)~(- d 1))] ; complemented by Egi+       [[$a $b ,1 $d] (* -1 p ∇J_(- a 1)_(- b 1)~(- d 1))]+       [[$a $b $c ,1] (* p ∇J_(- a 1)_(- b 1)_(- c 1))]+       [[$a $b $c $d] (+ R_(- a 1)_(- b 1)_(- c 1)~(- d 1)+                         (* -1 p^2 J_(- b 1)_(- c 1) J_(- a 1)~(- d 1))+                         (*    p^2 J_(- a 1)_(- c 1) J_(- b 1)~(- d 1))+                         (* 2  p^2 J_(- a 1)_(- b 1) J_(- c 1)~(- d 1)))]+       })+    {5 5 5 5}))++(define $S+  (with-symbols {i j k}+    (let {[[$es $os] (even-and-odd-permutations 5)]}+      (- (sum (map (lambda [$σ] (debug (. R'_(σ 1)_j_1~i R'_(σ 2)_(σ 3)_k~j R'_(σ 4)_(σ 5)_i~k))) es))+         (sum (map (lambda [$σ] (debug (. R'_(σ 1)_j_1~i R'_(σ 2)_(σ 3)_k~j R'_(σ 4)_(σ 5)_i~k))) os))))))++S

@@ -0,0 +1,54 @@+(define $N 3)++(define $J+  (generate-tensor+    (match-lambda [integer integer]+      {[[$i ,(+ i (* 2 N))] 1]+       [[$i ,(- i (* 2 N))] -1]+       [[_ _] 0]})+    {(* 4 N) (* 4 N)}))++J++(define $δ+  (generate-tensor+    (match-lambda [integer integer]+      {[[$n ,n] 1]+       [[_ _] 0]})+    {(* 4 N) (* 4 N)}))++δ++(define $g δ)++g++(define $T_a_b_c~d+  (+ (* -1 (. J_b_c J_a~d))+     (. J_a_c J_b~d)+     (* 2 (. J_a_b J_c~d))))++T_1_1_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~#+T_1_2_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 1 |] [| 0 0 -1 0 |] |]_#~#+T_1_3_#~#;[| [| 0 0 3 0 |] [| 0 0 0 2 |] [| -3 0 0 0 |] [| 0 -2 0 0 |] |]_#~#+T_1_4_#~#;[| [| 0 0 0 0 |] [| 0 0 1 0 |] [| 0 -1 0 0 |] [| 0 0 0 0 |] |]_#~#+T_2_1_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 -1 |] [| 0 0 1 0 |] |]_#~#+T_2_2_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~#+T_2_3_#~#;[| [| 0 0 0 1 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| -1 0 0 0 |] |]_#~#+T_2_4_#~#;[| [| 0 0 2 0 |] [| 0 0 0 3 |] [| -2 0 0 0 |] [| 0 -3 0 0 |] |]_#~#+T_3_1_#~#;[| [| 0 0 -3 0 |] [| 0 0 0 -2 |] [| 3 0 0 0 |] [| 0 2 0 0 |] |]_#~#+T_3_2_#~#;[| [| 0 0 0 -1 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 1 0 0 0 |] |]_#~#+T_3_3_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~#+T_3_4_#~#;[| [| 0 1 0 0 |] [| -1 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~#+T_4_1_#~#;[| [| 0 0 0 0 |] [| 0 0 -1 0 |] [| 0 1 0 0 |] [| 0 0 0 0 |] |]_#~#+T_4_2_#~#;[| [| 0 0 -2 0 |] [| 0 0 0 -3 |] [| 2 0 0 0 |] [| 0 3 0 0 |] |]_#~#+T_4_3_#~#;[| [| 0 -1 0 0 |] [| 1 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~#+T_4_4_#~#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#~#++(define $S'+  (with-symbols {i j k}+    (let {[[$es $os] (even-and-odd-permutations (* 4 N))]}+      (- (sum (map (lambda [$σ] (let {[$x (debug [0 (map 1#(σ %1) (between 1 (* 4 N))) (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k (* 2 N))]~[a_(- k 1)]) (between 1 (* 2 N))))])]} (3#%3 x))) es))+         (sum (map (lambda [$σ] (let {[$x (debug [1 (map 1#(σ %1) (between 1 (* 4 N))) (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k (* 2 N))]~[a_(- k 1)]) (between 1 (* 2 N))))])]} (3#%3 x))) os))))))++S'

@@ -0,0 +1,37 @@+(define $N 3)++(define $J+  (generate-tensor+    (match-lambda [integer integer]+      {[[$i ,(+ i N)] 1]+       [[$i ,(- i N)] -1]+       [[_ _] 0]})+    {(* 2 N) (* 2 N)}))++J++(define $δ+  (generate-tensor+    (match-lambda [integer integer]+      {[[$n ,n] 1]+       [[_ _] 0]})+    {(* 2 N) (* 2 N)}))++δ++(define $g δ)++g++(define $T_a_b_c~d+  (+ (* -1 (. J_b_c J_a~d))+     (. J_a_c J_b~d)+     (* 2 (. J_a_b J_c~d))))++(define $S'+  (with-symbols {i j k}+    (let {[[$es $os] (even-and-odd-permutations (* 2 N))]}+      (- (sum (map (lambda [$σ] (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k N)]~[a_(- k 1)]) (between 1 N)))) es))+         (sum (map (lambda [$σ] (foldl . 1 (map (lambda [$k] T_(σ (- (* 2 k) 1))_(σ (* 2 k))_[a_(modulo k N)]~[a_(- k 1)]) (between 1 N)))) os))))))++S'

@@ -17,7 +17,7 @@ e_i_j ;[|[|(* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |] ;  [|(* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]-;  |]_#_#+;  |]_i_j  ;; ;; Metric tensor

@@ -39,7 +39,7 @@               <nil>>>>>>>>>      a])) -(test eight-queen)+;(test eight-queen)  (define $n-queen   (lambda [$n]@@ -55,4 +55,7 @@                    <nil>)>       a]))) -(test (n-queen 4))+(test (n-queen 8))+(test (n-queen 9))+(test (n-queen 10))+(test (n-queen 11))

@@ -0,0 +1,16 @@+(define $nishiwaki-if+  (macro [$b $e1 $e2]+    (car (match-all b (matcher {[$ something {[#t {e1}] [#f {e2}]}]})+           [$x x]))))++(nishiwaki-if #t 1 2) ; 1++(nishiwaki-if #f 1 2) ; 2++(nishiwaki-if (eq? 1 1) 1 2) ; 1++(io (nishiwaki-if #t (print "OK") (print "NG"))) ; print "OK"++(io (nishiwaki-if #f (print "NG") (print "OK"))) ; print "OK"++(io (nishiwaki-if (eq? 1 1) (print "OK") (print "NG"))) ; print "OK"

@@ -27,63 +27,63 @@            <cons <card ,s ,(- n 3)>             <cons <card ,s ,(- n 4)>              <nil>>>>>>-        <Straight-Flush>]+        "Straight flush"]        [<cons <card _ $n>          <cons <card _ ,n>           <cons <card _ ,n>             <cons <card _ ,n>               <cons _                 <nil>>>>>>-        <Four-of-Kind>]+        "Four of a kind"]        [<cons <card _ $m>          <cons <card _ ,m>           <cons <card _ ,m>            <cons <card _ $n>             <cons <card _ ,n>               <nil>>>>>>-        <Full-House>]+        "Full house"]        [<cons <card $s _>          <cons <card ,s _>            <cons <card ,s _>              <cons <card ,s _>                <cons <card ,s _>                  <nil>>>>>>-        <Flush>]+        "Flush"]        [<cons <card _ $n>          <cons <card _ ,(- n 1)>           <cons <card _ ,(- n 2)>            <cons <card _ ,(- n 3)>             <cons <card _ ,(- n 4)>              <nil>>>>>>-        <Straight>]+        "Straight"]        [<cons <card _ $n>          <cons <card _ ,n>           <cons <card _ ,n>            <cons _             <cons _              <nil>>>>>>-        <Three-of-Kind>]+        "Three of a kind"]        [<cons <card _ $m>          <cons <card _ ,m>           <cons <card _ $n>             <cons <card _ ,n>              <cons _                <nil>>>>>>-        <Two-Pair>]+        "Two pair"]        [<cons <card _ $n>          <cons <card _ ,n>           <cons _            <cons _             <cons _              <nil>>>>>>-        <One-Pair>]+        "One pair"]        [<cons _          <cons _           <cons _            <cons _             <cons _              <nil>>>>>>-        <Nothing>]})))+        "Nothing"]})))  ;; ;; Demonstration code

@@ -0,0 +1,18 @@+(define $combs+  (lambda [$xs]+    (match-all xs (multiset something)+      [<cons $x_1+             (loop $i [2 $n]+               <cons $x_i ...>+               _)>+       (map 1#x_%1 (between 1 n))])))++(define $p?+  (lambda [$xs]+    (match xs (list integer)+      {[,{1} #f]+       [_ (prime? (read (S.concat (map show xs))))]})))++(define $main+  (lambda [$args]+    (each (compose show print) (filter p? (combs (map read args))))))

@@ -15,15 +15,31 @@ import Language.Egison.Types import Language.Egison.Core import Language.Egison.Primitives+import Language.Egison.Parser import Language.Egison -import UnitTest- main = do-  unitTestCases <- glob "test/[^answer]**/*.egi"-  sampleTestCases <- glob "test/answer/**/*.egi"+  (sampleTestCases, unitTestCases) <- partition (isSubsequenceOf "answer" . show) <$> glob "test/**/*.egi"   defaultMain $ hUnitTestToTests $ test $ map runUnitTestCase unitTestCases ++ map runSampleTestCase sampleTestCases +runUnitTestCase :: FilePath -> Test+runUnitTestCase file = TestLabel file . TestCase $ do+  env <- initialEnv+  assertEgisonM $ do+    exprs <- loadFile file+    let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs+    env' <- recursiveBind env bindings+    forM_ tests $ evalExprDeep env'+      where+        assertEgisonM :: EgisonM a -> Assertion+        assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")++        collectDefsAndTests (Define name expr) (bindings, tests) =+          ((name, expr) : bindings, tests)+        collectDefsAndTests (Test expr) (bindings, tests) =+          (bindings, expr : tests)+        collectDefsAndTests _ r = r+ runSampleTestCase :: FilePath -> Test runSampleTestCase file = TestLabel file . TestCase $ do   env <- initialEnv@@ -38,7 +54,7 @@       where         assertEgisonM :: [String] -> EgisonM [(EgisonExpr, EgisonValue)] -> Assertion         assertEgisonM answers m = fromEgisonM m >>= assertString . either show (f answers)-    +         collectDefsAndTests (Define name expr) (bindings, tests) =           ((name, expr) : bindings, tests)         collectDefsAndTests (Test expr) (bindings, tests) =@@ -52,3 +68,4 @@                      then (if i < (length y - 1) then g x y (i + 1)                                                  else "")                      else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ show (v !! i)+

@@ -1,30 +0,0 @@-module UnitTest ( runUnitTestCase ) where--import Control.Applicative-import Control.Monad-import Data.IORef--import Test.HUnit--import Language.Egison.Types-import Language.Egison.Core-import Language.Egison.Primitives-import Language.Egison--runUnitTestCase :: FilePath -> Test-runUnitTestCase file = TestLabel file . TestCase $ do-  env <- initialEnv-  assertEgisonM $ do-    exprs <- loadFile file-    let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs-    env' <- recursiveBind env bindings-    forM_ tests $ evalExprDeep env'-      where-        assertEgisonM :: EgisonM a -> Assertion-        assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")-    -        collectDefsAndTests (Define name expr) (bindings, tests) =-          ((name, expr) : bindings, tests)-        collectDefsAndTests (Test expr) (bindings, tests) =-          (bindings, expr : tests)-        collectDefsAndTests _ r = r