egison 3.7.14 → 3.8.0

raw patch · 20 files changed

+1321/−1461 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• egison.cabal +1/−1
• hs-src/Interpreter/egison.hs +83/−76
• hs-src/Language/Egison.hs +12/−10
• hs-src/Language/Egison/Core.hs +370/−398
• hs-src/Language/Egison/Desugar.hs +65/−81
• hs-src/Language/Egison/MathOutput.hs +129/−122
• hs-src/Language/Egison/Parser.hs +154/−154
• hs-src/Language/Egison/ParserNonS.hs +101/−114
• hs-src/Language/Egison/Primitives.hs +41/−40
• hs-src/Language/Egison/Types.hs +209/−238
• hs-src/Language/Egison/Util.hs +45/−46
• lib/core/order.egi +4/−4
• lib/math/algebra/matrix.egi +6/−0
• lib/math/algebra/tensor.egi +1/−1
• sample/dp.egi +43/−0
• sample/math/geometry/ThurstonManifold.egi +0/−85
• sample/math/geometry/ThurstonManifold2.egi +0/−54
• sample/math/geometry/ThurstonManifold3.egi +0/−37
• sample/order.egi +23/−0
• sample/salesman2.egi +34/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.7.14+Version:             3.8.0 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.

@@ -1,26 +1,32 @@+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE TupleSections #-}+ module Main where -import Prelude hiding (catch)-import Control.Exception ( AsyncException(..), catch )-import Control.Monad.Except+import           Control.Exception          (AsyncException (..), catch)+import           Control.Monad.Except+import           Control.Monad.Trans.State+import           Prelude                    hiding (catch) -import qualified Data.Text as T-import Data.Char-import Data.List (intercalate)+import           Data.Char+import           Data.List                  (intercalate)+import qualified Data.Text                  as T -import Data.Version+import           Data.Version -import System.Environment-import System.Directory (getHomeDirectory)-import System.FilePath ((</>))-import System.Console.Haskeline hiding (handle, catch, throwTo)-import System.Console.GetOpt-import System.Exit (ExitCode (..), exitWith, exitFailure)-import System.IO+import           System.Console.GetOpt+import           System.Console.Haskeline   hiding (catch, handle, throwTo)+import           System.Directory           (getHomeDirectory)+import           System.Environment+import           System.Exit                (ExitCode (..), exitFailure,+                                             exitSuccess)+import           System.FilePath            ((</>))+import           System.IO -import Language.Egison-import Language.Egison.Util-import Language.Egison.MathOutput+import           Language.Egison+import           Language.Egison.Core       (recursiveBind)+import           Language.Egison.MathOutput+import           Language.Egison.Util  main :: IO () main = do args <- getArgs@@ -31,36 +37,36 @@             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, optSExpr = isSExpr} -> do               coreEnv <- if noIOFlag then initialEnvNoIO else initialEnv-              mEnv <- evalEgisonTopExprs coreEnv $ (map (Load isSExpr) loadLibs) ++ (map (LoadFile isSExpr) loadFiles)+              mEnv <- evalEgisonTopExprs coreEnv $ map (Load isSExpr) loadLibs ++ map (LoadFile isSExpr) loadFiles               case mEnv of-                Left err -> putStrLn $ show err-                Right env -> do+                Left err -> print err+                Right env ->                   case mExpr of                     Just expr ->                       if tsvFlag-                        then do ret <- runEgisonTopExprs isSExpr 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 ()+                                  Left err -> hPrint stderr err+                                  Right _  -> return ()                         else do ret <- runEgisonExpr isSExpr env expr                                 case ret of-                                  Left err -> hPutStrLn stderr (show err) >> exitFailure-                                  Right val -> putStrLn (show val) >> exitWith ExitSuccess+                                  Left err -> hPrint stderr err >> exitFailure+                                  Right val -> print val >> exitSuccess                     Nothing ->                       case mCmd of                         Just cmd -> do cmdRet <- runEgisonTopExpr isSExpr env ("(execute " ++ cmd ++ ")")                                        case cmdRet of-                                         Left err -> putStrLn (show err) >> exitFailure-                                         _ -> exitWith ExitSuccess+                                         Left err -> print err >> exitFailure+                                         _        -> exitSuccess                         Nothing ->                           case mSub of-                            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))))")+                            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 {" ++ unwords (map fst fieldInfo) ++  "} {" ++ unwords (map snd fieldInfo) ++  "})]} (" ++ sub ++ " SH.input))))")                                            case cmdRet of-                                             Left err -> putStrLn (show err) >> exitFailure-                                             _ -> exitWith ExitSuccess+                                             Left err -> print err >> exitFailure+                                             _ -> exitSuccess                             Nothing ->                               case nonOpts of-                                [] -> when bannerFlag showBanner >> repl noIOFlag isSExpr mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess+                                [] -> when bannerFlag showBanner >> repl noIOFlag isSExpr mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitSuccess                                 (file:args) ->                                   case opts of                                     Options {optTestOnly = True} -> do@@ -70,25 +76,25 @@                                                   else evalEgisonTopExprsTestOnly env [LoadFile isSExpr file]                                       either print (const $ return ()) result                                     Options {optTestOnly = False} -> do-                                      result <- evalEgisonTopExprs env [LoadFile isSExpr 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) . T.pack) args)))]                                       either print (const $ return ()) result  data Options = Options {-    optShowVersion :: Bool,-    optShowHelp :: Bool,-    optEvalString :: Maybe String,-    optExecuteString :: Maybe String,+    optShowVersion      :: Bool,+    optShowHelp         :: Bool,+    optEvalString       :: Maybe String,+    optExecuteString    :: Maybe String,     optSubstituteString :: Maybe String,-    optFieldInfo :: [(String, String)],-    optLoadLibs :: [String],-    optLoadFiles :: [String],-    optTsvOutput :: Bool,-    optNoIO :: Bool,-    optShowBanner :: Bool,-    optTestOnly :: Bool,-    optPrompt :: String,-    optMathExpr :: Maybe String,-    optSExpr :: Bool+    optFieldInfo        :: [(String, String)],+    optLoadLibs         :: [String],+    optLoadFiles        :: [String],+    optTsvOutput        :: Bool,+    optNoIO             :: Bool,+    optShowBanner       :: Bool,+    optTestOnly         :: Bool,+    optPrompt           :: String,+    optMathExpr         :: Maybe String,+    optSExpr            :: Bool     }  defaultOptions :: Options@@ -163,13 +169,13 @@     (NoArg (\opts -> opts {optTsvOutput = True}))     "output in tsv format",   Option ['F'] ["--field"]-    (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [(readFieldOption d)]})+    (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [readFieldOption d]})             "String")     "field information",   Option ['M'] ["math"]     (ReqArg (\lang opts -> opts {optMathExpr = Just lang})             "String")-    "output in AsciiMath, Latex, or Mathematica format",+    "output in AsciiMath, Latex, Mathematica, or Maxima format",   Option ['N'] ["new-syntax"]     (NoArg (\opts -> opts {optSExpr = False}))     "parse by new syntax"@@ -222,14 +228,14 @@   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 "  --math, -M (asciimath|latex|mathematica|maxima)"   putStrLn "                             Output in AsciiMath, LaTeX, or Mathematica format (only for interpreter)"-  exitWith ExitSuccess+  exitSuccess  printVersionNumber :: IO () printVersionNumber = do   putStrLn $ showVersion version-  exitWith ExitSuccess+  exitSuccess  showBanner :: IO () showBanner = do@@ -242,47 +248,48 @@ --  putStrLn $ "*****************"  showByebyeMessage :: IO ()-showByebyeMessage = putStrLn $ "Leaving Egison Interpreter."+showByebyeMessage = putStrLn "Leaving Egison Interpreter." -repl :: Bool -> Bool -> (Maybe String) -> Env -> String -> IO ()-repl noIOFlag isSExpr mathExprLang env prompt = do-  loop env+repl :: Bool -> Bool -> Maybe String -> Env -> String -> IO ()+repl noIOFlag isSExpr mathExprLang env prompt =+  loop $ StateT (\defines -> (, defines) <$> recursiveBind env defines)  where   settings :: MonadIO m => FilePath -> Settings m   settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history") } -  loop :: Env -> IO ()-  loop env = (do+  loop :: StateT [(Var, EgisonExpr)] EgisonM Env -> IO ()+  loop st = (do     home <- getHomeDirectory     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+        loop st+      (True, Just (_, Load _ _)) -> do         putStrLn "error: No IO support"-        loop env+        loop st       (_, Just (topExpr, _)) -> do-        result <- liftIO $ runEgisonTopExpr' isSExpr env topExpr+        result <- liftIO $ runEgisonTopExpr' isSExpr st topExpr         case result of           Left err -> do-            liftIO $ putStrLn $ show err-            loop env-          Right (Nothing, env') -> loop env'-          Right (Just output, env') ->+            liftIO $ print err+            loop st+          Right (Nothing, st') -> loop st'+          Right (Just output, st') ->             case mathExprLang of-              Nothing -> putStrLn output >> loop env'-              (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'+              Nothing -> putStrLn output >> loop st'+              (Just "haskell") -> putStrLn (mathExprToHaskell output) >> loop st'+              (Just "asciimath") -> putStrLn (mathExprToAsciiMath output) >> loop st'+              (Just "latex") -> putStrLn (mathExprToLatex output) >> loop st'+              (Just "mathematica") -> putStrLn (mathExprToMathematica output) >> loop st'+              (Just "maxima") -> putStrLn (mathExprToMaxima output) >> loop st'               _ -> putStrLn "error: this output lang is not supported"              )     `catch`-    (\e -> case e of-             UserInterrupt -> putStrLn "" >> loop env-             StackOverflow -> putStrLn "Stack over flow!" >> loop env-             HeapOverflow -> putStrLn "Heap over flow!" >> loop env-             _ -> putStrLn "error!" >> loop env+    (\case+        UserInterrupt -> putStrLn "" >> loop st+        StackOverflow -> putStrLn "Stack over flow!" >> loop st+        HeapOverflow  -> putStrLn "Heap over flow!" >> loop st+        _             -> putStrLn "error!" >> loop st      )

@@ -29,15 +29,17 @@        , version        ) where -import Data.Version-import qualified Paths_egison as P+import           Data.Version+import qualified Paths_egison               as P -import Language.Egison.Types-import Language.Egison.Parser as Parser-import Language.Egison.ParserNonS as ParserNonS-import Language.Egison.Primitives-import Language.Egison.Core+import           Language.Egison.Core+import           Language.Egison.Parser     as Parser+import           Language.Egison.ParserNonS as ParserNonS+import           Language.Egison.Primitives+import           Language.Egison.Types +import           Control.Monad.State+ -- |Version number version :: Version version = P.version@@ -69,9 +71,9 @@ runEgisonTopExpr False env input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr env  -- |eval an Egison top expression. Input is a Haskell string.-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+runEgisonTopExpr' :: Bool -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env))+runEgisonTopExpr' True st input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' st+runEgisonTopExpr' False st input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' st  -- |eval Egison top expressions. Input is a Haskell string. runEgisonTopExprs :: Bool -> Env -> String -> IO (Either EgisonError Env)

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase      #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections   #-} {-# LANGUAGE ViewPatterns    #-}@@ -42,38 +43,41 @@     , packStringValue     ) where -import           Prelude                   hiding (mapM, mappend, mconcat)+import           Prelude                    hiding (mapM, mappend, mconcat)  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.Lens               (makeLenses, (%~), (&), (.~), (^.))+import           Control.Monad              (when)+import           Control.Monad.Except       hiding (mapM)+import           Control.Monad.State        hiding (mapM) import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.State  (evalStateT, withStateT) -import           Data.Foldable             (toList)+import           Data.Foldable              (toList) import           Data.IORef-import           Data.List                 (last, partition, nub, drop, any)-import           Data.List.Split           (oneOf, split)+import           Data.List                  (any, drop, last, nub, partition)+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           Data.Sequence              (Seq, ViewL (..), ViewR (..), (><))+import qualified Data.Sequence              as Sq+import           Data.Traversable           (mapM) -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.Array                 ((!))+import qualified Data.Array                 as Array+import qualified Data.HashMap.Lazy          as HL+import           Data.HashMap.Strict        (HashMap)+import qualified Data.HashMap.Strict        as HashMap+import           Data.Map                   (Map, assocs, empty, singleton,+                                             unionWith, unionsWith, (!))+import qualified Data.Map                   as M+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.Parser as Parser+import           Language.Egison.Parser     as Parser import           Language.Egison.ParserNonS as ParserNonS import           Language.Egison.Types @@ -87,21 +91,21 @@   env <- recursiveBind env bindings   forM_ rest $ evalTopExpr env   return env- where-  collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])-  collectDefs (expr:exprs) bindings rest =-    case expr of-      Define name expr -> collectDefs exprs ((name, expr) : bindings) rest-      Load b file -> do-        exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file-        collectDefs (exprs' ++ exprs) bindings rest-      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-  collectDefs [] bindings rest = return (bindings, reverse rest) +collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])+collectDefs (expr:exprs) bindings rest =+  case expr of+    Define name expr -> collectDefs exprs ((name, expr) : bindings) rest+    Load b file -> do+      exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file+      collectDefs (exprs' ++ exprs) bindings rest+    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+collectDefs [] bindings rest = return (bindings, reverse rest)+ evalTopExprsTestOnly :: Env -> [EgisonTopExpr] -> EgisonM Env evalTopExprsTestOnly env exprs = do   (bindings, rest) <- collectDefs exprs [] []@@ -135,32 +139,38 @@   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"+      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+  ret <- evalTopExpr' (StateT $ \defines -> (, defines) <$> recursiveBind env defines) topExpr   case fst ret of     Nothing     -> return ()     Just output -> liftIO $ putStrLn output-  return $ snd ret+  evalStateT (snd ret) [] -evalTopExpr' :: Env -> EgisonTopExpr -> EgisonM (Maybe String, Env)-evalTopExpr' env (Define name expr) = recursiveBind env [(name, expr)] >>= return . ((,) Nothing)-evalTopExpr' env (Redefine name expr) = recursiveRebind env (name, expr) >>= return . ((,) Nothing)-evalTopExpr' env (Test expr) = do-  val <- evalExprDeep env expr-  return (Just (show val), env)-evalTopExpr' env (Execute expr) = do-  io <- evalExpr env expr+evalTopExpr' :: StateT [(Var, EgisonExpr)] EgisonM Env -> EgisonTopExpr -> EgisonM (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env)+evalTopExpr' st (Define name expr) = return (Nothing, withStateT (\defines -> (name, expr):defines) st)+evalTopExpr' st (Redefine name expr) = return (Nothing, mapStateT (>>= \(env, defines) -> (, defines) <$> recursiveRebind env (name, expr)) st)+evalTopExpr' st (Test expr) = do+  val <- evalStateT st [] >>= flip evalExprDeep expr+  return (Just (show val), st)+evalTopExpr' st (Execute expr) = do+  io <- evalStateT st [] >>= flip evalExpr expr   case io of-    Value (IOFunc m) -> m >> return (Nothing, env)+    Value (IOFunc m) -> m >> return (Nothing, st)     _                -> 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)+evalTopExpr' st (Load b file) = do+  exprs <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file+  (bindings, _) <- collectDefs exprs [] []+  return (Nothing, withStateT (\defines -> bindings ++ defines) st)+evalTopExpr' st (LoadFile b file) = do+  exprs <- if b then Parser.loadFile file else ParserNonS.loadFile file+  (bindings, _) <- collectDefs exprs [] []+  return (Nothing, withStateT (\defines -> bindings ++ defines) st)  evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c@@ -173,13 +183,13 @@   whnf <- evalExpr env expr   case whnf of     Value (ScalarData s) -> return . Value $ ScalarData $ Div (Plus [Term 1 [(Quote s, 1)]]) (Plus [Term 1 []])-    _ -> throwError $ TypeMismatch "scalar in quote" $ whnf+    _ -> throwError $ TypeMismatch "scalar in quote" whnf  evalExpr env (QuoteSymbolExpr expr) = do   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@@ -219,26 +229,26 @@   refs' <- mapM (newObjectRef env) exprs   return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs' -evalExpr env (VectorExpr exprs) = do-  whnfs <- mapM (evalExpr env) exprs+evalExpr env@(Env frame maybe_vwi) (VectorExpr exprs) = do+  whnfs <- mapM (\(expr, i) ->+            let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList [toEgison $ toInteger i]) maybe_vwi in+            evalExpr env' expr) $ zip exprs [1..(length exprs + 1)]   case whnfs of-    ((Intermediate (ITensor (Tensor _ _ _))):_) -> do-      ret <- mapM toTensor (map f $ zip whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor-      return ret+    (Intermediate (ITensor Tensor{}):_) ->+      mapM toTensor (zipWith (curry f) whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor     _ -> 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 (Intermediate (ITensor (Tensor ns xs indices)), i) =+    Intermediate $ ITensor $ Tensor ns (V.fromList $ zipWith (curry g) (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' = maybe fn (\(VarWithIndices nameString indexList) -> Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi 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-  ns <- ((fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer])+  ns <- (fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer]   xsWhnf <- evalExpr env xsExpr   xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef   supWhnf <- evalExpr env supExpr@@ -247,7 +257,7 @@   sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar'   if product ns == toInteger (length xs)     then fromTensor (initTensor ns xs sup sub)-    else throwError $ InconsistentTensorSize+    else throwError InconsistentTensorSize  evalExpr env (HashExpr assocs) = do   let (keyExprs, exprs) = unzip assocs@@ -256,86 +266,86 @@   refs <- mapM (newObjectRef env) exprs   case keys of     [] -> do-      let keys' = map (\key -> case key of IntKey i -> i) keys+      let keys' = map (\case IntKey i -> i) keys       return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs     _ ->      case head keys of        IntKey _ -> do-         let keys' = map (\key -> case key of IntKey i -> i) keys+         let keys' = map (\ case IntKey i -> i) keys          return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs        CharKey _ -> do-         let keys' = map (\key -> case key of CharKey c -> c) keys+         let keys' = map (\case CharKey c -> c) keys          return . Intermediate . ICharHash $ HL.fromList $ zip keys' refs        StrKey _ -> do-          let keys' = map (\key -> case key of StrKey s -> s) keys+          let keys' = map (\case StrKey s -> s) keys           return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs  where   makeHashKey :: WHNFData -> EgisonM EgisonHashKey   makeHashKey (Value val) =     case val of-      ScalarData _ -> fromEgison val >>= (return . IntKey)+      ScalarData _ -> IntKey <$> fromEgison val       Char c -> return (CharKey c)       String str -> return (StrKey str)       _ -> throwError $ TypeMismatch "integer or string" $ Value val-  makeHashKey whnf = throwError $ TypeMismatch "integer or string" $ whnf+  makeHashKey whnf = throwError $ TypeMismatch "integer or string" whnf  evalExpr env (IndexedExpr bool expr indices) = do   tensor <- case expr of               VarExpr (Var xs is) -> do-                let mObjRef = refVar env (Var xs $ is ++ (map f indices))+                let mObjRef = refVar env (Var xs $ is ++ map f indices)                 case mObjRef of                   (Just objRef) -> evalRef objRef                   Nothing       -> evalExpr env expr               _ -> evalExpr env expr-  js <- mapM (\i -> case i of-                      Superscript n -> evalExprDeep env n >>= return . Superscript-                      Subscript n -> evalExprDeep env n >>= return . Subscript-                      SupSubscript n -> evalExprDeep env n >>= return . SupSubscript-                      Userscript n -> evalExprDeep env n >>= return . Userscript+  js <- mapM (\case+                 Superscript n -> Superscript <$> evalExprDeep env n+                 Subscript n -> Subscript <$> evalExprDeep env n+                 SupSubscript n -> SupSubscript <$> evalExprDeep env n+                 Userscript n -> Userscript <$> evalExprDeep env n               ) 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-                             Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript-                             Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript-                             SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript-                             Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript+      (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])))) -> do+        js2 <- mapM (\case+                        Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar)+                        Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar)+                        SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)+                        Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar)                     ) indices-        return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name js2, 1)])]) (Plus [(Term 1 [])])))-      (Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name js', 1)])]) (Plus [(Term 1 [])])))) -> do-        js2 <- mapM (\i -> case i of-                             Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript-                             Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript-                             SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript-                             Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript+        return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js2, 1)]]) (Plus [Term 1 []])))+      (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js', 1)]]) (Plus [Term 1 []])))) -> do+        js2 <- mapM (\case+                        Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar)+                        Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar)+                        SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)+                        Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar)                     ) indices-        return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name (js' ++ js2), 1)])]) (Plus [(Term 1 [])])))-      (Value (TensorData (Tensor ns xs is))) -> do-        if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value-                else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value-      (Intermediate (ITensor (Tensor ns xs is))) -> do+        return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (js' ++ js2), 1)]]) (Plus [Term 1 []])))+      (Value (TensorData (Tensor ns xs is))) ->+        if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)+                else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)+      (Intermediate (ITensor (Tensor ns xs is))) ->         if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor                 else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor       _ -> do-        js2 <- mapM (\i -> case i of-                             Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript-                             Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript-                             SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript-                             Userscript n -> evalExprDeep env n >>= extractScalar >>= return . Userscript+        js2 <- mapM (\case+                        Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar)+                        Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar)+                        SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)+                        Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar)                     ) indices-        refArray tensor (map (\j -> case j of-                                      Superscript k  -> ScalarData k-                                      Subscript k    -> ScalarData k-                                      SupSubscript k -> ScalarData k-                                      Userscript k   -> ScalarData k+        refArray tensor (map (\case+                                 Superscript k  -> ScalarData k+                                 Subscript k    -> ScalarData k+                                 SupSubscript k -> ScalarData k+                                 Userscript k   -> ScalarData k                               ) js2)   let ret2 = case expr of-               (VarExpr var) -> do+               (VarExpr var) ->                  case ret of                    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 var ++ concat (map show indices)) argnames args js, 1)]]) p)+                       Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show var ++ concatMap show indices) argnames args js, 1)]]) p)                        Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)                    _ -> ret                _ -> ret@@ -348,25 +358,24 @@   f (Userscript _)   = Userscript ()  evalExpr env (SubrefsExpr bool expr jsExpr) = do-  js <- evalExpr env jsExpr >>= collectionToList >>= return . (map Subscript)+  js <- map Subscript <$> (evalExpr env jsExpr >>= collectionToList)   tensor <- case expr of               VarExpr (Var xs is) -> do-                let mObjRef = refVar env (Var xs $ is ++ (take (length js) (repeat (Subscript ()))))+                let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Subscript ()))                 case mObjRef of                   (Just objRef) -> evalRef objRef                   Nothing       -> evalExpr env expr               _ -> evalExpr env expr-  ret <- case tensor of-      (Value (ScalarData _)) -> do-        return $ tensor-      (Value (TensorData (Tensor ns xs is))) -> do-        if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value-                else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value-      (Intermediate (ITensor (Tensor ns xs is))) -> do-        if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor-                else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor-      _ -> throwError $ NotImplemented "subrefs"-  return ret+  case tensor of+    (Value (ScalarData _)) ->+      return tensor+    (Value (TensorData (Tensor ns xs is))) ->+      if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)+              else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)+    (Intermediate (ITensor (Tensor ns xs is))) ->+      if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor+              else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor+    _ -> throwError $ NotImplemented "subrefs"  where   f :: Index a -> Index ()   f (Superscript _)  = Superscript ()@@ -375,25 +384,24 @@   f (Userscript _)   = Userscript ()  evalExpr env (SuprefsExpr bool expr jsExpr) = do-  js <- evalExpr env jsExpr >>= collectionToList >>= return . (map Superscript)+  js <- map Superscript <$> (evalExpr env jsExpr >>= collectionToList)   tensor <- case expr of               VarExpr (Var xs is) -> do-                let mObjRef = refVar env (Var xs $ is ++ (take (length js) (repeat (Superscript ()))))+                let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Superscript ()))                 case mObjRef of                   (Just objRef) -> evalRef objRef                   Nothing       -> evalExpr env expr               _ -> evalExpr env expr-  ret <- case tensor of-      (Value (ScalarData _)) -> do-        return $ tensor-      (Value (TensorData (Tensor ns xs is))) -> do-        if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value-                else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value-      (Intermediate (ITensor (Tensor ns xs is))) -> do-        if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor-                else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor-      _ -> throwError $ NotImplemented "suprefs"-  return ret+  case tensor of+    (Value (ScalarData _)) ->+      return tensor+    (Value (TensorData (Tensor ns xs is))) ->+      if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)+              else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)+    (Intermediate (ITensor (Tensor ns xs is))) ->+      if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor+              else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor+    _ -> throwError $ NotImplemented "suprefs"  where   f :: Index a -> Index ()   f (Superscript _)  = Superscript ()@@ -403,17 +411,16 @@  evalExpr env (UserrefsExpr bool expr jsExpr) = do   val <- evalExprDeep env expr-  js <- evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar >>= return . (map Userscript)-  ret <- case val of-      (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []])))-      (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args (is ++ js), 1)]]) (Plus [Term 1 []])))-      _ -> throwError $ NotImplemented "user-refs"-  return ret+  js <- map Userscript <$> (evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar)+  case val of+    (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []])))+    (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args (is ++ js), 1)]]) (Plus [Term 1 []])))+    _ -> throwError $ NotImplemented "user-refs"  evalExpr env (LambdaExpr names expr) = do-  names' <- mapM (\name -> case name of-                             (TensorArg name') -> return name'-                             (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names+  names' <- mapM (\case+                     (TensorArg name') -> return name'+                     (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names   return . Value $ Func Nothing env names' expr  evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr@@ -429,16 +436,16 @@ 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-  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) (map (\x -> symbolScalarData "" $ show x) args) args' [], 1)]]) (Plus [Term 1 []]))+  args' <- mapM (evalExprDeep env) args+  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) (map (symbolScalarData "" . show) args) args' [], 1)]]) (Plus [Term 1 []]))  evalExpr env (SymbolicTensorExpr args sizeExpr name) = do-  args' <- mapM (\arg -> evalExprDeep env arg) args+  args' <- mapM (evalExprDeep env) args   size' <- evalExpr env sizeExpr   size'' <- collectionToList size'-  ns <- (mapM fromEgison size'') :: EgisonM [Integer]-  let xs = map (\ms -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" (name ++ concat (map (\m -> "_" ++ m) (map show ms)))) (map (\x -> symbolScalarData "" $ show x) args) args' [], 1)]]) (Plus [Term 1 []])))-               (map (\ms -> map toEgison ms) (enumTensorIndices ns))+  ns <- mapM fromEgison size'' :: EgisonM [Integer]+  let xs = map ((\ms -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" (name ++ concatMap ((\m -> "_" ++ m) . show) ms)) (map (symbolScalarData "" . show) args) args' [], 1)]]) (Plus [Term 1 []])))+               . map toEgison) (enumTensorIndices ns)   fromTensor (Tensor ns (V.fromList xs) [])  evalExpr env (IfExpr test expr expr') = do@@ -501,17 +508,17 @@  evalExpr env (WithSymbolsExpr vars expr) = do   symId <- fresh-  syms <- mapM (\var -> (newEvaluatedObjectRef (Value (symbolScalarData symId var)))) vars+  syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars   let bindings = zip (map stringToVar vars) syms   whnf <- evalExpr (extendEnv env bindings) expr   case whnf of-    (Value (TensorData (Tensor ns xs js))) -> do+    (Value (TensorData (Tensor ns xs js))) ->       removeTmpscripts symId (Value (TensorData (Tensor ns xs js)))-    (Intermediate (ITensor (Tensor ns xs js))) -> do+    (Intermediate (ITensor (Tensor ns xs js))) ->       removeTmpscripts symId (Intermediate (ITensor (Tensor ns xs js)))     _ -> return whnf  where-  isTmpSymbol :: String -> (Index EgisonValue) -> Bool+  isTmpSymbol :: String -> Index EgisonValue -> Bool   isTmpSymbol symId (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []]))))     | symId == id = True     | otherwise = False@@ -533,7 +540,7 @@     let (ds, js) = partition (isTmpSymbol symId) is     (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)     return (Value (TensorData (Tensor s ys js)))-  removeDFscripts _ whnf = return whnf+  removeDFscripts _ = return   evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do@@ -564,13 +571,31 @@     head <- IElement <$> newEvaluatedObjectRef val     tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)     seqRef <- liftIO . newIORef $ Sq.fromList [head, tail]-    return . Intermediate $ ICollection $ seqRef+    return . Intermediate $ ICollection seqRef   f matcher target = do       let tryMatchClause (pattern, expr) results = do-            result <- patternMatch env pattern target matcher+            result <- patternMatch BFSMode env pattern target matcher             mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results       mfoldr tryMatchClause (return MNil) (fromList clauses) +evalExpr env (MatchAllDFSExpr target matcher clauses) = do+  target <- evalExpr env target+  matcher <- evalExpr env matcher >>= evalMatcherWHNF+  f matcher target >>= fromMList+ where+  fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData+  fromMList MNil = return . Value $ Collection Sq.empty+  fromMList (MCons val m) = do+    head <- IElement <$> newEvaluatedObjectRef val+    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 DFSMode 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   matcher <- evalExpr env matcher >>= evalMatcherWHNF@@ -578,7 +603,7 @@  where   f matcher target = do       let tryMatchClause (pattern, expr) cont = do-            result <- patternMatch env pattern target matcher+            result <- patternMatch BFSMode env pattern target matcher             case result of               MCons bindings _ -> evalExpr (extendEnv env bindings) expr               MNil             -> cont@@ -596,7 +621,7 @@       indices' <- mapM fromEgison args       hash <- liftIO $ readIORef hashRef       case HL.lookup indices' hash of-        Just objRef -> do+        Just objRef ->           evalRef objRef         Nothing -> do           whnf <- applyFunc env (Value (Func Nothing env names body)) (Value (makeTuple args))@@ -611,16 +636,16 @@   func <- evalExpr env func >>= appendDFscripts 0   arg <- evalExpr env arg   case func of-    Value (TensorData t@(Tensor ns fs js)) -> do-      tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value >>= removeDFscripts-    Intermediate (ITensor t@(Tensor ns fs js)) -> do+    Value (TensorData t@(Tensor ns fs js)) ->+      Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor) >>= removeDFscripts+    Intermediate (ITensor t@(Tensor ns fs js)) ->       tMap (\f -> applyFunc env f arg) t >>= fromTensor     Value (MemoizedFunc name ref hashRef env names body) -> do       indices <- evalWHNF arg       indices' <- mapM fromEgison $ fromTupleValue indices       hash <- liftIO $ readIORef hashRef       case HL.lookup indices' hash of-        Just objRef -> do+        Just objRef ->           evalRef objRef         Nothing -> do           whnf <- applyFunc env (Value (Func Nothing env names body)) arg@@ -635,18 +660,18 @@   func <- evalExpr env func >>= appendDFscripts 0   arg <- evalExpr env arg >>= fromTupleWHNF   let k = fromIntegral (length arg)-  arg <-  mapM (\(i,j) -> appendDFscripts i j) (zip [1..k] arg) >>= makeITuple+  arg <- zipWithM appendDFscripts [1..k] arg >>= makeITuple   case func of-    Value (TensorData t@(Tensor ns fs js)) -> do-      tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value-    Intermediate (ITensor t@(Tensor ns fs js)) -> do+    Value (TensorData t@(Tensor ns fs js)) ->+      Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor)+    Intermediate (ITensor t@(Tensor ns fs js)) ->       tMap (\f -> applyFunc env f arg) t >>= fromTensor     Value (MemoizedFunc name ref hashRef env names body) -> do       indices <- evalWHNF arg       indices' <- mapM fromEgison $ fromTupleValue indices       hash <- liftIO $ readIORef hashRef       case HL.lookup indices' hash of-        Just objRef -> do+        Just objRef ->           evalRef objRef         Nothing -> do           whnf <- applyFunc env (Value (Func Nothing env names body)) arg@@ -658,28 +683,26 @@     _ -> applyFunc env func arg >>= removeDFscripts  evalExpr env (MemoizeExpr memoizeFrame expr) = do-  mapM (\(x, y, z) -> do x' <- evalExprDeep env x-                         case x' of-                           (MemoizedFunc name ref hashRef env' names body) -> do-                             indices <- evalExprDeep env y-                             indices' <- mapM fromEgison $ fromTupleValue indices-                             hash <- liftIO $ readIORef hashRef-                             ret <- evalExprDeep env z-                             retRef <- newEvaluatedObjectRef (Value ret)-                             liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)-                             writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))-                           _ -> throwError $ TypeMismatch "memoized-function" (Value x'))+  mapM_ (\(x, y, z) -> do x' <- evalExprDeep env x+                          case x' of+                            (MemoizedFunc name ref hashRef env' names body) -> do+                              indices <- evalExprDeep env y+                              indices' <- mapM fromEgison $ fromTupleValue indices+                              hash <- liftIO $ readIORef hashRef+                              ret <- evalExprDeep env z+                              retRef <- newEvaluatedObjectRef (Value ret)+                              liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)+                              writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))+                            _ -> throwError $ TypeMismatch "memoized-function" (Value x'))        memoizeFrame   evalExpr env expr -evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info BFSMode--evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env info (DFSMode "umdfs")+evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info  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]+  xs <- mapM (newObjectRef env . ApplyExpr fnExpr . IntegerExpr) [fN..eN]   return $ Intermediate $ IArray $ Array.listArray (fN, eN) xs  evalExpr env (ArrayBoundsExpr expr) =@@ -688,26 +711,26 @@ evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do   size' <- evalExpr env sizeExpr   size'' <- collectionToList size'-  ns <- (mapM fromEgison size'') :: EgisonM [Integer]+  ns <- mapM fromEgison size'' :: EgisonM [Integer]   let Env frame maybe_vwi = env-  xs <- mapM (\ms -> do+  xs <- mapM ((\ms -> do     let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi     fn <- evalExpr env' fnExpr     applyFunc env fn $ Value $ makeTuple ms)-                (map (\ms -> map toEgison ms) $ enumTensorIndices ns)+                . map toEgison) (enumTensorIndices ns)   fromTensor (Tensor ns (V.fromList xs) [])  evalExpr env (TensorContractExpr fnExpr tExpr) = do   fn <- evalExpr env fnExpr   whnf <- evalExpr env tExpr   case whnf of-    (Intermediate (ITensor t@(Tensor _ _ _))) -> do+    (Intermediate (ITensor t@Tensor{})) -> do       ts <- tContract t       tMapN (\xs -> do xs' <- mapM newEvaluatedObjectRef xs                        applyFunc env fn (Intermediate (ITuple xs'))) ts >>= fromTensor-    (Value (TensorData t@(Tensor _ _ _))) -> do+    (Value (TensorData t@Tensor{})) -> do       ts <- tContract t-      tMapN (\xs -> applyFunc' env fn (Tuple xs)) ts >>= fromTensor >>= return . Value+      Value <$> (tMapN (applyFunc' env fn . Tuple) ts >>= fromTensor)     _ -> return whnf  where   applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue@@ -717,10 +740,10 @@   fn <- evalExpr env fnExpr   whnf <- evalExpr env tExpr   case whnf of-    Intermediate (ITensor t) -> do+    Intermediate (ITensor t) ->       tMap (applyFunc env fn) t >>= fromTensor-    Value (TensorData t) -> do-      tMap (applyFunc' env fn) t >>= fromTensor >>= return . Value+    Value (TensorData t) ->+      Value <$> (tMap (applyFunc' env fn) t >>= fromTensor)     _ -> applyFunc env fn whnf  where   applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue@@ -732,7 +755,7 @@   whnf2 <- evalExpr env t2Expr   case (whnf1, whnf2) of     -- both of arguments are tensors-    (Intermediate (ITensor t1), Intermediate (ITensor t2)) -> do+    (Intermediate (ITensor t1), Intermediate (ITensor t2)) ->       tMap2 (applyFunc'' env fn) t1 t2 >>= fromTensor     (Intermediate (ITensor t), Value (TensorData (Tensor ns xs js))) -> do       let xs' = V.map Value xs@@ -740,20 +763,20 @@     (Value (TensorData (Tensor ns xs js)), Intermediate (ITensor t)) -> do       let xs' = V.map Value xs       tMap2 (applyFunc'' env fn) (Tensor ns xs' js) t >>= fromTensor-    (Value (TensorData t1), Value (TensorData t2)) -> do-      tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor >>= return . Value+    (Value (TensorData t1), Value (TensorData t2)) ->+      Value <$> (tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor)     -- an argument is scalar     (Intermediate (ITensor (Tensor ns xs js)), whnf) -> do-      ys <- V.mapM (\x -> (applyFunc'' env fn x whnf)) xs+      ys <- V.mapM (\x -> applyFunc'' env fn x whnf) xs       return $ Intermediate (ITensor (Tensor ns ys js))     (whnf, Intermediate (ITensor (Tensor ns xs js))) -> do-      ys <- V.mapM (\x -> (applyFunc'' env fn whnf x)) xs+      ys <- V.mapM (applyFunc'' env fn whnf) xs       return $ Intermediate (ITensor (Tensor ns ys js))     (Value (TensorData (Tensor ns xs js)), whnf) -> do-      ys <- V.mapM (\x -> (applyFunc'' env fn (Value x) whnf)) xs+      ys <- V.mapM (\x -> applyFunc'' env fn (Value x) whnf) xs       return $ Intermediate (ITensor (Tensor ns ys js))     (whnf, Value (TensorData (Tensor ns xs js))) -> do-      ys <- V.mapM (\x -> (applyFunc'' env fn whnf (Value x))) xs+      ys <- V.mapM (applyFunc'' env fn whnf . Value) xs       return $ Intermediate (ITensor (Tensor ns ys js))     _ -> applyFunc'' env fn whnf1 whnf2  where@@ -833,7 +856,7 @@ evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList)  addscript :: (Index EgisonValue, Tensor a) -> Tensor a-addscript (subj, (Tensor s t i)) = (Tensor s t (i ++ [subj]))+addscript (subj, Tensor s t i) = Tensor s t (i ++ [subj])  valuetoTensor2 :: WHNFData -> Tensor WHNFData valuetoTensor2 (Intermediate (ITensor t)) = t@@ -841,32 +864,32 @@ 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)+  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]+          subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum]+          supjs = map (Superscript . symbolScalarData symId . show) [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+      makeITuple (Value (TensorData (Tensor s1 t1 (i1 ++ supjs))):map (Intermediate .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)+  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]+          subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum]+          supjs = map (Superscript . symbolScalarData symId . show) [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+      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   if n == fromIntegral (length refs)-    then evalExpr (extendEnv env $ makeBindings (map (\n -> (stringToVar $ "::" ++ show n)) [1..n]) refs) body+    then evalExpr (extendEnv env $ makeBindings (map (\n -> stringToVar $ "::" ++ show n) [1..n]) refs) body     else throwError $ ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs) applyFunc _ (Value (Func _ env [name] body)) arg = do   ref <- newEvaluatedObjectRef arg@@ -887,8 +910,8 @@ applyFunc _ (Value (CFunc _ env name body)) arg = do   refs <- fromTuple arg   seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs)-  col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection $ seqRef-  if length refs > 0+  col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection seqRef+  if not (null refs)     then evalExpr (extendEnv env $ makeBindings' [name] [col]) body     else throwError $ ArgumentsNumWithNames [name] 1 0 applyFunc env (Value (Macro [name] body)) arg = do@@ -900,48 +923,50 @@     then evalExpr (extendEnv env $ makeBindings' names refs) body     else throwError $ ArgumentsNumWithNames names (length names) (length refs) applyFunc _ (Value (PrimitiveFunc _ func)) arg = func arg-applyFunc _ (Value (IOFunc m)) arg = do+applyFunc _ (Value (IOFunc m)) arg =   case arg of      Value World -> m      _           -> throwError $ TypeMismatch "world" arg applyFunc _ (Value (QuotedFunc fn)) arg = do   args <- tupleToList arg   mExprs <- mapM extractScalar args-  return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])]))))-applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])])))) arg = do+  return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []]))))+applyFunc _ (Value fn@(ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])))) arg = do   args <- tupleToList arg-  mExprs <- mapM extractScalar args-  return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])]))))+  mExprs <- mapM (\arg -> case arg of+                            ScalarData _ -> extractScalar arg+                            _ -> throwError $ EgisonBug "to use undefined functions, you have to use ScalarData args") args+  return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []])))) applyFunc _ whnf _ = throwError $ TypeMismatch "function" whnf  refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData refArray val [] = return val-refArray (Value (Array array)) (index:indices) = do+refArray (Value (Array array)) (index:indices) =   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 do i <- (fmap fromInteger . fromEgison) index+            if (\(a,b) -> a <= i && i <= b) $ Array.bounds array               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+           (ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> do              let (_,size) = Array.bounds array              elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array)              elmRefs <- mapM newEvaluatedObjectRef elms              return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs            _  -> throwError $ TypeMismatch "integer or symbol" (Value index)-refArray (Intermediate (IArray array)) (index:indices) = do+refArray (Intermediate (IArray array)) (index:indices) =   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 do i <- (fmap fromInteger . fromEgison) index+            if (\(a,b) -> a <= i && i <= b) $ Array.bounds array               then let ref = array Array.! i in                    evalRef ref >>= flip refArray indices               else return  $ Value Undefined     else case index of-           (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> do+           (ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> do              let (_,size) = Array.bounds array              let refs = Array.elems array              arrs <- mapM evalRef refs-             elms <- mapM (\arr -> refArray arr indices) arrs+             elms <- mapM (`refArray` indices) arrs              elmRefs <- mapM newEvaluatedObjectRef elms              return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs            _  -> throwError $ TypeMismatch "integer or symbol" (Value index)@@ -978,11 +1003,11 @@ refArray val _ = throwError $ TypeMismatch "array or hash" val  arrayBounds :: WHNFData -> EgisonM WHNFData-arrayBounds val = arrayBounds' val >>= return . Value+arrayBounds val = Value <$> arrayBounds' val  arrayBounds' :: WHNFData -> EgisonM EgisonValue-arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [(toEgison (fst (Array.bounds arr))), (toEgison (snd (Array.bounds arr)))]-arrayBounds' (Value (Array arr))         = return $ Tuple [(toEgison (fst (Array.bounds arr))), (toEgison (snd (Array.bounds arr)))]+arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))]+arrayBounds' (Value (Array arr))         = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))] arrayBounds' val                         = throwError $ TypeMismatch "array" val  newThunk :: Env -> EgisonExpr -> Object@@ -1009,7 +1034,7 @@   refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr   let env' = extendEnv env $ makeBindings names refs   let Env frame _ = env'-  zipWithM_ (\ref (name,expr) -> do+  zipWithM_ (\ref (name,expr) ->                case expr of                  MemoizedLambdaExpr names body -> do                    hashRef <- liftIO $ newIORef HL.empty@@ -1017,11 +1042,11 @@                  LambdaExpr args body -> do                    whnf <- evalExpr env' expr                    case whnf of-                     (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ (Value (Func (Just name) env args body))+                     (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body)                  CambdaExpr arg body -> do                    whnf <- evalExpr env' expr                    case whnf of-                     (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body))+                     (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body)                  FunctionExpr args -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args                  _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr                    | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr)@@ -1042,11 +1067,11 @@                   LambdaExpr args body -> do                     whnf <- evalExpr env expr                     case whnf of-                      (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ (Value (Func (Just name) env args body))+                      (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body)                   CambdaExpr arg body -> do                     whnf <- evalExpr env expr                     case whnf of-                      (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body))+                      (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body)                   _ -> liftIO . writeIORef ref . Thunk $ evalExpr env expr   return env @@ -1054,52 +1079,26 @@ -- Pattern Match -- -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) }+patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch mode env pattern target matcher = processMStates mode [msingleton $ MState env [] [] [] [MAtom pattern target matcher]] -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 = convert ((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'- where-  convert :: Map Int [a] -> [[a]]-  convert ms = let ((start, root), ms') = M.deleteFindMin ms in-                   M.foldlWithKey (\l k x -> let k' = k - start in-                                                 if length l <= k' then l ++ (replicate (k' - length l) []) ++ [x]-                                                                   else let (xs, y:ys) = splitAt k' l in xs ++ (x:ys)) [root] ms'+processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)+processMStates _ [] = return MNil+processMStates mode streams = do+  (matches, streams') <- mapM (processMStates' mode) streams >>= extractMatches . concat+  mappend (fromList matches) $ (processMStates mode) streams' -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+processMStates' :: PMMode -> MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]+processMStates' _ MNil = return []+processMStates' BFSMode stream@(MCons _ _) = processMStatesBFS stream+processMStates' DFSMode stream@(MCons _ _) = processMStatesDFS stream  gatherBindings :: MatchingState -> Maybe [Binding]-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+gatherBindings (MState _ _ [] bindings []) = return bindings+gatherBindings _ = Nothing -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)))+extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])+extractMatches = extractMatches' ([], [])  where   extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])   extractMatches' (xs, ys) [] = return (xs, ys)@@ -1108,48 +1107,8 @@     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+processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]+processMStatesBFS (MCons state stream) = do   newStream <- processMState state   newStream' <- stream   return [newStream, newStream']@@ -1160,63 +1119,74 @@   newStream <- mappend stream' stream   return [newStream] +topMAtom :: MatchingState -> Maybe MatchingTree+topMAtom (MState _ _ _ _ (mAtom@MAtom{}:_))  = Just mAtom+topMAtom (MState _ _ _ _ (MNode _ mstate:_)) = topMAtom mstate+topMAtom _ = Nothing+ processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState state =   case topMAtom state of-    MAtom (NotPat _) _ _ -> do+    Just (MAtom (NotPat _) _ _) -> do       let (state1, state2) = splitMState state-      result <- processMStatesAll 0 $ MatchingStates { _normalTree = [[msingleton state1]], _orderedOrTrees = M.empty, _ids = [], _bool = False }+      result <- processMStates BFSMode [msingleton state1]       case result of         MNil -> return $ msingleton state2         _    -> return MNil-    MAtom (LaterPat _) _ _ -> do+    Just (MAtom (LaterPat _) _ _) -> do       let state' = swapMState state       processMState' state'     _ -> processMState' state  where   splitMState :: MatchingState -> (MatchingState, MatchingState)-  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)) =+  splitMState (MState env loops seqs bindings (MAtom (NotPat pattern) target matcher : trees)) =+    (MState env loops seqs bindings [MAtom pattern target matcher], MState env loops seqs bindings trees)+  splitMState (MState env loops seqs bindings (MNode penv state' : trees)) =     let (state1, state2) = splitMState state'-     in (MState mode env loops bindings [MNode penv state1], MState mode env loops bindings (MNode penv state2 : trees))+     in (MState env loops seqs bindings [MNode penv state1], MState env loops seqs bindings (MNode penv state2 : trees))   swapMState :: MatchingState -> MatchingState-  swapMState (MState mode env loops bindings ((MAtom (LaterPat pattern) target matcher) : trees)) =-    MState mode env loops bindings (trees ++ [MAtom pattern target matcher])-  swapMState (MState mode env loops bindings ((MNode penv state') : trees)) =+  swapMState (MState env loops seqs bindings (MAtom (LaterPat pattern) target matcher : trees)) =+    MState env loops seqs bindings (trees ++ [MAtom pattern target matcher])+  swapMState (MState env loops seqs bindings (MNode penv state' : trees)) =     let state'' = swapMState state'-     in MState mode env loops bindings ((MNode penv state''):trees)+     in MState env loops seqs bindings (MNode penv state'':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 env loops (SeqPatContext stack SeqNilPat [] []:seqs) bindings []) = return $ msingleton $ (MState env loops seqs bindings stack)+processMState' (MState env loops (SeqPatContext stack seqPat mats tgts:seqs) bindings []) = do+  let mat' = makeTuple mats+  tgt' <- makeITuple tgts+  return $ msingleton $ MState env loops seqs bindings (MAtom seqPat tgt' mat' : stack) -processMState' (MState mode env loops bindings (MNode penv (MState mode' env' loops' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) =+processMState' (MState _ _ _ _ (MNode _ (MState _ _ _ [] []):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)"++processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = do   case lookup name penv of     Just pattern ->       case trees' of-        [] -> 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)+        [] -> return $ msingleton $ MState env loops seqs bindings ((MAtom pattern target matcher):trees)+        _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees)     Nothing -> throwError $ UnboundVariable name -processMState' (MState mode env loops bindings (MNode penv (MState mode' env' loops' bindings' ((MAtom (IndexedPat (VarPat name) indices) target matcher):trees')):trees)) =+processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' 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'+      indices' <- mapM (evalExpr env'' >=> fmap fromInteger . fromWHNF) indices+      let pattern' = IndexedPat pattern $ map IntegerExpr indices'       case trees' of-        [] -> 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)+        [] -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:trees)+        _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees)     Nothing -> throwError $ UnboundVariable name -processMState' (MState mode env loops bindings ((MNode penv state):trees)) =+processMState' (MState env loops seqs bindings (MNode penv state:trees)) =   processMState' state >>= mmap (\state' -> case state' of-                                              MState _ _ _ _ [] -> return $ MState mode env loops bindings trees-                                              _ -> (return . MState mode env loops bindings . (: trees) . MNode penv) state')+                                              MState _ _ _ _ [] -> return $ MState env loops seqs bindings trees+                                              _ -> return $ MState env loops seqs bindings (MNode penv state':trees)) -processMState' (MState mode env loops bindings ((MAtom pattern target matcher):trees)) =+processMState' (MState env loops seqs 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)"@@ -1228,13 +1198,13 @@           extractBindings (names, expr) =             makeBindings names <$> (evalExpr env' expr >>= fromTuple)       in-       liftM concat (mapM extractBindings bindings')-         >>= (\b -> return $ msingleton $ MState mode env loops (b ++ bindings) ((MAtom pattern' target matcher):trees))+       fmap concat (mapM extractBindings bindings')+         >>= (\b -> return $ msingleton $ MState env loops seqs (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 mode env loops bindings trees)+      if result then return $ msingleton $ MState env loops seqs bindings trees                 else return MNil      PApplyPat func args -> do@@ -1242,11 +1212,11 @@       case func' of         Value (PatternFunc env'' names expr) ->           let penv = zip names args-          in return $ msingleton $ MState mode env loops bindings (MNode penv (MState mode env'' [] [] [MAtom expr target matcher]) : trees)+          in return $ msingleton $ MState env loops seqs bindings (MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees)         _ -> throwError $ TypeMismatch "pattern constructor" func' -    DApplyPat func args -> do-      return $ msingleton $ (MState mode env loops bindings ((MAtom (InductivePat "apply" [func, (toListPat args)]) target matcher):trees))+    DApplyPat func args ->+      return $ msingleton $ MState env loops seqs 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)@@ -1257,10 +1227,10 @@           endsRef <- newEvaluatedObjectRef ends'           inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef]           endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners)))-          return $ msingleton $ MState mode env ((LoopPatContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)+          return $ msingleton $ MState env (LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops) seqs bindings (MAtom ContPat target matcher:trees)         else do           endsRef <- newEvaluatedObjectRef ends'-          return $ msingleton $ MState mode env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)+          return $ msingleton $ MState env (LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops) seqs bindings (MAtom ContPat target matcher:trees)     ContPat ->       case loops of         [] -> throwError $ Default "cannot use cont pattern except in loop pattern"@@ -1280,46 +1250,50 @@                 then return MNil                 else if startNum == carEndsNum                        then if b2-                              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)]+                              then return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees)]+                              else return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees), MState env (LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]+                       else return $ fromList [MState env (LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]+    SeqNilPat -> throwError $ EgisonBug "should not reach here (seq nil pattern)"+    SeqConsPat pattern pattern' -> return $ msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher]+    LaterPatVar ->+      case seqs of+        [] -> throwError $ Default "cannot use # out of seq patterns"+        (SeqPatContext stack pat mats tgts:seqs) -> return $ msingleton $ MState env loops (SeqPatContext stack pat (matcher:mats) (target:tgts):seqs) bindings trees     AndPat patterns ->       let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees-      in return $ msingleton $ MState mode env loops bindings trees'+      in return $ msingleton $ MState env loops seqs bindings trees'     OrPat patterns ->       return $ fromList $ flip map patterns $ \pat ->-        MState mode env loops bindings (MAtom pat target matcher : trees)+        MState env loops seqs bindings (MAtom pat target matcher : trees)      _ ->       case matcher of-        UserMatcher _ _ _ -> do-          case pattern of-            _ -> do-              (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher-              case (length patterns, length matchers) of-                (1,1) -> do-                  mfor targetss $ \ref -> do-                    targets <- evalRef ref >>= (\x -> return [x])-                    let trees' = zipWith3 MAtom patterns targets matchers ++ trees-                    return $ MState mode env loops bindings trees'-                _ -> do-                  mfor targetss $ \ref -> do-                    targets <- evalRef ref >>= fromTupleWHNF-                    let trees' = zipWith3 MAtom patterns targets matchers ++ trees-                    return $ MState mode env loops bindings trees'+        UserMatcher{} -> do+          (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher+          case (length patterns, length matchers) of+            (1,1) ->+              mfor targetss $ \ref -> do+                targets <- evalRef ref >>= (\x -> return [x])+                let trees' = zipWith3 MAtom patterns targets matchers ++ trees+                return $ MState env loops seqs bindings trees'+            _ ->+              mfor targetss $ \ref -> do+                targets <- evalRef ref >>= fromTupleWHNF+                let trees' = zipWith3 MAtom patterns targets matchers ++ trees+                return $ MState env loops seqs bindings trees'          Tuple matchers ->           case pattern of-            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)+            ValuePat _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)+            WildCard -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)+            PatVar _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)+            IndexedPat _ _ -> return $ msingleton $ MState env loops seqs 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 ()+              when (length patterns /= length targets) $ throwError $ ArgumentsNum (length patterns) (length targets)+              when (length patterns /= length matchers) $ throwError $ ArgumentsNum (length patterns) (length matchers)               let trees' = zipWith3 MAtom patterns targets matchers ++ trees-              return $ msingleton $ MState mode env loops bindings trees'+              return $ msingleton $ MState env loops seqs bindings trees'             _ ->  throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern          Something ->@@ -1328,21 +1302,21 @@               val <- evalExprDeep env' valExpr               tgtVal <- evalWHNF target               if val == tgtVal-                then return $ msingleton $ MState mode env loops bindings trees+                then return $ msingleton $ MState env loops seqs bindings trees                 else return MNil-            WildCard -> return $ msingleton $ MState mode env loops bindings trees+            WildCard -> return $ msingleton $ MState env loops seqs bindings trees             PatVar name -> do               targetRef <- newEvaluatedObjectRef target-              return $ msingleton $ MState mode env loops ((name, targetRef):bindings) trees+              return $ msingleton $ MState env loops seqs ((name, targetRef):bindings) trees             IndexedPat (PatVar name) indices -> do-              indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices+              indices <- mapM (evalExpr env' >=> fmap fromInteger . fromWHNF) indices               case lookup name bindings of                 Just ref -> do                   obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef-                  return $ msingleton $ MState mode env loops (subst name obj bindings) trees+                  return $ msingleton $ MState env loops seqs (subst name obj bindings) trees                 Nothing  -> do                   obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef-                  return $ msingleton $ MState mode env loops ((name,obj):bindings) trees+                  return $ msingleton $ MState env loops seqs ((name,obj):bindings) trees                where                 updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData                 updateHash [index] (Intermediate (IIntHash hash)) = do@@ -1353,26 +1327,26 @@                   ref <- updateHash indices val >>= newEvaluatedObjectRef                   return . Intermediate . IIntHash $ HL.insert index ref hash                 updateHash indices (Value (IntHash hash)) = do-                  keys <- return $ HL.keys hash+                  let keys = HL.keys hash                   vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash                   updateHash indices (Intermediate $ IIntHash $ HL.fromList $ zip keys vals)                 updateHash _ v = throwError $ Default $ "expected hash value: " ++ show v                 subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)]-                subst k nv ((k', v'):xs) | k == k'   = (k', nv):(subst k nv xs)-                                         | otherwise = (k', v'):(subst k nv xs)+                subst 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)             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 mode env loops bindings trees'+              when (length patterns /= length targets) $ throwError $ ArgumentsNum (length patterns) (length targets)+              let trees' = zipWith3 MAtom patterns targets (replicate (length patterns) Something) ++ trees+              return $ msingleton $ MState env loops seqs 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 _) =+inductiveMatch env pattern target (UserMatcher matcherEnv clauses) =   foldr tryPPMatchClause failPPPatternMatch clauses  where   tryPPMatchClause (pat, matchers, clauses) cont = do@@ -1380,7 +1354,7 @@     case result of       Just (patterns, bindings) -> do         targetss <- foldr tryPDMatchClause failPDPatternMatch clauses-        matchers <- evalExpr matcherEnv matchers >>= evalMatcherWHNF >>= (return . fromTupleValue)+        matchers <- fromTupleValue <$> (evalExpr matcherEnv matchers >>= evalMatcherWHNF)         return (patterns, targetss, matchers)        where         tryPDMatchClause (pat, expr) cont = do@@ -1452,7 +1426,7 @@  expandCollection :: WHNFData -> EgisonM (Seq Inner) expandCollection (Value (Collection vals)) =-  mapM (liftM IElement . newEvaluatedObjectRef . Value) vals+  mapM (fmap IElement . newEvaluatedObjectRef . Value) vals expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef expandCollection val = throwError $ TypeMismatch "collection" val @@ -1462,7 +1436,7 @@   inners <- liftIO $ readIORef innersRef   case Sq.viewl inners of     EmptyL -> return True-    (ISubCollection ref') :< tInners -> do+    ISubCollection ref' :< tInners -> do       hInners <- evalRef ref' >>= expandCollection       liftIO $ writeIORef innersRef (hInners >< tInners)       isEmptyCollection coll@@ -1480,10 +1454,10 @@   inners <- liftIO $ readIORef innersRef   case Sq.viewl inners of     EmptyL -> matchFail-    (IElement ref') :< tInners -> do+    IElement ref' :< tInners -> do       tInnersRef <- liftIO $ newIORef tInners       lift $ (ref', ) <$> newEvaluatedObjectRef (Intermediate $ ICollection tInnersRef)-    (ISubCollection ref') :< tInners -> do+    ISubCollection ref' :< tInners -> do       hInners <- lift $ evalRef ref' >>= expandCollection       liftIO $ writeIORef innersRef (hInners >< tInners)       unconsCollection coll@@ -1500,10 +1474,10 @@   inners <- liftIO $ readIORef innersRef   case Sq.viewr inners of     EmptyR -> matchFail-    hInners :> (IElement ref') -> do+    hInners :> IElement ref' -> do       hInnersRef <- liftIO $ newIORef hInners       lift $ (, ref') <$> newEvaluatedObjectRef (Intermediate $ ICollection hInnersRef)-    hInners :> (ISubCollection ref') -> do+    hInners :> ISubCollection ref' -> do       tInners <- lift $ evalRef ref' >>= expandCollection       liftIO $ writeIORef innersRef (hInners >< tInners)       unsnocCollection coll@@ -1514,7 +1488,7 @@  evalMatcherWHNF :: WHNFData -> EgisonM Matcher evalMatcherWHNF (Value matcher@Something) = return matcher-evalMatcherWHNF (Value matcher@(UserMatcher _ _ _)) = return matcher+evalMatcherWHNF (Value matcher@UserMatcher{}) = return matcher evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms evalMatcherWHNF (Intermediate (ITuple refs)) = do   whnfs <- mapM evalRef refs@@ -1527,7 +1501,7 @@ -- toListPat :: [EgisonPattern] -> EgisonPattern toListPat []         = InductivePat "nil" []-toListPat (pat:pats) = InductivePat "cons" [pat, (toListPat pats)]+toListPat (pat:pats) = InductivePat "cons" [pat, toListPat pats]  fromTuple :: WHNFData -> EgisonM [ObjectRef] fromTuple (Intermediate (ITuple refs)) = return refs@@ -1580,9 +1554,9 @@ makeTuple xs  = Tuple xs  makeITuple :: [WHNFData] -> EgisonM WHNFData-makeITuple [] = return $ Intermediate (ITuple [])-makeITuple [x] = return $ x-makeITuple xs = mapM newEvaluatedObjectRef xs >>= (return . Intermediate . ITuple)+makeITuple []  = return $ Intermediate (ITuple [])+makeITuple [x] = return x+makeITuple xs  = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs  -- -- String@@ -1619,5 +1593,3 @@ isPrimitiveValue (Value (ScalarData _)) = True isPrimitiveValue (Value (Float _ _))    = True isPrimitiveValue _                      = False--makeLenses ''MatchingStates

@@ -1,4 +1,6 @@-{-# Language FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}  {- | Module      : Language.Egison.Desugar@@ -17,18 +19,19 @@     , desugar     ) where -import Control.Applicative (Applicative)-import Control.Applicative ((<$>), (<*>), (<*), (*>), pure)-import qualified Data.Sequence as Sq-import Data.Sequence (ViewL(..), (<|))-import qualified Data.Set as S-import Data.List (span)-import Data.Set (Set)-import Data.Char (toUpper)-import Control.Monad.Except-import Control.Monad.Fail-import Control.Monad.Reader-import Language.Egison.Types+import           Control.Applicative   (Applicative, pure, (*>), (<$>), (<*),+                                        (<*>))+import           Control.Monad.Except+import           Control.Monad.Fail+import           Control.Monad.Reader+import           Data.Char             (toUpper)+import           Data.List             (span)+import           Data.Maybe            (fromMaybe)+import           Data.Sequence         (ViewL (..), (<|))+import qualified Data.Sequence         as Sq+import           Data.Set              (Set)+import qualified Data.Set              as S+import           Language.Egison.Types  type Subst = [(String, EgisonExpr)] @@ -62,7 +65,7 @@ desugar :: EgisonExpr -> DesugarM EgisonExpr desugar (AlgebraicDataMatcherExpr patterns) = do   matcherName <- freshV-  matcherRef <- return $ VarExpr matcherName+  let matcherRef = VarExpr matcherName   matcher <- genMatcherClauses patterns matcherRef   return $ LetRecExpr [([matcherName], matcher)] matcherRef     where@@ -71,20 +74,20 @@         main <- genMainClause patterns matcher         body <- mapM genMatcherClause patterns         footer <- genSomethingClause-        clauses <- return $ [main] ++ body ++ [footer]+        let clauses = [main] ++ body ++ [footer]         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])-                                             clauses))])+               ,[(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)]+                                     <*> pure [(TuplePat [WildCard, WildCard], matchingFailure)]            genClause :: (String, [EgisonExpr]) -> DesugarM MatchClause           genClause pattern = do@@ -94,8 +97,8 @@           genMatchingPattern :: (String, [EgisonExpr]) -> DesugarM (EgisonPattern, EgisonPattern)           genMatchingPattern (name, patterns) = do             names <- mapM (const freshV) patterns-            return $ ((InductivePat name (map PatVar names))-                     ,(InductivePat name (map (ValuePat . VarExpr) names)))+            return (InductivePat name (map PatVar names),+                    InductivePat name (map (ValuePat . VarExpr) names))        genMatcherClause :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMatcherClause pattern = do@@ -112,7 +115,7 @@           genPrimitiveDataPat :: (String, [EgisonExpr]) -> DesugarM (PrimitiveDataPattern, [EgisonExpr])           genPrimitiveDataPat (name, patterns) = do             patterns' <- mapM (const freshV) patterns-            return (PDInductivePat (capitalize name) $ map PDPatVar $ map show patterns', map VarExpr patterns')+            return (PDInductivePat (capitalize name) $ map (PDPatVar . show) patterns', map VarExpr patterns')            capitalize :: String -> String           capitalize (x:xs) = toUpper x : xs@@ -120,7 +123,7 @@        genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genSomethingClause =-        return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr $ stringToVar "tgt")])])+        return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr $ stringToVar "tgt")])])        matchingSuccess :: EgisonExpr       matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []]@@ -143,30 +146,30 @@  desugar (IndexedExpr b expr indices)   | endWithThreeDots expr = case expr of-                              (VarExpr name) -> let x = show name in desugar $ IndexedExpr False (VarExpr $ stringToVar $ take ((length x)-3) x) indices+                              (VarExpr name) -> let x = show name in desugar $ IndexedExpr False (VarExpr $ stringToVar $ take (length x - 3) x) indices   | otherwise = case indices 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)]))]))+                                                                                    (TupleExpr [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ VarExpr $ stringToVar k]),+                                                                                                ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [fromIndexToExpr n1, fromIndexToExpr n2])]))                  [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                                                k <- fresh                                                return $ SuprefsExpr 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)]))]))-                 _ -> IndexedExpr b <$> desugar expr <*> (mapM desugarIndex indices)+                                                                                      (TupleExpr [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ VarExpr $ stringToVar k]),+                                                                                                  ApplyExpr (VarExpr $ stringToVar "between") (TupleExpr [fromIndexToExpr n1, fromIndexToExpr n2])]))+                 _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices  where   endWithThreeDots :: EgisonExpr -> Bool-  endWithThreeDots (VarExpr name) = (take 3 $ reverse (show name)) == "..."-  endWithThreeDots _ = False+  endWithThreeDots (VarExpr name) = take 3 (reverse (show name)) == "..."+  endWithThreeDots _              = False   fromIndexToExpr :: Index EgisonExpr -> EgisonExpr-  fromIndexToExpr (Subscript a) = a-  fromIndexToExpr (Superscript a) = a+  fromIndexToExpr (Subscript a)    = a+  fromIndexToExpr (Superscript a)  = a   fromIndexToExpr (SupSubscript a) = a  desugar (SubrefsExpr bool expr1 expr2) =@@ -194,12 +197,12 @@  desugar expr@(CollectionExpr []) = return expr -desugar (CollectionExpr ((ElementExpr elm):inners)) = do+desugar (CollectionExpr (ElementExpr elm:inners)) = do       elm' <- desugar elm       (CollectionExpr inners') <- desugar (CollectionExpr inners)       return $ CollectionExpr (ElementExpr elm':inners') -desugar (CollectionExpr ((SubCollectionExpr sub):inners)) = do+desugar (CollectionExpr (SubCollectionExpr sub:inners)) = do       sub' <- desugar sub       (CollectionExpr inners') <- desugar (CollectionExpr inners)       return $ CollectionExpr (SubCollectionExpr sub':inners')@@ -214,16 +217,15 @@   return $ TensorExpr nsExpr' xsExpr' supExpr subExpr  desugar (LambdaExpr names expr) = do-  let (rtnames, rhnames) = span (\name -> case name of-                                            TensorArg _ -> True-                                            _ -> False) (reverse names)+  let (rtnames, rhnames) = span (\case+                                    TensorArg _ -> True+                                    _           -> False) (reverse names)   case rhnames of     [] -> do expr' <- desugar expr              return $ LambdaExpr names expr'      (InvertedScalarArg rhname:rhnames') -> do-      let (rtnames2, rhnames2) = span (\name -> case name of-                                                _ -> False) rhnames'+      let (rtnames2, rhnames2) = span (const False) rhnames'       case rhnames2 of         [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)                           (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname)))@@ -235,9 +237,9 @@                       (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (FlipIndicesExpr (VarExpr $ stringToVar rhname2)) (FlipIndicesExpr (VarExpr $ stringToVar rhname)))      (ScalarArg rhname:rhnames') -> do-      let (rtnames2, rhnames2) = span (\name -> case name of-                                                TensorArg _ -> True-                                                _ -> False) rhnames'+      let (rtnames2, rhnames2) = span (\case+                                          TensorArg _ -> True+                                          _           -> False) rhnames'       case rhnames2 of         [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)                           (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (VarExpr $ stringToVar rhname))@@ -302,7 +304,7 @@   expr0' <- desugar expr0   expr1' <- desugar expr1   clauses' <- desugarMatchClauses clauses-  return (MatchExpr expr0' expr1' clauses')+  return $ MatchExpr expr0' expr1' clauses'  desugar (MatchAllExpr expr0 expr1 clauses) = do   expr0' <- desugar expr0@@ -310,6 +312,12 @@   clauses' <- desugarMatchClauses clauses   return $ MatchAllExpr expr0' expr1' clauses' +desugar (MatchAllDFSExpr expr0 expr1 clauses) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  clauses' <- desugarMatchClauses clauses+  return $ MatchAllDFSExpr expr0' expr1' clauses'+ desugar (DoExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr@@ -385,8 +393,8 @@   expr1' <- desugar expr1   return $ CApplyExpr expr0' expr1' -desugar (VarExpr name) = do-  asks $ maybe (VarExpr name) id . lookup (show name)+desugar (VarExpr name) =+  asks $ fromMaybe (VarExpr name) . lookup (show name)  desugar FreshVarExpr = do   id <- fresh@@ -396,10 +404,6 @@   matcherInfo' <- desugarMatcherInfo 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@@ -422,10 +426,10 @@ desugar expr = return expr  desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr)-desugarIndex (Superscript expr) = desugar expr >>= return . Superscript-desugarIndex (Subscript expr) = desugar expr >>= return . Subscript-desugarIndex (SupSubscript expr) = desugar expr >>= return . SupSubscript-desugarIndex (Userscript expr) = desugar expr >>= return . Userscript+desugarIndex (Superscript expr)  = Superscript <$> desugar expr+desugarIndex (Subscript expr)    = Subscript <$> desugar expr+desugarIndex (SupSubscript expr) = SupSubscript <$> desugar expr+desugarIndex (Userscript expr)   = Userscript <$> desugar expr  desugarPattern :: EgisonPattern -> DesugarM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern@@ -449,8 +453,6 @@    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@@ -463,8 +465,6 @@ desugarPattern' (LaterPat pattern) = LaterPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (OrPat patterns)  =  OrPat <$> mapM desugarPattern' patterns-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@@ -472,23 +472,24 @@ 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' (SeqConsPat pattern1 pattern2)  = SeqConsPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (DivPat pattern1 pattern2) = do   pat1' <- desugarPattern' pattern1   pat2' <- desugarPattern' pattern2   return $ InductivePat "div" [pat1', pat2'] desugarPattern' (PlusPat patterns) = do   pats' <- mapM desugarPattern' (concatMap f patterns)-  case (reverse pats') of+  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]+   f pat          = [pat] desugarPattern' (MultPat (intPat:patterns)) = do   intPat' <- desugarPattern' intPat   pats' <- mapM desugarPattern' (concatMap f patterns)-  case (reverse pats') of+  case reverse pats' of     [] -> return $ InductivePat "mult" [intPat', ValuePat (IntegerExpr 1)]     lp:hps ->       return $ InductivePat "mult" [intPat',@@ -501,27 +502,10 @@                                           (reverse hps)]  where    f (MultPat xs) = concatMap f xs-   f pat = [pat]+   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@@ -532,7 +516,7 @@ desugarBinding :: BindingExpr -> DesugarM BindingExpr desugarBinding (name, expr) = do   expr' <- desugar expr-  return $ (name, expr')+  return (name, expr')  desugarBindings :: [BindingExpr] -> DesugarM [BindingExpr] desugarBindings (bind:rest) = do@@ -546,7 +530,7 @@ desugarMatchClause (pattern, expr) = do   pattern' <- desugarPattern pattern   expr'    <- desugar expr-  return $ (pattern', expr')+  return (pattern', expr')  desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause] desugarMatchClauses (clause:rest) = do

@@ -6,31 +6,44 @@ This module provides utility functions. -} -module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex, mathExprToMathematica) where+module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex, mathExprToMathematica, mathExprToMaxima) where -import Control.Monad-import System.Environment-import Text.ParserCombinators.Parsec hiding (spaces)+import           Control.Monad+import           System.Environment+import           Text.ParserCombinators.Parsec hiding (spaces)  mathExprToHaskell :: String -> String mathExprToHaskell input = case parse parseExpr "math-expr" input of-                            Left err -> input+                            Left err  -> input                             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 -> case showMathExprAsciiMath val of+                                             "undefined" -> "undefined"+                                             output -> "#asciimath|" ++ output ++ "|#"  mathExprToLatex :: String -> String mathExprToLatex input = case parse parseExpr "math-expr" input of                           Left err -> input-                          Right val -> "#latex|" ++ showMathExprLatex val ++ "|#"+                          Right val -> case showMathExprLatex val of+                                         "undefined" -> "undefined"+                                         output -> "#latex|" ++ output ++ "|#"  mathExprToMathematica :: String -> String mathExprToMathematica input = case parse parseExpr "math-expr" input of+                                Left err -> input+                                Right val -> case showMathExprMathematica val of+                                               "undefined" -> "undefined"+                                               output -> "#mathematica|" ++ output ++ "|#"++mathExprToMaxima :: String -> String+mathExprToMaxima input = case parse parseExpr "math-expr" input of                           Left err -> input-                          Right val -> "#mathematica|" ++ showMathExprMathematica val ++ "|#"+                          Right val -> case showMathExprMaxima val of+                                         "undefined" -> "undefined"+                                         output -> "#maxima|" ++ output ++ "|#"  data MathExpr = Atom String [MathIndex]               | NegativeAtom String@@ -62,19 +75,19 @@  where   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 (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 showMathExprAsciiMath (Multiply []) = "" showMathExprAsciiMath (Multiply [a]) = showMathExprAsciiMath a showMathExprAsciiMath (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExprAsciiMath (Multiply lvs) showMathExprAsciiMath (Multiply lvs) = showMathExprAsciiMath' (head lvs) ++ " " ++ showMathExprAsciiMath (Multiply (tail lvs)) showMathExprAsciiMath (Power lv1 lv2) = showMathExprAsciiMath lv1 ++ "^" ++ showMathExprAsciiMath lv2-showMathExprAsciiMath (Func f lvs) = case f of-                                       Atom "/" [] -> if length lvs == 2 then "frac{" ++ showMathExprAsciiMath (head lvs) ++ "}{" ++ showMathExprAsciiMath (lvs !! 1) ++ "}"-                                                                        else showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")"-                                       _ -> showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")"+showMathExprAsciiMath (Func (Atom "sqrt" []) [x]) = "sqrt " ++ showMathExprAsciiMath x+showMathExprAsciiMath (Func (Atom "rt" []) [x, y]) = "root " ++ showMathExprAsciiMath x ++ " " ++ showMathExprAsciiMath y+showMathExprAsciiMath (Func (Atom "/" []) [x, y]) = "frac{" ++ showMathExprAsciiMath x ++ "}{" ++ showMathExprAsciiMath y ++ "}"+showMathExprAsciiMath (Func f lvs) = showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")" showMathExprAsciiMath (Tensor lvs mis)   | null mis = "(" ++ showMathExprAsciiMathArg lvs ++ ")"   | not (any isSub mis) = "(" ++ showMathExprAsciiMathArg lvs ++ ")^(" ++ showMathExprAsciiMathIndices mis ++ ")"@@ -85,9 +98,8 @@ showMathExprAsciiMath (Exp x) = "e^(" ++ showMathExprAsciiMath x ++ ")"  isSub :: MathIndex -> Bool-isSub x = case x of-            Sub _ -> True-            _ -> False+isSub (Sub _) = True+isSub _       = False  showMathExprAsciiMath' :: MathExpr -> String showMathExprAsciiMath' (Plus lvs) = "(" ++ showMathExprAsciiMath (Plus lvs) ++ ")"@@ -96,7 +108,7 @@ showMathExprAsciiMathArg :: [MathExpr] -> String showMathExprAsciiMathArg [] = "" showMathExprAsciiMathArg [a] = showMathExprAsciiMath a-showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ (showMathExprAsciiMathArg (tail lvs))+showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ showMathExprAsciiMathArg (tail lvs)  showMathExprAsciiMathIndices :: [MathIndex] -> String showMathExprAsciiMathIndices [a] = showMathIndexAsciiMath a@@ -104,7 +116,7 @@  showMathIndexAsciiMath :: MathIndex -> String showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a-showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a+showMathIndexAsciiMath (Sub a)   = showMathExprAsciiMath a  -- -- Show (Latex)@@ -114,25 +126,26 @@ showMathExprLatex (Atom a []) = a showMathExprLatex (Atom a xs) = a ++ showMathExprLatexScript xs showMathExprLatex (Partial f xs) = "\\frac{" ++ convertToPartial (f, length xs) ++ "}{" ++ showPartial xs ++ "}"-                                         where showPartial :: [MathExpr] -> String-                                               showPartial xs = let lx = elemCount xs in convertToPartial2 (head lx) ++ foldr (\x acc -> " " ++ convertToPartial2 x ++ acc) "" (tail lx)+ where+  showPartial :: [MathExpr] -> String+  showPartial xs = let lx = elemCount xs in convertToPartial2 (head lx) ++ foldr (\x acc -> " " ++ convertToPartial2 x ++ acc) "" (tail lx) -                                               convertToPartial :: (MathExpr, Int) -> String-                                               convertToPartial (x, 1) = "\\partial " ++ showMathExprLatex x-                                               convertToPartial (x, n) = "\\partial^" ++ show n ++ " " ++ showMathExprLatex x+  convertToPartial :: (MathExpr, Int) -> String+  convertToPartial (x, 1) = "\\partial " ++ showMathExprLatex x+  convertToPartial (x, n) = "\\partial^" ++ show n ++ " " ++ showMathExprLatex x -                                               convertToPartial2 :: (MathExpr, Int) -> String-                                               convertToPartial2 (x, 1) = "\\partial " ++ showMathExprLatex x-                                               convertToPartial2 (x, n) = "\\partial " ++ showMathExprLatex x ++ "^"  ++ show n+  convertToPartial2 :: (MathExpr, Int) -> String+  convertToPartial2 (x, 1) = "\\partial " ++ showMathExprLatex x+  convertToPartial2 (x, n) = "\\partial " ++ showMathExprLatex x ++ "^"  ++ show n showMathExprLatex (NegativeAtom a) = "-" ++ a showMathExprLatex (Plus []) = "" showMathExprLatex (Plus (x:xs)) = showMathExprLatex x ++ showMathExprLatexForPlus xs  where   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 (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 []) = "" showMathExprLatex (Multiply [x]) = showMathExprLatex x@@ -144,9 +157,7 @@ showMathExprLatex (Func (Atom "rt" []) [x, y]) = "\\sqrt[" ++ showMathExprLatex x ++ "]{" ++ showMathExprLatex y ++ "}" showMathExprLatex (Func (Atom "/" []) [x, y]) = "\\frac{" ++ showMathExprLatex x ++ "}{" ++ showMathExprLatex y ++ "}" showMathExprLatex (Func f xs) = showMathExprLatex f ++ "(" ++ showMathExprLatexArg xs ", " ++ ")"-showMathExprLatex (Tensor xs mis) = case head xs of-                                       Tensor _ _ -> "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis-                                       _ -> "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis+showMathExprLatex (Tensor xs mis) = "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis showMathExprLatex (Tuple xs) = "(" ++ showMathExprLatexArg xs ", " ++ ")" showMathExprLatex (Collection xs) = "\\{" ++ showMathExprLatexArg xs ", " ++ "\\}" showMathExprLatex (Exp x) = "e^{" ++ showMathExprLatex x ++ "}"@@ -154,7 +165,7 @@  showMathExprLatex' :: MathExpr -> String showMathExprLatex' (Plus xs) = "(" ++ showMathExprLatex (Plus xs) ++ ")"-showMathExprLatex' x = showMathExprLatex x+showMathExprLatex' x         = showMathExprLatex x  showMathExprLatexArg :: [MathExpr] -> String -> String showMathExprLatexArg [] _ = ""@@ -163,17 +174,17 @@  showMathExprLatexSuper :: MathIndex -> String showMathExprLatexSuper (Super (Atom "#" [])) = "\\#"-showMathExprLatexSuper (Super x) = showMathExprLatex x-showMathExprLatexSuper (Sub x) = "\\;"+showMathExprLatexSuper (Super x)             = showMathExprLatex x+showMathExprLatexSuper (Sub x)               = "\\;"  showMathExprLatexSub :: MathIndex -> String showMathExprLatexSub (Sub (Atom "#" [])) = "\\#"-showMathExprLatexSub (Sub x) = showMathExprLatex x-showMathExprLatexSub (Super x) = "\\;"+showMathExprLatexSub (Sub x)             = showMathExprLatex x+showMathExprLatexSub (Super x)           = "\\;"  showMathExprLatexScript :: [MathIndex] -> String showMathExprLatexScript [] = ""-showMathExprLatexScript is = "_{" ++ concat (map showMathExprLatexSub is) ++ "}^{" ++ concat (map showMathExprLatexSuper is) ++ "}"+showMathExprLatexScript is = "_{" ++ concatMap showMathExprLatexSub is ++ "}^{" ++ concatMap showMathExprLatexSuper is ++ "}"  showMathExprLatexVectors :: [MathExpr] -> String showMathExprLatexVectors [] = ""@@ -186,17 +197,16 @@  showMathExprMathematica :: MathExpr -> String showMathExprMathematica (Atom a []) = a---showMathExprMathematica (Atom a xs) = a ++ showMathExprMathematicaScript xs-showMathExprMathematica (Partial f xs) = undefined+showMathExprMathematica (Partial f xs) = showMathExprMathematica f ++ "_" ++ (showMathExprsMathematica "_" xs) 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 (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@@ -206,7 +216,10 @@ 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 (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y+ where+   addBracket x@(Atom _ []) = showMathExprMathematica x+   addBracket x             = "(" ++ showMathExprMathematica x ++ ")" showMathExprMathematica (Func f xs) = showMathExprMathematica f ++ "(" ++ showMathExprMathematicaArg xs ++ ")" showMathExprMathematica (Tensor lvs mis)   | null mis = "{" ++ showMathExprMathematicaArg lvs ++ "}"@@ -222,10 +235,13 @@ showMathExprMathematica' (Plus xs) = "(" ++ showMathExprMathematica (Plus xs) ++ ")" showMathExprMathematica' x = showMathExprMathematica x +showMathExprsMathematica :: String -> [MathExpr] -> String+showMathExprsMathematica _ [] = ""+showMathExprsMathematica _ [a] = showMathExprMathematica a+showMathExprsMathematica s lvs = showMathExprMathematica (head lvs) ++ s ++ showMathExprsMathematica s (tail lvs)+ showMathExprMathematicaArg :: [MathExpr] -> String-showMathExprMathematicaArg [] = ""-showMathExprMathematicaArg [a] = showMathExprMathematica a-showMathExprMathematicaArg lvs = showMathExprMathematica (head lvs) ++ ", " ++ (showMathExprMathematicaArg (tail lvs))+showMathExprMathematicaArg xs = showMathExprsMathematica ", " xs  showMathExprMathematicaIndices :: [MathIndex] -> String showMathExprMathematicaIndices [a] = showMathIndexMathematica a@@ -233,9 +249,55 @@  showMathIndexMathematica :: MathIndex -> String showMathIndexMathematica (Super a) = showMathExprMathematica a-showMathIndexMathematica (Sub a) = showMathExprMathematica a+showMathIndexMathematica (Sub a)   = showMathExprMathematica a +--+-- Show (Maxima)+-- +showMathExprMaxima :: MathExpr -> String+showMathExprMaxima (Atom a []) = a+showMathExprMaxima (Partial f xs) = "undefined"+showMathExprMaxima (NegativeAtom a) = "-" ++ a+showMathExprMaxima (Plus []) = ""+showMathExprMaxima (Plus (x:xs)) = showMathExprMaxima x ++ showMathExprMaximaForPlus xs+ where+  showMathExprMaximaForPlus :: [MathExpr] -> String+  showMathExprMaximaForPlus [] = ""+  showMathExprMaximaForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprMaximaForPlus xs+  showMathExprMaximaForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExprMaxima (Multiply ys) ++ showMathExprMaximaForPlus xs+  showMathExprMaximaForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExprMaxima (Multiply (Atom a []:ys)) ++ showMathExprMaximaForPlus xs+  showMathExprMaximaForPlus (x:xs) = " + " ++  showMathExprMaxima x ++ showMathExprMaximaForPlus xs+showMathExprMaxima (Multiply []) = ""+showMathExprMaxima (Multiply [x]) = showMathExprMaxima x+showMathExprMaxima (Multiply (Atom "1" []:xs)) = showMathExprMaxima (Multiply xs)+showMathExprMaxima (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprMaxima (Multiply xs)+showMathExprMaxima (Multiply (x:xs)) = showMathExprMaxima' x ++ " * " ++ showMathExprMaxima (Multiply xs)+showMathExprMaxima (Power lv1 lv2) = showMathExprMaxima lv1 ++ "^" ++ showMathExprMaxima lv2+showMathExprMaxima (Func (Atom "sqrt" []) [x]) = "sqrt(" ++ showMathExprMaxima x ++ ")"+showMathExprMaxima (Func (Atom "rt" []) [x, y]) = showMathExprMaxima y ++ "^(1/" ++ showMathExprMaxima x ++ ")"+showMathExprMaxima (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y+ where+   addBracket x@(Atom _ []) = showMathExprMaxima x+   addBracket x             = "(" ++ showMathExprMaxima x ++ ")"+showMathExprMaxima (Func f xs) = showMathExprMaxima f ++ "(" ++ showMathExprMaximaArg xs ++ ")"+showMathExprMaxima (Tensor lvs mis) = "undefined"+showMathExprMaxima (Tuple xs) = "undefined"+showMathExprMaxima (Collection xs) = "[" ++ showMathExprMaximaArg xs ++ "]"+showMathExprMaxima (Exp x) = "exp(" ++ showMathExprMaxima x ++ ")"+showMathExprMaxima (Quote x) = "(" ++ showMathExprMaxima x ++ ")"++showMathExprMaxima' :: MathExpr -> String+showMathExprMaxima' (Plus xs) = "(" ++ showMathExprMaxima (Plus xs) ++ ")"+showMathExprMaxima' x         = showMathExprMaxima x++showMathExprMaximaArg :: [MathExpr] -> String+showMathExprMaximaArg [] = ""+showMathExprMaximaArg [Tensor lvs []] = "undefined"+showMathExprMaximaArg [a] = showMathExprMaxima a+showMathExprMaximaArg lvs = showMathExprMaxima (head lvs) ++ ", " ++ showMathExprMaximaArg (tail lvs)++ -- -- Parser --@@ -250,102 +312,47 @@ symbol = oneOf "!$%&*+-/:<=>?@#"  parseAtom :: Parser MathExpr-parseAtom = do-    first <- letter <|> symbol <|> digit-    rest <- many (letter <|> digit <|> symbol)-    let atom = first : rest-    ys <- many parseScript-    return $ Atom atom ys+parseAtom = Atom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol)) <*> many parseScript  parseAtom' :: Parser MathExpr-parseAtom' = do-    first <- letter <|> symbol <|> digit-    rest <- many (letter <|> digit <|> symbol)-    let atom = first : rest-    return $ Atom atom []+parseAtom' = flip Atom [] <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol))  parsePartial :: Parser MathExpr-parsePartial = do-    xs <- parseAtom-    is <- many1 (char '|' >> parseAtom)-    return $ Partial xs is+parsePartial = Partial <$> parseAtom <*> many1 (char '|' >> parseAtom)  parseNegativeAtom :: Parser MathExpr-parseNegativeAtom = do-    char '-'-    first <- letter <|> symbol <|> digit-    rest <- many (letter <|> digit <|> symbol)-    let atom = first : rest-    return $ NegativeAtom atom+parseNegativeAtom = char '-' >> NegativeAtom <$> ((:) <$> (letter <|> symbol <|> digit) <*> many (letter <|> digit <|> symbol))  parseList :: Parser [MathExpr] parseList = sepEndBy parseExpr spaces  parseScript :: Parser MathIndex-parseScript = (Sub <$> (char '_' >> parseAtom')) <|> (Super <$> (char '~' >> parseAtom'))+parseScript = Sub <$> (char '_' >> parseAtom')+              <|> Super <$> (char '~' >> parseAtom')  parsePlus :: Parser MathExpr-parsePlus = do-    string "(+"-    spaces-    xs <- parseList-    char ')'-    return $ Plus xs+parsePlus = string "(+" >> spaces >> Plus <$> parseList <* char ')'  parseMultiply :: Parser MathExpr-parseMultiply = do-    string "(*"-    spaces-    xs <- parseList-    char ')'-    return $ Multiply xs+parseMultiply = string "(*" >> spaces >> Multiply <$> parseList <* char ')'  parseFunction :: Parser MathExpr-parseFunction = do-    char '('-    func <- parseAtom-    spaces-    xs <- parseList-    char ')'-    return $ Func func xs+parseFunction = char '(' >> Func <$> parseAtom <* spaces <*> parseList <* char ')'  parseTensor :: Parser MathExpr-parseTensor = do-    string "[|"-    spaces0-    xs <- parseList-    spaces0-    string "|]"-    ys <- many  parseScript-    return $ Tensor xs ys+parseTensor = string "[|" >> spaces0 >> Tensor <$> parseList <* spaces0 <* string "|]" <*> many parseScript  parseTuple :: Parser MathExpr-parseTuple = do-    char '['-    xs <- parseList-    char ']'-    return $ Tuple xs+parseTuple = char '[' >> Tuple <$> parseList <* char ']'  parseCollection :: Parser MathExpr-parseCollection = do-    char '{'-    xs <- parseList-    char '}'-    return $ Collection xs+parseCollection = char '{' >> Collection <$> parseList <* char '}'  parseExp :: Parser MathExpr-parseExp = do-    string "(exp"-    spaces-    x <- parseExpr-    char ')'-    return $ Exp x+parseExp = string "(exp" >> spaces >> Exp <$> parseExpr <* char ')'  parseQuote :: Parser MathExpr-parseQuote = do-    char '\''-    x <- parseExpr'-    return $ Quote x+parseQuote = char '\'' >> Quote <$> parseExpr'  parseExpr' :: Parser MathExpr parseExpr' = parseNegativeAtom@@ -362,9 +369,9 @@  parseExpr :: Parser MathExpr parseExpr = do-    x <- parseExpr'-    option x $ Power x <$> try (char '^' >> parseExpr')+  x <- parseExpr'+  option x $ Power x <$> try (char '^' >> parseExpr')  elemCount :: Eq a => [a] -> [(a, Int)] elemCount [] = []-elemCount (x:xs) = (x, (length $ filter (== x) xs) + 1) : elemCount (filter (/= x) xs)+elemCount (x:xs) = (x, length (filter (== x) xs) + 1) : elemCount (filter (/= x) xs)

@@ -1,4 +1,5 @@-{-# LANGUAGE TupleSections, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections    #-}  {- | Module      : Language.Egison.Parser@@ -24,32 +25,33 @@        , 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           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>))+import           Control.Monad.Except    hiding (mapM)+import           Control.Monad.Identity  hiding (mapM)+import           Control.Monad.State     hiding (mapM)+import           Prelude                 hiding (mapM) -import System.Directory (doesFileExist, getHomeDirectory)+import           System.Directory        (doesFileExist, getHomeDirectory) -import qualified Data.Sequence as Sq-import Data.Either-import Data.Char (isLower, isUpper)-import qualified Data.Set as Set-import Data.Traversable (mapM)-import Data.Ratio-import Data.List.Split (splitOn)+import           Data.Char               (isLower, isUpper)+import           Data.Either+import           Data.Functor            (($>))+import           Data.List.Split         (splitOn)+import           Data.Ratio+import qualified Data.Sequence           as Sq+import qualified Data.Set                as Set+import           Data.Traversable        (mapM) -import Text.Parsec-import Text.Parsec.String-import qualified Text.Parsec.Token as P+import           Text.Parsec+import           Text.Parsec.String+import qualified Text.Parsec.Token       as P -import qualified Data.Text as T-import Text.Regex.TDFA+import qualified Data.Text               as T+import           Text.Regex.TDFA -import Language.Egison.Types-import Language.Egison.Desugar-import Paths_egison (getDataFileName)+import           Language.Egison.Desugar+import           Language.Egison.Types+import           Paths_egison            (getDataFileName)  readTopExprs :: String -> EgisonM [EgisonTopExpr] readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs@@ -90,7 +92,7 @@ -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] loadLibraryFile file = do-  homeDir <- liftIO $ getHomeDirectory+  homeDir <- liftIO getHomeDirectory   doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file   if doesExist     then loadFile $ homeDir ++ "/.egison/" ++ file@@ -105,12 +107,12 @@   exprs <- readTopExprs $ shebang input   concat <$> mapM  recursiveLoad exprs  where-  recursiveLoad (Load _ file) = loadLibraryFile file+  recursiveLoad (Load _ file)     = loadLibraryFile file   recursiveLoad (LoadFile _ file) = loadFile file-  recursiveLoad expr = return [expr]+  recursiveLoad expr              = return [expr]   shebang :: String -> String   shebang ('#':'!':cs) = ';':'#':'!':cs-  shebang cs = cs+  shebang cs           = cs  -- -- Parser@@ -142,15 +144,14 @@ defineExpr :: Parser EgisonTopExpr defineExpr = try (parens (keywordDefine >> Define <$> (char '$' >> identVar) <*> expr))          <|> try (parens (do keywordDefine-                             (VarWithIndices name is) <- (char '$' >> identVarWithIndices)-                             body <- expr-                             return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) body))))+                             (VarWithIndices name is) <- char '$' >> identVarWithIndices+                             Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr))  where-  f (Superscript _) = Superscript ()-  f (Subscript _) = Subscript ()+  f (Superscript _)  = Superscript ()+  f (Subscript _)    = Subscript ()   f (SupSubscript _) = SupSubscript ()-  g (Superscript i) = i-  g (Subscript i) = i+  g (Superscript i)  = i+  g (Subscript i)    = i   g (SupSubscript i) = i  redefineExpr :: Parser EgisonTopExpr@@ -175,87 +176,85 @@ expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr'                           expr1 <- option expr0 $ try (string "..." >> IndexedExpr False expr0 <$> parseindex)                                                   <|> IndexedExpr True expr0 <$> parseindex-                          option expr1 $ PowerExpr expr1 <$> (try $ char '^' >> expr'))+                          option expr1 $ PowerExpr expr1 <$> try (char '^' >> expr'))                             where parseindex :: Parser [Index EgisonExpr]                                   parseindex = many1 (try (do                                                            char '_'                                                            e1 <- expr'                                                            string "..._"-                                                           e2 <- expr'-                                                           return $ MultiSubscript e1 e2)+                                                           MultiSubscript e1 <$> expr')                                                  <|> try (do                                                            char '~'                                                            e1 <- expr'                                                            string "...~"-                                                           e2 <- expr'-                                                           return $ MultiSuperscript e1 e2)-                                                 <|> try (char '_' >> expr' >>= return . Subscript)-                                                 <|> try (char '~' >> expr' >>= return . Superscript)-                                                 <|> try (string "~_" >> expr' >>= return . SupSubscript)-                                                 <|> try (char '|' >> expr' >>= return . Userscript))+                                                           MultiSuperscript e1 <$> expr')+                                                 <|> try (Subscript <$> (char '_' >> expr'))+                                                 <|> try (Superscript <$> (char '~' >> expr'))+                                                 <|> try (SupSubscript <$> (string "~_" >> expr'))+                                                 <|> try (Userscript <$> (char '|' >> expr')))   quoteExpr' :: Parser EgisonExpr quoteExpr' = char '\'' >> QuoteExpr <$> expr'  expr' :: Parser EgisonExpr-expr' = (try partialExpr-             <|> try constantExpr-             <|> try partialVarExpr-             <|> try freshVarExpr-             <|> try varExpr-             <|> inductiveDataExpr-             <|> try arrayExpr-             <|> try vectorExpr-             <|> try tupleExpr-             <|> try hashExpr-             <|> collectionExpr---             <|> quoteExpr-             <|> quoteSymbolExpr-             <|> wedgeExpr-             <|> parens (ifExpr-                         <|> lambdaExpr-                         <|> memoizedLambdaExpr-                         <|> memoizeExpr-                         <|> cambdaExpr-                         <|> procedureExpr-                         <|> macroExpr-                         <|> patternFunctionExpr-                         <|> letRecExpr-                         <|> letExpr-                         <|> letStarExpr-                         <|> withSymbolsExpr-                         <|> doExpr-                         <|> ioExpr-                         <|> matchAllExpr-                         <|> matchExpr-                         <|> matchAllLambdaExpr-                         <|> matchLambdaExpr-                         <|> matcherExpr-                         <|> matcherDFSExpr-                         <|> seqExpr-                         <|> applyExpr-                         <|> cApplyExpr-                         <|> algebraicDataMatcherExpr-                         <|> generateArrayExpr-                         <|> arrayBoundsExpr-                         <|> arrayRefExpr-                         <|> generateTensorExpr-                         <|> symbolicTensorExpr-                         <|> tensorExpr-                         <|> tensorContractExpr-                         <|> tensorMapExpr-                         <|> tensorMap2Expr-                         <|> transposeExpr-                         <|> parExpr-                         <|> pseqExpr-                         <|> pmapExpr-                         <|> subrefsExpr-                         <|> suprefsExpr-                         <|> userrefsExpr-                         <|> functionWithArgExpr-                         )-             <?> "expression")+expr' = try partialExpr+            <|> try constantExpr+            <|> try partialVarExpr+            <|> try freshVarExpr+            <|> try varExpr+            <|> inductiveDataExpr+            <|> try arrayExpr+            <|> try vectorExpr+            <|> try tupleExpr+            <|> try hashExpr+            <|> collectionExpr+--            <|> quoteExpr+            <|> quoteSymbolExpr+            <|> wedgeExpr+            <|> parens (ifExpr+                        <|> lambdaExpr+                        <|> memoizedLambdaExpr+                        <|> memoizeExpr+                        <|> cambdaExpr+                        <|> procedureExpr+                        <|> macroExpr+                        <|> patternFunctionExpr+                        <|> letRecExpr+                        <|> letExpr+                        <|> letStarExpr+                        <|> withSymbolsExpr+                        <|> doExpr+                        <|> ioExpr+                        <|> matchAllExpr+                        <|> matchAllDFSExpr+                        <|> matchExpr+                        <|> matchAllLambdaExpr+                        <|> matchLambdaExpr+                        <|> matcherExpr+                        <|> seqExpr+                        <|> applyExpr+                        <|> cApplyExpr+                        <|> algebraicDataMatcherExpr+                        <|> generateArrayExpr+                        <|> arrayBoundsExpr+                        <|> arrayRefExpr+                        <|> generateTensorExpr+                        <|> symbolicTensorExpr+                        <|> tensorExpr+                        <|> tensorContractExpr+                        <|> tensorMapExpr+                        <|> tensorMap2Expr+                        <|> transposeExpr+                        <|> parExpr+                        <|> pseqExpr+                        <|> pmapExpr+                        <|> subrefsExpr+                        <|> suprefsExpr+                        <|> userrefsExpr+                        <|> functionWithArgExpr+                        )+            <?> "expression"  varExpr :: Parser EgisonExpr varExpr = VarExpr <$> identVarWithoutIndex@@ -303,25 +302,28 @@ wedgeExpr = char '!' >> WedgeExpr <$> expr  functionWithArgExpr :: Parser EgisonExpr-functionWithArgExpr = keywordFunction >> FunctionExpr <$> (between lp rp $ sepEndBy expr whiteSpace)+functionWithArgExpr = keywordFunction >> FunctionExpr <$> between lp rp (sepEndBy expr whiteSpace)   where     lp = P.lexeme lexer (char '[')     rp = char ']'  symbolicTensorExpr :: Parser EgisonExpr-symbolicTensorExpr = keywordSymbolicTensor >> SymbolicTensorExpr <$> (brackets $ sepEndBy expr whiteSpace) <*> expr <*> ident+symbolicTensorExpr = keywordSymbolicTensor >> SymbolicTensorExpr <$> brackets (sepEndBy expr whiteSpace) <*> expr <*> ident  quoteSymbolExpr :: Parser EgisonExpr quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr  matchAllExpr :: Parser EgisonExpr-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses)+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses) +matchAllDFSExpr :: Parser EgisonExpr+matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)+ matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses  matchAllLambdaExpr :: Parser EgisonExpr-matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((flip (:) []) <$> matchClause) <|> matchClauses)+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)  matchLambdaExpr :: Parser EgisonExpr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses@@ -335,9 +337,6 @@ matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -matcherDFSExpr :: Parser EgisonExpr-matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses- ppMatchClauses :: Parser MatcherInfo ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace @@ -358,10 +357,10 @@                         <?> "primitive-pattren-pattern")  ppWildCard :: Parser PrimitivePatPattern-ppWildCard = reservedOp "_" *> pure PPWildCard+ppWildCard = reservedOp "_" $> PPWildCard  ppPatVar :: Parser PrimitivePatPattern-ppPatVar = reservedOp "$" *> pure PPPatVar+ppPatVar = reservedOp "$" $> PPPatVar  ppValuePat :: Parser PrimitivePatPattern ppValuePat = reservedOp ",$" >> PPValuePat <$> ident@@ -370,10 +369,10 @@ ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)  pdPattern :: Parser PrimitiveDataPattern-pdPattern = P.lexeme lexer $ pdPattern'+pdPattern = P.lexeme lexer pdPattern'  pdPattern' :: Parser PrimitiveDataPattern-pdPattern' = reservedOp "_" *> pure PDWildCard+pdPattern' = reservedOp "_" $> PDWildCard                     <|> (char '$' >> PDPatVar <$> ident)                     <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern))                             <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern)@@ -423,7 +422,7 @@ letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr  withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident whiteSpace) <*> expr+withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident whiteSpace) <*> expr  doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr@@ -455,9 +454,9 @@             <|> brackets (sepEndBy argName whiteSpace)  argName :: Parser Arg-argName = try (char '$' >> ident >>= return . ScalarArg)-      <|> try (string "*$" >> ident >>= return . InvertedScalarArg)-      <|> try (char '%' >> ident >>= return . TensorArg)+argName = try (ScalarArg <$> (char '$' >> ident))+      <|> try (InvertedScalarArg <$> (string "*$" >> ident))+      <|> try (TensorArg <$> (char '%' >> ident))  ioExpr :: Parser EgisonExpr ioExpr = keywordIo >> IoExpr <$> expr@@ -466,7 +465,7 @@ 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)@@ -481,8 +480,8 @@     [] -> return . 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''+            args'' = zipWith (curry f) args (annonVars 1 (length args))+            args''' = map (VarExpr . stringToVar . either id id) args''         in return $ ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'       | all (not . null) vars ->         let ns = Set.fromList $ map read vars@@ -490,8 +489,8 @@         in if Set.findMin ns == 1 && Set.findMax ns == n              then                let args' = rights args-                   args'' = map g (zip args (annonVars (n + 1) (length args)))-                   args''' = map (VarExpr . stringToVar . (either id id)) args''+                   args'' = zipWith (curry g) args (annonVars (n + 1) (length args))+                   args''' = map (VarExpr . stringToVar . either id id) args''                in return $ ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'              else fail "invalid partial application"       | otherwise -> fail "invalid partial application"@@ -501,13 +500,13 @@          <|> char '$' *> (Left <$> option "" index)   index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit   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+  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 '#' >> expr)+partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> expr)  where   index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit @@ -588,15 +587,16 @@             <|> notPat             <|> tuplePat             <|> inductivePat+            <|> laterPatVar+            <|> try seqNilPat+            <|> try seqConsPat+            <|> try seqPat             <|> parens (andPat                     <|> notPat'-                    <|> orderedOrPat                     <|> orPat                     <|> loopPat                     <|> letPat                     <|> laterPat-                    <|> bfsPat-                    <|> dfsPat                     <|> try divPat                     <|> try plusPat                     <|> try multPat@@ -651,9 +651,6 @@ orPat :: Parser EgisonPattern orPat = (reservedOp "|" <|> keywordOr) >> OrPat <$> sepEndBy pattern whiteSpace -orderedOrPat :: Parser EgisonPattern-orderedOrPat = reservedOp "|*" >> OrderedOrPat' <$> sepEndBy pattern whiteSpace- pApplyPat :: Parser EgisonPattern pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace @@ -667,8 +664,23 @@ loopRange = brackets (try (LoopRange <$> expr <*> expr <*> option WildCard pattern)                       <|> (do s <- expr                               ep <- option WildCard pattern-                              return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep)))+                              return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) +seqNilPat :: Parser EgisonPattern+seqNilPat = braces $ pure SeqNilPat++seqConsPat :: Parser EgisonPattern+seqConsPat = braces $ SeqConsPat <$> pattern <*> (char '@' >> pattern)++seqPat :: Parser EgisonPattern+seqPat = braces $ do+  pats <- sepEndBy pattern whiteSpace+  tailPat <- option SeqNilPat (char '@' >> pattern)+  return $ foldr (\p rets -> SeqConsPat p rets) tailPat pats++laterPatVar :: Parser EgisonPattern+laterPatVar = char '#' >> pure LaterPatVar+ divPat :: Parser EgisonPattern divPat = reservedOp "/" >> DivPat <$> pattern <*> pattern @@ -682,12 +694,6 @@ powerPat = try (PowerPat <$> pattern <* char '^' <*> pattern)             <|> pattern -dfsPat :: Parser EgisonPattern-dfsPat = keywordDFS >> DFSPat' <$> pattern--bfsPat :: Parser EgisonPattern-bfsPat = keywordBFS >> BFSPat <$> pattern- -- Constants  constantExpr :: Parser EgisonExpr@@ -696,8 +702,8 @@                  <|> try charExpr                  <|> try floatExpr                  <|> try integerExpr-                 <|> (keywordSomething *> pure SomethingExpr)-                 <|> (keywordUndefined *> pure UndefinedExpr)+                 <|> (keywordSomething $> SomethingExpr)+                 <|> (keywordUndefined $> UndefinedExpr)                  <?> "constant"  charExpr :: Parser EgisonExpr@@ -713,13 +719,11 @@ floatExpr = do   (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i')             <|> try ((,) 0 <$> floatLiteral' <* char 'i')-            <|> try (flip (,) 0 <$> floatLiteral')+            <|> try ((, 0) <$> floatLiteral')   return $ FloatExpr x y  integerExpr :: Parser EgisonExpr-integerExpr = do-  n <- integerLiteral'-  return $ IntegerExpr n+integerExpr = IntegerExpr <$> integerLiteral'  integerLiteral' :: Parser Integer integerLiteral' = sign <*> positiveIntegerLiteral@@ -733,8 +737,8 @@   char '.'   mStr <- many1 digit   let m = read mStr-  let l = m % (10 ^ (fromIntegral (length mStr)))-  return (fromRational ((fromIntegral n) + l) :: Double)+  let l = m % (10 ^ fromIntegral (length mStr))+  return (fromRational (fromIntegral n + l) :: Double)  floatLiteral' :: Parser Double floatLiteral' = sign <*> positiveFloatLiteral@@ -875,11 +879,11 @@ keywordLoop                 = reserved "loop" keywordCont                 = reserved "..." keywordMatchAll             = reserved "match-all"+keywordMatchAllDFS          = reserved "match-all-dfs" keywordMatchAllLambda       = reserved "match-all-lambda" keywordMatch                = reserved "match" keywordMatchLambda          = reserved "match-lambda" keywordMatcher              = reserved "matcher"-keywordMatcherDFS           = reserved "matcher-dfs" keywordDo                   = reserved "do" keywordIo                   = reserved "io" keywordSomething            = reserved "something"@@ -905,8 +909,6 @@ 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)@@ -939,7 +941,7 @@   return $ doParse' charLiteral $ "'" ++ x ++ "'"  boolLiteral :: Parser Bool-boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)+boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False)  whiteSpace :: Parser () whiteSpace = P.whiteSpace lexer@@ -975,9 +977,7 @@   return $ Var (splitOn "." name) is)  identVarWithoutIndex :: Parser Var-identVarWithoutIndex = do-    x <- ident-    return $ stringToVar x+identVarWithoutIndex = stringToVar <$> ident  identVarWithIndices :: Parser VarWithIndices identVarWithIndices = P.lexeme lexer (do@@ -994,7 +994,7 @@         <|> try (char '_' >> return (Subscript ()))  upperName :: Parser String-upperName = P.lexeme lexer $ upperName'+upperName = P.lexeme lexer upperName'  upperName' :: Parser String upperName' = (:) <$> upper <*> option "" ident@@ -1003,7 +1003,7 @@   upper = satisfy isUpper  lowerName :: Parser String-lowerName = P.lexeme lexer $ lowerName'+lowerName = P.lexeme lexer lowerName'  lowerName' :: Parser String lowerName' = (:) <$> lower <*> option "" ident

@@ -1,4 +1,5 @@-{-# LANGUAGE TupleSections, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections    #-}  {- | Module      : Language.Egison.ParserNonS@@ -24,34 +25,35 @@        , 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           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>))+import           Control.Monad.Except    hiding (mapM)+import           Control.Monad.Identity  hiding (mapM)+import           Control.Monad.State     hiding (mapM)+import           Prelude                 hiding (mapM) -import System.Directory (doesFileExist, getHomeDirectory)+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           Data.Char               (isLower, isUpper, toLower)+import           Data.Either+import           Data.Functor            (($>))+import           Data.List               (intercalate)+import           Data.List.Split         (split, splitOn, startsWithOneOf)+import           Data.Ratio+import qualified Data.Sequence           as Sq+import qualified Data.Set                as Set+import           Data.Traversable        (mapM) -import Text.Parsec-import Text.Parsec.String-import Text.Parsec.Expr-import qualified Text.Parsec.Token as P+import           Text.Parsec+import           Text.Parsec.Expr+import           Text.Parsec.String+import qualified Text.Parsec.Token       as P -import qualified Data.Text as T-import Text.Regex.TDFA+import qualified Data.Text               as T+import           Text.Regex.TDFA -import Language.Egison.Types-import Language.Egison.Desugar-import Paths_egison (getDataFileName)+import           Language.Egison.Desugar+import           Language.Egison.Types+import           Paths_egison            (getDataFileName)  readTopExprs :: String -> EgisonM [EgisonTopExpr] readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs@@ -92,7 +94,7 @@ -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] loadLibraryFile file = do-  homeDir <- liftIO $ getHomeDirectory+  homeDir <- liftIO getHomeDirectory   doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file   if doesExist     then loadFile $ homeDir ++ "/.egison/" ++ file@@ -107,12 +109,12 @@   exprs <- readTopExprs $ shebang input   concat <$> mapM  recursiveLoad exprs  where-  recursiveLoad (Load _ file) = loadLibraryFile file+  recursiveLoad (Load _ file)     = loadLibraryFile file   recursiveLoad (LoadFile _ file) = loadFile file-  recursiveLoad expr = return [expr]+  recursiveLoad expr              = return [expr]   shebang :: String -> String   shebang ('#':'!':cs) = ';':'#':'!':cs-  shebang cs = cs+  shebang cs           = cs  -- -- Parser@@ -141,24 +143,23 @@           <?> "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)+defineExpr = try (Define <$ keywordDefine <*> identVar <*> (LambdaExpr <$> parens argNames' <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr))+             <|> try (Define <$> identVar <* inSpaces (reservedOp "=") <* 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 . VarExpr . stringToVar . g) is)) body)))+                         inSpaces $ reservedOp "=" >> notFollowedBy (string "=")+                         Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr)  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 ()+  argName' = try (ScalarArg <$> ident)+        <|> try (InvertedScalarArg <$> (char '*' >> ident))+        <|> try (TensorArg <$> (char '%' >> ident))+  f (Superscript _)  = Superscript ()+  f (Subscript _)    = Subscript ()   f (SupSubscript _) = SupSubscript ()-  g (Superscript i) = i-  g (Subscript i) = i+  g (Superscript i)  = i+  g (Subscript i)    = i   g (SupSubscript i) = i  testExpr :: Parser EgisonTopExpr@@ -194,12 +195,12 @@           , [binary "&&" "and" AssocLeft, binary "||" "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]))+  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+    | 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)@@ -230,10 +231,10 @@ term' :: Parser EgisonExpr term' = matchExpr         <|> matchAllExpr+        <|> matchAllDFSExpr         <|> matchLambdaExpr         <|> matchAllLambdaExpr         <|> matcherExpr-        <|> matcherDFSExpr         <|> functionWithArgExpr         <|> userrefsExpr         <|> algebraicDataMatcherExpr@@ -314,7 +315,7 @@ wedgeExpr = char '!' >> WedgeExpr <$> expr  functionWithArgExpr :: Parser EgisonExpr-functionWithArgExpr = keywordFunction >> FunctionExpr <$> (parens $ sepEndBy expr comma)+functionWithArgExpr = keywordFunction >> FunctionExpr <$> parens (sepEndBy expr comma)  quoteSymbolExpr :: Parser EgisonExpr quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr@@ -322,6 +323,9 @@ matchAllExpr :: Parser EgisonExpr matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses +matchAllDFSExpr :: Parser EgisonExpr+matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <* keywordAs <*> expr <*> matchClauses+ matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses @@ -335,25 +339,22 @@ matchClauses = many1 matchClause  matchClause :: Parser MatchClause-matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* (reservedOp "->") <*> expr+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+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+pdMatchClause = try $ inSpaces (string "|") >> (,) <$> pdPattern <* reservedOp "->" <*> expr  ppPattern :: Parser PrimitivePatPattern ppPattern = P.lexeme lexer (ppWildCard@@ -363,10 +364,10 @@                         <?> "primitive-pattren-pattern")  ppWildCard :: Parser PrimitivePatPattern-ppWildCard = reservedOp "_" *> pure PPWildCard+ppWildCard = reservedOp "_" $> PPWildCard  ppPatVar :: Parser PrimitivePatPattern-ppPatVar = reservedOp "$" *> pure PPPatVar+ppPatVar = reservedOp "$" $> PPPatVar  ppValuePat :: Parser PrimitivePatPattern ppValuePat = reservedOp "$" >> PPValuePat <$> ident@@ -378,7 +379,7 @@ pdPattern = P.lexeme lexer pdPattern'  pdPattern' :: Parser PrimitiveDataPattern-pdPattern' = reservedOp "_" *> pure PDWildCard+pdPattern' = reservedOp "_" $> PDWildCard                     <|> (char '$' >> PDPatVar <$> ident)                     <|> brackets ((PDConsPat <$> pdPattern <* comma <*> (char '@' *> pdPattern))                             <|> (PDSnocPat <$> (char '@' *> pdPattern) <* comma <*> pdPattern)@@ -413,7 +414,7 @@ macroExpr = keywordMacro >> MacroExpr <$> varNames <* reservedOp "->" <*> expr  patternFunctionExpr :: Parser EgisonExpr-patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> (brackets $ sepEndBy ident comma) <* comma <*> pattern)+patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> brackets (sepEndBy ident comma) <* comma <*> pattern)  letRecExpr :: Parser EgisonExpr letRecExpr =  keywordLetRec >> LetRecExpr <$> bindings <* keywordLetIn <*> expr@@ -425,7 +426,7 @@ letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <* keywordLetIn <*> expr  withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident comma) <*> expr+withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident comma) <*> expr  doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr $ stringToVar "return") (TupleExpr [])) expr@@ -454,9 +455,9 @@ argNames = sepEndBy argName whiteSpace  argName :: Parser Arg-argName = try (char '$' >> ident >>= return . ScalarArg)-      <|> try (string "*$" >> ident >>= return . InvertedScalarArg)-      <|> try (char '%' >> ident >>= return . TensorArg)+argName = try (ScalarArg <$> (char '$' >> ident))+      <|> try (InvertedScalarArg <$> (string "*$" >> ident))+      <|> try (TensorArg <$> (char '%' >> ident))  ioExpr :: Parser EgisonExpr ioExpr = keywordIo >> parens (IoExpr <$> expr)@@ -473,15 +474,15 @@  applyExpr' :: Parser EgisonExpr applyExpr' = do-  func <- try varExpr <|> try partialExpr <|> try partialVarExpr <|> (parens expr)+  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+  return $ foldl makeApply func argslist  where-  args = sepEndBy arg $ comma+  args = sepEndBy arg comma   arg = try expr         <|> char '$' *> (LambdaArgExpr <$> option "" index)   index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit@@ -490,7 +491,7 @@ applyInfixExpr = do   arg1 <- arg   spaces-  func <- (char '`' *> varExpr <* char '`')+  func <- char '`' *> varExpr <* char '`'   spaces   arg2 <- arg   return $ makeApply func [arg1, arg2]@@ -503,30 +504,30 @@ makeApply func xs = do   let args = map (\x -> case x of                           LambdaArgExpr s -> Left s-                          _ -> Right x) xs+                          _               -> 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''+            args'' = zipWith (curry f) 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''+            args'' = zipWith (curry g) 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+  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))+partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> (try (parens expr) <|> expr))  where   index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit @@ -562,7 +563,7 @@                    xs <- parens $ sepEndBy expr comma                    case xs of                      [x, y] -> return $ UserrefsExpr False x y-                     _ -> unexpected "number of arguments (expected 2)")+                     _      -> unexpected "number of arguments (expected 2)")                 <|> (do keywordUserrefsNew                         xs <- parens $ sepEndBy expr comma                         case xs of@@ -583,21 +584,19 @@           , [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' "and" AndPat 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+  unary op assoc = Prefix (try $ inSpaces (string op) >> return NotPat)+  binary op name = Infix (try $ inSpaces (string op) >> return (\x y -> InductivePat name [x, y]))+  binary' op epr = Infix (try $ inSpaces (string op) >> return (\x y -> epr [x, y]))+  binary'' op epr = Infix (try $ inSpaces (string op) >> return epr)  pattern' :: Parser EgisonPattern pattern' = wildCard            <|> contPat            <|> try indexedPat            <|> patVar-           <|> try dfsPat-           <|> try bfsPat            <|> try loopPat            <|> try pApplyPat            <|> try dApplyPat@@ -658,13 +657,7 @@                  <|> (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+                         return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep)))  -- Constants @@ -674,8 +667,8 @@                  <|> try charExpr                  <|> try floatExpr                  <|> try integerExpr-                 <|> (keywordSomething *> pure SomethingExpr)-                 <|> (keywordUndefined *> pure UndefinedExpr)+                 <|> (keywordSomething $> SomethingExpr)+                 <|> (keywordUndefined $> UndefinedExpr)                  <?> "constant"  charExpr :: Parser EgisonExpr@@ -691,13 +684,11 @@ floatExpr = do   (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i')             <|> try ((,) 0 <$> floatLiteral' <* char 'i')-            <|> try (flip (,) 0 <$> floatLiteral')+            <|> try ((, 0) <$> floatLiteral')   return $ FloatExpr x y  integerExpr :: Parser EgisonExpr-integerExpr = do-  n <- integerLiteral'-  return $ IntegerExpr n+integerExpr = IntegerExpr <$> integerLiteral'  integerLiteral' :: Parser Integer integerLiteral' = sign <*> positiveIntegerLiteral@@ -711,8 +702,8 @@   char '.'   mStr <- many1 digit   let m = read mStr-  let l = m % (10 ^ (fromIntegral (length mStr)))-  return (fromRational ((fromIntegral n) + l) :: Double)+  let l = m % (10 ^ fromIntegral (length mStr))+  return (fromRational (fromIntegral n + l) :: Double)  floatLiteral' :: Parser Double floatLiteral' = sign <*> positiveFloatLiteral@@ -770,11 +761,11 @@   , "withSymbols"   , "loop"   , "matchAll"+  , "matchAllDFS"   , "matchAllLambda"   , "match"   , "matchLambda"   , "matcher"-  , "matcherDFS"   , "do"   , "io"   , "something"@@ -789,9 +780,7 @@   , "suprefs!"   , "userRefs"   , "userRefs!"-  , "function"-  , "dfs"-  , "bfs"]+  , "function"]  reservedOperators :: [String] reservedOperators =@@ -804,6 +793,8 @@   , ")"   , "->"   , "`"+  , "=="+  , "=" --  , "'" --  , "~" --  , "!"@@ -817,7 +808,7 @@ reservedOp :: String -> Parser () reservedOp = P.reservedOp lexer -keywordDefine               = reserved "define"+keywordDefine               = reserved "def" keywordSet                  = reserved "set!" keywordTest                 = reserved "test" keywordLoadFile             = reserved "loadFile"@@ -843,11 +834,11 @@ keywordLoop                 = reserved "loop" keywordCont                 = reserved "..." keywordMatchAll             = reserved "matchAll"+keywordMatchAllDFS          = reserved "matchAllDFS" keywordMatchAllLambda       = reserved "matchAllLambda" keywordMatch                = reserved "match" keywordMatchLambda          = reserved "matchLambda" keywordMatcher              = reserved "matcher"-keywordMatcherDFS           = reserved "matcherDFS" keywordDo                   = reserved "do" keywordIo                   = reserved "io" keywordSomething            = reserved "something"@@ -863,8 +854,6 @@ 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)@@ -897,7 +886,7 @@   return $ doParse' charLiteral $ "'" ++ x ++ "'"  boolLiteral :: Parser Bool-boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)+boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False)  whiteSpace :: Parser () whiteSpace = P.whiteSpace lexer@@ -929,8 +918,8 @@   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)+    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)@@ -942,9 +931,7 @@   return $ Var (splitOn "." name) is)  identVarWithoutIndex :: Parser Var-identVarWithoutIndex = do-  x <- ident-  return $ stringToVar x+identVarWithoutIndex = stringToVar <$> ident  identVarWithIndices :: Parser VarWithIndices identVarWithIndices = P.lexeme lexer (do@@ -961,7 +948,7 @@         <|> try (char '_' >> return (Subscript ()))  upperName :: Parser String-upperName = P.lexeme lexer $ upperName'+upperName = P.lexeme lexer upperName'  upperName' :: Parser String upperName' = (:) <$> upper <*> option "" ident@@ -970,7 +957,7 @@   upper = satisfy isUpper  lowerName :: Parser String-lowerName = P.lexeme lexer $ lowerName'+lowerName = P.lexeme lexer lowerName'  lowerName' :: Parser String lowerName' = (:) <$> lower <*> option "" ident

@@ -1,4 +1,5 @@-{-# Language FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase       #-}  {- | Module      : Language.Egison.Primitives@@ -10,35 +11,35 @@  module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where -import Control.Arrow-import Control.Monad.Except-import Control.Monad.Trans.Maybe-import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)+import           Control.Applicative       (pure, (*>), (<$>), (<*), (<*>))+import           Control.Arrow+import           Control.Monad.Except+import           Control.Monad.Trans.Maybe -import Data.IORef-import Data.Ratio-import Data.Foldable (toList)-import Text.Regex.TDFA+import           Data.Foldable             (toList)+import           Data.IORef+import           Data.Ratio+import           Text.Regex.TDFA -import System.IO-import System.Random-import System.Process+import           System.IO+import           System.Process+import           System.Random -import qualified Data.Sequence as Sq-import qualified Data.Vector as V+import qualified Data.Sequence             as Sq+import qualified Data.Vector               as V -import Data.Char (ord, chr)-import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Text.IO as T+import           Data.Char                 (chr, ord)+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import qualified Data.Text.IO              as T   {--  -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite  --}  -- for 'egison-sqlite' -import Language.Egison.Types-import Language.Egison.Parser-import Language.Egison.Core+import           Language.Egison.Core+import           Language.Egison.Parser+import           Language.Egison.Types  primitiveEnv :: IO Env primitiveEnv = do@@ -62,7 +63,7 @@     args' <- tupleToList args     case args' of       [] -> Value <$> f-      _ -> throwError $ ArgumentsNumPrimitive 0 $ length args'+      _  -> throwError $ ArgumentsNumPrimitive 0 $ length args'  {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc@@ -85,12 +86,12 @@ twoArgs f args = do   args' <- tupleToList args   case args' of-    [TensorData t1@(Tensor _ _ _), TensorData t2@(Tensor _ _ _)] -> Value <$> (tProduct f t1 t2 >>= fromTensor)+    [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+      ds' <- V.mapM (`f` val) ds       Value <$> fromTensor (Tensor ns ds' js)     [val, TensorData (Tensor ns ds js)] -> do-      ds' <- V.mapM (\d -> f val d) ds+      ds' <- V.mapM (f val) ds       Value <$> fromTensor (Tensor ns ds' js)     [val, val'] -> Value <$> f val val'     _ -> throwError $ ArgumentsNumPrimitive 2 $ length args'@@ -101,7 +102,7 @@   args' <- tupleToList args   case args' of     [val, val'] -> Value <$> f val val'-    _ -> throwError $ ArgumentsNumPrimitive 2 $ length args'+    _           -> throwError $ ArgumentsNumPrimitive 2 $ length args'  {-# INLINE threeArgs' #-} threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc@@ -109,7 +110,7 @@   args' <- tupleToList args   case args' of     [val, val', val''] -> Value <$> f val val' val''-    _ -> throwError $ ArgumentsNumPrimitive 3 $ length args'+    _                  -> throwError $ ArgumentsNumPrimitive 3 $ length args'  -- -- Constants@@ -342,7 +343,7 @@ toScalarData :: PrimitiveFunc toScalarData = oneArg toScalarData'  where-  toScalarData' val = (ScalarData . mathNormalize') <$> egisonToScalarData val+  toScalarData' val = ScalarData . mathNormalize' <$> egisonToScalarData val  -- -- Pred@@ -411,13 +412,13 @@ realPart =  oneArg realPart'  where   realPart' (Float x y) = return $ Float x 0-  realPart' val = throwError $ TypeMismatch "float" (Value val)+  realPart' val         = throwError $ TypeMismatch "float" (Value val)  imaginaryPart :: PrimitiveFunc imaginaryPart =  oneArg imaginaryPart'  where   imaginaryPart' (Float _ y) = return $ Float y 0-  imaginaryPart' val = throwError $ TypeMismatch "float" (Value val)+  imaginaryPart' val         = throwError $ TypeMismatch "float" (Value val)  -- -- Tensor@@ -553,7 +554,7 @@                                        ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []])))                                       (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),                                        ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []])))-                                      (ScalarData (Div (Plus [Term 1 [(Symbol _ _ _, 1)]]) (Plus [Term 1 []])),+                                      (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),                                        _) -> throwError $ TypeMismatch "symbol or integer" (Value sub)                                       _ ->  throwError $ TypeMismatch "symbol or integer" (Value fn) @@ -563,16 +564,16 @@                                          ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []])))                                         (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),                                          ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []])))-                                        (ScalarData (Div (Plus [Term 1 [(Symbol _ _ _, 1)]]) (Plus [Term 1 []])),+                                        (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),                                          _) -> throwError $ TypeMismatch "symbol" (Value sub)                                         _ ->  throwError $ TypeMismatch "symbol" (Value fn)  readProcess' :: PrimitiveFunc readProcess' = threeArgs' $ \cmd args input -> case (cmd, args, input) of                                                  (String cmdStr, Collection argStrs, String inputStr) -> do-                                                   outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\arg -> case arg of-                                                                                                                       String argStr -> T.unpack argStr)-                                                                                                             (toList argStrs)) (T.unpack inputStr)+                                                   outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\case+                                                                                                                String argStr -> T.unpack argStr)+                                                                                                                (toList argStrs)) (T.unpack inputStr)                                                    return (String (T.pack outputStr))                                                  (_, _, _) -> throwError $ TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) @@ -583,7 +584,7 @@ readTSV= oneArg' $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv)                               case rets of                                 [ret] -> return ret-                                _ -> return (Tuple rets)+                                _     -> return (Tuple rets)  show' :: PrimitiveFunc show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val@@ -662,7 +663,7 @@                ]  makeIO :: EgisonM EgisonValue -> EgisonValue-makeIO m = IOFunc $ liftM (Value . Tuple . (World :) . (:[])) m+makeIO m = IOFunc $ fmap (Value . Tuple . (World :) . (:[])) m  makeIO' :: EgisonM () -> EgisonValue makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []])@@ -712,7 +713,7 @@   return $ makeIO' $ liftIO $ hFlush port  readChar :: PrimitiveFunc-readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar+readChar = noArg $ return $ makeIO $ liftIO $ fmap Char getChar  readCharFromPort :: PrimitiveFunc readCharFromPort = oneArg' $ \val -> do@@ -721,7 +722,7 @@   return $ makeIO $ return (Char c)  readLine :: PrimitiveFunc-readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison T.getLine+readLine = noArg $ return $ makeIO $ liftIO $ fmap toEgison T.getLine  readLineFromPort :: PrimitiveFunc readLineFromPort = oneArg' $ \val -> do@@ -736,7 +737,7 @@   return $ makeIO $ return $ toEgison s  isEOFStdin :: PrimitiveFunc-isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF+isEOFStdin = noArg $ return $ makeIO $ liftIO $ fmap Bool isEOF  isEOFPort :: PrimitiveFunc isEOFPort = oneArg' $ \val -> do

@@ -1,6 +1,14 @@-{-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable,-             TypeFamilies, TupleSections, DeriveGeneric, TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE UndecidableInstances       #-} {- | Module      : Language.Egison.Types Copyright   : Satoshi Egi@@ -96,19 +104,11 @@     -- * Pattern matching     , Match     , PMMode (..)-    , pmMode     , MatchingTree (..)     , MatchingState (..)-    , MatchingStates (..)     , PatternBinding (..)     , LoopPatContext (..)-    , topDFS-    , containBFS-    -- * makeLenses-    , normalTree-    , orderedOrTrees-    , ids-    , bool+    , SeqPatContext (..)     -- * Errors     , EgisonError (..)     , liftError@@ -160,47 +160,50 @@     , varToVarWithIndices     ) where -import Prelude hiding (foldr, mappend, mconcat)+import           Prelude                   hiding (foldr, mappend, mconcat) -import Control.Exception-import Control.Parallel-import Control.Lens (makeLenses)-import Data.Typeable+import           Control.Exception+import           Control.Lens              (makeLenses)+import           Control.Parallel+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-import Control.Monad.Trans.Maybe+import           Control.Applicative+import           Control.Monad.Except+import           Control.Monad.Fail+import           Control.Monad.Identity+import           Control.Monad.Reader      (ReaderT)+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import           Control.Monad.Writer      (WriterT) -import Data.Monoid (Monoid)-import qualified Data.HashMap.Lazy as HL-import qualified Data.Array as Array-import qualified Data.Vector as V-import qualified Data.Sequence as Sq-import Data.Sequence (Seq)-import Data.Foldable (foldr, toList)-import Data.IORef-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Map (Map)+import qualified Data.Array                as Array+import           Data.Foldable             (foldr, toList)+import           Data.Hashable             (Hashable)+import qualified Data.HashMap.Lazy         as HL+import           Data.HashMap.Strict       (HashMap)+import qualified Data.HashMap.Strict       as HashMap+import           Data.IORef+import           Data.Map                  (Map)+import           Data.Monoid               (Monoid)+import           Data.Sequence             (Seq)+import qualified Data.Sequence             as Sq+import qualified Data.Vector               as V -import Data.List (intercalate, sort, sortBy, find, findIndex, splitAt, (\\), elem, delete, deleteBy, any, partition, intercalate, elemIndex)-import Data.List.Split (splitOn)-import Data.Text (Text, pack)-import qualified Data.Text as T+import           Data.List                 (any, delete, deleteBy, elem,+                                            elemIndex, find, findIndex,+                                            intercalate, partition, sort,+                                            sortBy, splitAt, (\\))+import           Data.List.Split           (splitOn)+import           Data.Text                 (Text, pack)+import qualified Data.Text                 as T -import System.IO-import Data.Ratio-import Numeric+import           Data.Ratio+import           Numeric+import           System.IO -import System.IO.Unsafe (unsafePerformIO)+import           System.IO.Unsafe          (unsafePerformIO) -import GHC.Generics (Generic)+import           GHC.Generics              (Generic)  -- -- Expressions@@ -253,11 +256,11 @@    | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr [MatchClause]+  | MatchAllDFSExpr EgisonExpr EgisonExpr [MatchClause]   | MatchLambdaExpr EgisonExpr [MatchClause]   | MatchAllLambdaExpr EgisonExpr [MatchClause]    | MatcherExpr MatcherInfo-  | MatcherDFSExpr MatcherInfo   | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]    | QuoteExpr EgisonExpr@@ -337,23 +340,21 @@   | NotPat EgisonPattern   | AndPat [EgisonPattern]   | OrPat [EgisonPattern]-  | OrderedOrPat' [EgisonPattern]-  | OrderedOrPat Id EgisonPattern EgisonPattern   | TuplePat [EgisonPattern]   | InductivePat String [EgisonPattern]   | LoopPat Var LoopRange EgisonPattern EgisonPattern   | ContPat   | PApplyPat EgisonExpr [EgisonPattern]   | VarPat String+  | SeqNilPat+  | SeqConsPat EgisonPattern EgisonPattern+  | LaterPatVar   -- For symbolic computing   | DApplyPat EgisonPattern [EgisonPattern]   | DivPat EgisonPattern EgisonPattern   | PlusPat [EgisonPattern]   | MultPat [EgisonPattern]   | PowerPat EgisonPattern EgisonPattern-  | DFSPat' EgisonPattern-  | DFSPat Id EgisonPattern-  | BFSPat EgisonPattern  deriving (Show, Eq)  data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern@@ -396,7 +397,7 @@   | IntHash (HashMap Integer EgisonValue)   | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)-  | UserMatcher Env MatcherInfo PMMode+  | UserMatcher Env MatcherInfo   | Func (Maybe Var) Env [String] EgisonExpr   | PartialFunc Env Integer EgisonExpr   | CFunc (Maybe Var) Env String EgisonExpr@@ -486,7 +487,7 @@   fromTensor t@Tensor{} = return $ TensorData t   fromTensor (Scalar x) = return x   toTensor (TensorData t) = return t-  toTensor x = return $ Scalar x+  toTensor x              = return $ Scalar x   undef = Undefined  instance HasTensor WHNFData where@@ -496,7 +497,7 @@   fromTensor t@Tensor{} = return $ Intermediate $ ITensor t   fromTensor (Scalar x) = return x   toTensor (Intermediate (ITensor t)) = return t-  toTensor x = return $ Scalar x+  toTensor x                          = return $ Scalar x   undef = Value Undefined  --@@ -524,10 +525,10 @@ symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, f js], toEgison n]  where-  f js = Collection (Sq.fromList (map (\j -> case j of-                                               Superscript k -> InductiveData "Sup" [ScalarData k]-                                               Subscript k -> InductiveData "Sub" [ScalarData k]-                                               Userscript k -> InductiveData "User" [ScalarData k]+  f js = Collection (Sq.fromList (map (\case+                                          Superscript k -> InductiveData "Sup" [ScalarData k]+                                          Subscript k -> InductiveData "Sub" [ScalarData k]+                                          Userscript k -> InductiveData "User" [ScalarData k]                                       ) js)) symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]@@ -535,10 +536,10 @@                                                                Nothing -> Tuple [InductiveData "Function" [symbolScalarData "" "", Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]                                                                Just name' -> Tuple [InductiveData "Function" [name', Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]  where-  f js = Collection (Sq.fromList (map (\j -> case j of-                                               Superscript k -> InductiveData "Sup" [ScalarData k]-                                               Subscript k -> InductiveData "Sub" [ScalarData k]-                                               Userscript k -> InductiveData "User" [ScalarData k]+  f js = Collection (Sq.fromList (map (\case+                                          Superscript k -> InductiveData "Sup" [ScalarData k]+                                          Subscript k -> InductiveData "Sub" [ScalarData k]+                                          Userscript k -> InductiveData "User" [ScalarData k]                                       ) js))  egisonToScalarData :: EgisonValue -> EgisonM ScalarData@@ -573,10 +574,10 @@ egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do   let js = toList seq   js' <- mapM (\j -> case j of-                         InductiveData "Sup" [ScalarData k] -> return (Superscript k)-                         InductiveData "Sub" [ScalarData k] -> return (Subscript k)-                         InductiveData "User" [ScalarData k] -> return (Userscript k)-                         _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j)+                       InductiveData "Sup" [ScalarData k] -> return (Superscript k)+                       InductiveData "Sub" [ScalarData k] -> return (Subscript k)+                       InductiveData "User" [ScalarData k] -> return (Userscript k)+                       _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j)                ) js   n' <- fromEgison n   case x of@@ -590,7 +591,7 @@   mExpr' <- egisonToScalarData mExpr   n' <- fromEgison n   return (Quote mExpr', n')-egisonToSymbolExpr (Tuple [InductiveData "Function" [name, (Collection argnames), (Collection args), Collection seq], n]) = do+egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args, Collection seq], n]) = do   let js = toList seq   js' <- mapM (\j -> case j of                          InductiveData "Sup" [ScalarData k] -> return (Superscript k)@@ -601,7 +602,7 @@   n' <- fromEgison n   let name' = case getSymName name of                 "" -> Nothing-                s -> Just $ name+                s  -> Just name   return (FunctionData name' (toList argnames) (toList args) js', n') egisonToSymbolExpr val = liftError $ throwError $ TypeMismatch "math symbol expression" (Value val) @@ -637,9 +638,9 @@   case z of     (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)))-                      else (Div (Plus (map (\t -> mathDivideTerm t z) ts1)) (Plus (map (\t -> mathDivideTerm t z) ts2)))-      _ -> (Div (Plus (map (\t -> mathDivideTerm t z) ts1)) (Plus (map (\t -> mathDivideTerm t z) ts2)))+                      then Div (Plus (map (`mathDivideTerm` Term (-1 * c) zs) ts1)) (Plus (map (`mathDivideTerm` Term (-1 * c) zs) ts2))+                      else Div (Plus (map (`mathDivideTerm` z) ts1)) (Plus (map (`mathDivideTerm` z) ts2))+      _ -> Div (Plus (map (`mathDivideTerm` z) ts1)) (Plus (map (`mathDivideTerm` z) ts2))  mathDivideTerm :: TermExpr -> TermExpr -> TermExpr mathDivideTerm (Term a xs) (Term b ys) =@@ -665,7 +666,7 @@ mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =   let p x = case x of               (_, 0) -> False-              _ -> True in+              _      -> True in   let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1 in   let ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2 in     Div (Plus ts1') (Plus ts2')@@ -676,7 +677,7 @@   let ts2' = filter (\(Term a _) -> a /= 0) ts2 in     case ts1' of       [] -> Div (Plus []) (Plus [Term 1 []])-      _ -> Div (Plus ts1') (Plus ts2')+      _  -> Div (Plus ts1') (Plus ts2')  mathFold :: ScalarData -> ScalarData mathFold mExpr = mathTermFold (mathSymbolFold (mathTermFold mExpr))@@ -695,7 +696,7 @@       else g (ret ++ [((x, n), 1)]) xs   p :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> Bool   p (Quote x, _) ((Quote y, _),_) = (x == y) || (mathNegate x == y)-  p (x, _) ((y, _),_) = x == y+  p (x, _) ((y, _),_)             = x == y   h :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> ((SymbolExpr, Integer), Integer)   h (Quote x, n) ((Quote y, m), sgn)     | x == y = ((Quote y, m + n), sgn)@@ -794,26 +795,29 @@  tSize :: Tensor a -> [Integer] tSize (Tensor ns _ _) = ns-tSize (Scalar _) = []+tSize (Scalar _)      = []  tToList :: Tensor a -> [a] tToList (Tensor _ xs _) = V.toList xs-tToList (Scalar x) = [x]+tToList (Scalar x)      = [x]  tToVector :: Tensor a -> V.Vector a tToVector (Tensor _ xs _) = xs-tToVector (Scalar x) = V.fromList [x]+tToVector (Scalar x)      = V.fromList [x]  tIndex :: Tensor a -> [Index EgisonValue] tIndex (Tensor _ _ js) = js-tIndex (Scalar _) = []+tIndex (Scalar _)      = []  tIntRef' :: HasTensor a => Integer -> Tensor a -> EgisonM a-tIntRef' i (Tensor [_] xs _) = fromTensor $ Scalar $ xs V.! (fromIntegral (i - 1))+tIntRef' i (Tensor [n] xs _) =+  if (0 < i) && (i <= n)+     then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1)+     else throwError $ TensorIndexOutOfBounds i n tIntRef' i (Tensor (n:ns) xs js) =   if (0 < i) && (i <= n)    then let w = fromIntegral (product ns) in-        let ys = V.take w (V.drop (w * (fromIntegral (i - 1))) xs) in+        let ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in           fromTensor $ Tensor ns ys (cdr js)    else throwError $ TensorIndexOutOfBounds i n tIntRef' i _ = throwError $ Default "More indices than the order of the tensor"@@ -885,7 +889,7 @@ transIndex [] [] is = return is transIndex (j1:js1) js2 is = do   let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2-  if tjs2 == []+  if null tjs2     then throwError InconsistentTensorIndex     else do let n = length hjs2 + 1             rs <- transIndex js1 (hjs2 ++ tail tjs2) (take (n - 1) is ++ drop n is)@@ -895,7 +899,7 @@ tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a) tTranspose is t@(Tensor ns xs js) = do   ns' <- transIndex js is ns-  xs' <- mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor >>= return . V.fromList+  xs' <- V.fromList <$> mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor   return $ Tensor ns' xs' is  tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EgisonM (Tensor a)@@ -904,8 +908,8 @@   tTranspose is' t  where   f :: Index EgisonValue -> EgisonValue-  f (Subscript i) = i-  f (Superscript i) = i+  f (Subscript i)    = i+  f (Superscript i)  = i   f (SupSubscript i) = i   g :: [EgisonValue] -> [Index EgisonValue] -> EgisonM [Index EgisonValue]   g [] js = return []@@ -917,9 +921,9 @@ tFlipIndices :: HasTensor a => Tensor a -> EgisonM (Tensor a) tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map flipIndex js)  where-  flipIndex (Subscript i) = Superscript i+  flipIndex (Subscript i)   = Superscript i   flipIndex (Superscript i) = Subscript i-  flipIndex x = x+  flipIndex x               = x  appendDFscripts :: Integer -> WHNFData -> EgisonM WHNFData appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do@@ -937,21 +941,21 @@   return (Intermediate (ITensor (Tensor s ys js)))  where   isDF (DFscript _ _) = True-  isDF _ = False+  isDF _              = False removeDFscripts (Value (TensorData (Tensor s xs is))) = do   let (ds, js) = partition isDF is   (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)   return (Value (TensorData (Tensor s ys js)))  where   isDF (DFscript _ _) = True-  isDF _ = False+  isDF _              = False removeDFscripts whnf = return whnf  tMap :: HasTensor a => (a -> EgisonM a) -> Tensor a -> EgisonM (Tensor a) tMap f (Tensor ns xs js') = do   let k = fromIntegral $ length ns - length js'   let js = js' ++ map (DFscript 0) [1..k]-  xs' <- mapM f (V.toList xs) >>= return . V.fromList+  xs' <- V.fromList <$> mapM f (V.toList xs)   t <- toTensor (V.head xs')   case t of     (Tensor ns1 _ js1') -> do@@ -979,7 +983,7 @@   let cns = take (length cjs) (tSize t1')   rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns)   rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns)-  rts' <- mapM (\(t1, t2) -> tProduct f t1 t2) (zip rts1 rts2)+  rts' <- zipWithM (tProduct f) rts1 rts2   let ret = Tensor (cns ++ tSize (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts'))   tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret  where@@ -987,14 +991,14 @@   h js1 js2 = let cjs = filter (`elem` js2) js1 in                 (cjs, js1 \\ cjs, js2 \\ cjs)   uniq :: [Index EgisonValue] -> [Index EgisonValue]-  uniq [] = []+  uniq []     = []   uniq (x:xs) = x:uniq (delete x xs)-tMap2 f t@(Tensor _ _ _) (Scalar x) = tMap (`f` x) t-tMap2 f (Scalar x) t@(Tensor _ _ _) = tMap (f x) t+tMap2 f t@Tensor{} (Scalar x) = tMap (`f` x) t+tMap2 f (Scalar x) t@Tensor{} = tMap (f x) t tMap2 f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2  tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a)-tDiag t@(Tensor _ _ js) = do+tDiag t@(Tensor _ _ js) =   case filter (\j -> any (p j) js) js of     [] -> return t     xs -> do@@ -1007,14 +1011,14 @@  where   p :: Index EgisonValue -> Index EgisonValue -> Bool   p (Superscript i) (Subscript j) = i == j-  p (Subscript i) _ = False-  p _ _ = False+  p (Subscript i) _               = False+  p _ _                           = False   rev :: Index EgisonValue -> Index EgisonValue   rev (Superscript i) = Subscript i-  rev (Subscript i) = Superscript i+  rev (Subscript i)   = Superscript i   g :: Index EgisonValue -> Index EgisonValue   g (Superscript i) = SupSubscript i-  g (Subscript i) = SupSubscript i+  g (Subscript i)   = SupSubscript i tDiag t = return t  tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue]@@ -1025,21 +1029,21 @@  where   p :: Index EgisonValue -> Index EgisonValue -> Bool   p (Superscript i) (Subscript j) = i == j-  p (Subscript _) _ = False-  p _ _ = False+  p (Subscript _) _               = False+  p _ _                           = False   rev :: Index EgisonValue -> Index EgisonValue   rev (Superscript i) = Subscript i-  rev (Subscript i) = Superscript i+  rev (Subscript i)   = Superscript i   g :: Index EgisonValue -> Index EgisonValue   g (Superscript i) = SupSubscript i-  g (Subscript i) = SupSubscript i+  g (Subscript i)   = SupSubscript i  tSum :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)-tSum f t1@(Tensor ns1 xs1 js1) t2@(Tensor _ _ _) = do+tSum f t1@(Tensor ns1 xs1 js1) t2@Tensor{} = do   t2' <- tTranspose js1 t2   case t2' of     (Tensor ns2 xs2 _)-      | ns2 == ns1 -> do ys <- V.mapM (\(x1,x2) -> f x1 x2) (V.zip xs1 xs2)+      | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2)                          return (Tensor ns1 ys js1)       | otherwise -> throwError InconsistentTensorSize @@ -1050,15 +1054,16 @@   let k2 = fromIntegral $ length ns2 - length js2'   let js2 = js2' ++ map (DFscript 0) [1..k2]   let (cjs1, cjs2, tjs1, tjs2) = h js1 js2-  let t1 = (Tensor ns1 xs1 js1)-  let t2 = (Tensor ns2 xs2 js2)+  let t1 = Tensor ns1 xs1 js1+  let t2 = Tensor ns2 xs2 js2   case cjs1 of     [] -> do-      xs' <- mapM (\is -> do let is1 = take (length ns1) is-                             let is2 = take (length ns2) (drop (length ns1) is)-                             x1 <- tIntRef is1 t1 >>= fromTensor-                             x2 <- tIntRef is2 t2 >>= fromTensor-                             f x1 x2) (enumTensorIndices (ns1 ++ ns2)) >>= return . V.fromList+      xs' <- V.fromList <$> mapM (\is -> do+                              let is1 = take (length ns1) is+                              let is2 = take (length ns2) (drop (length ns1) is)+                              x1 <- tIntRef is1 t1 >>= fromTensor+                              x2 <- tIntRef is2 t2 >>= fromTensor+                              f x1 x2) (enumTensorIndices (ns1 ++ ns2))       tContract' (Tensor (ns1 ++ ns2) xs' (js1 ++ js2))     _ -> do       t1' <- tTranspose (cjs1 ++ tjs1) t1@@ -1069,8 +1074,7 @@                               rt2 <- tIntRef is t2'                               tProduct f rt1 rt2) (enumTensorIndices cns1)       let ret = Tensor (cns1 ++ tSize (head rts')) (V.concat (map tToVector rts')) (map g cjs1 ++ tIndex (head rts'))-      ret2 <- tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret-      return ret2+      tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret  where   h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue])   h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in@@ -1078,15 +1082,15 @@   p :: Index EgisonValue -> Index EgisonValue -> Bool   p (Superscript i) (Subscript j) = i == j   p (Subscript i) (Superscript j) = i == j-  p _ _ = False+  p _ _                           = False   rev :: Index EgisonValue -> Index EgisonValue   rev (Superscript i) = Subscript i-  rev (Subscript i) = Superscript i+  rev (Subscript i)   = Superscript i   g :: Index EgisonValue -> Index EgisonValue   g (Superscript i) = SupSubscript i-  g (Subscript i) = SupSubscript i+  g (Subscript i)   = SupSubscript i   uniq :: [Index EgisonValue] -> [Index EgisonValue]-  uniq [] = []+  uniq []     = []   uniq (x:xs) = x:uniq (delete x xs) tProduct f (Scalar x) (Tensor ns xs js) = do   xs' <- V.mapM (f x) xs@@ -1107,23 +1111,23 @@     _ -> return [t']  tContract' :: HasTensor a => Tensor a -> EgisonM (Tensor a)-tContract' t@(Tensor ns xs js) = do+tContract' t@(Tensor ns xs js) =   case findPairs p js of     [] -> return t     ((m,n):_) -> do       let ns' = (ns !! m):removePairs (m,n) ns       let js' = (js !! m):removePairs (m,n) js       let (hjs, mjs, tjs) = removePairs' (m,n) js-      xs' <- mapM (\i -> (tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs-                                    ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t))+      xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs+                                    ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t)                   [1..(ns !! m)]       mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract'  where   p :: Index EgisonValue -> Index EgisonValue -> Bool-  p (Superscript i) (Superscript j) = i == j-  p (Subscript i) (Subscript j) = i == j+  p (Superscript i) (Superscript j)   = i == j+  p (Subscript i) (Subscript j)       = i == j   p (DFscript i1 j1) (DFscript i2 j2) = (i1 == i2) && (j1 == j2)-  p _ _ = False+  p _ _                               = False tContract' val = return val  -- utility functions for tensors@@ -1132,7 +1136,7 @@ nth i xs = xs !! fromIntegral (i - 1)  cdr :: [a] -> [a]-cdr [] = []+cdr []     = [] cdr (_:ts) = ts  split :: Integer -> V.Vector a -> [V.Vector a]@@ -1157,7 +1161,7 @@  getScalar :: Tensor a -> EgisonM a getScalar (Scalar x) = return x-getScalar _ = throwError $ Default "Inconsitent Tensor order"+getScalar _          = throwError $ Default "Inconsitent Tensor order"  findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)] findPairs p xs = reverse $ findPairs' 0 p xs@@ -1165,7 +1169,7 @@ findPairs' :: Int -> (a -> a -> Bool) -> [a] -> [(Int, Int)] findPairs' _ _ [] = [] findPairs' m p (x:xs) = case findIndex (p x) xs of-                    Just i -> (m, m + i + 1):findPairs' (m + 1) p xs+                    Just i  -> (m, m + i + 1):findPairs' (m + 1) p xs                     Nothing -> findPairs' (m + 1) p xs  removePairs :: (Int, Int) -> [a] -> [a]@@ -1235,7 +1239,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 _ _ _) = "#<user-matcher>"+  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@@ -1246,7 +1250,7 @@   show (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)"   show (Proc (Just name) _ _ _) = name   show (Macro names _) = "(macro [" ++ unwords names ++ "] ...)"-  show (PatternFunc _ _ _) = "#<pattern-function>"+  show PatternFunc{} = "#<pattern-function>"   show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"   show (IOFunc _) = "#<io-function>"   show (QuotedFunc _) = "#<quoted-function>"@@ -1257,18 +1261,18 @@   show EOF = "#<eof>"  instance Show Arg where-  show (ScalarArg name) = "$" ++ name+  show (ScalarArg name)         = "$" ++ name   show (InvertedScalarArg name) = "*$" ++ name-  show (TensorArg name) = "%" ++ name+  show (TensorArg name)         = "%" ++ name  instance Show ScalarData where   show (Div p1 (Plus [Term 1 []])) = show p1-  show (Div p1 p2) = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")"+  show (Div p1 p2)                 = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")"  instance Show PolyExpr where-  show (Plus []) = "0"+  show (Plus [])  = "0"   show (Plus [t]) = show t-  show (Plus ts) = "(+ " ++ unwords (map show ts)  ++ ")"+  show (Plus ts)  = "(+ " ++ unwords (map show ts)  ++ ")"  instance Show TermExpr where   show (Term a []) = show a@@ -1286,7 +1290,7 @@   show (Symbol _ s js) = s ++ concatMap show js   show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")"   show (Quote mExprs) = "'" ++ show mExprs-  show (FunctionData Nothing argnames args js) = "(function [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js+  show (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js   show (FunctionData (Just name) argnames args js) = show name ++ concatMap show js  showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String@@ -1401,15 +1405,15 @@  fromCharValue :: EgisonValue -> Either EgisonError Char fromCharValue (Char c) = return c-fromCharValue val = throwError $ TypeMismatch "char" (Value val)+fromCharValue val      = throwError $ TypeMismatch "char" (Value val)  fromStringValue :: EgisonValue -> Either EgisonError Text fromStringValue (String str) = return str-fromStringValue val = throwError $ TypeMismatch "string" (Value val)+fromStringValue val          = throwError $ TypeMismatch "string" (Value val)  fromBoolValue :: EgisonValue -> Either EgisonError Bool fromBoolValue (Bool b) = return b-fromBoolValue val = throwError $ TypeMismatch "bool" (Value val)+fromBoolValue val      = throwError $ TypeMismatch "bool" (Value val)  fromIntegerValue :: EgisonValue -> Either EgisonError Integer fromIntegerValue (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0@@ -1423,11 +1427,11 @@  fromFloatValue :: EgisonValue -> Either EgisonError Double fromFloatValue (Float f 0) = return f-fromFloatValue val = throwError $ TypeMismatch "float" (Value val)+fromFloatValue val         = throwError $ TypeMismatch "float" (Value val)  fromPortValue :: EgisonValue -> Either EgisonError Handle fromPortValue (Port h) = return h-fromPortValue val = throwError $ TypeMismatch "port" (Value val)+fromPortValue val      = throwError $ TypeMismatch "port" (Value val)  -- -- Internal Data@@ -1471,7 +1475,7 @@   show (Intermediate (ITensor (Tensor ns xs _))) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]"  instance Show Object where-  show (Thunk _) = "#<thunk>"+  show (Thunk _)   = "#<thunk>"   show (WHNF whnf) = show whnf  instance Show ObjectRef where@@ -1505,15 +1509,15 @@  fromCharWHNF :: WHNFData -> Either EgisonError Char fromCharWHNF (Value (Char c)) = return c-fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf+fromCharWHNF whnf             = throwError $ TypeMismatch "char" whnf  fromStringWHNF :: WHNFData -> Either EgisonError Text fromStringWHNF (Value (String str)) = return str-fromStringWHNF whnf = throwError $ TypeMismatch "string" whnf+fromStringWHNF whnf                 = throwError $ TypeMismatch "string" whnf  fromBoolWHNF :: WHNFData -> Either EgisonError Bool fromBoolWHNF (Value (Bool b)) = return b-fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf+fromBoolWHNF whnf             = throwError $ TypeMismatch "bool" whnf  fromIntegerWHNF :: WHNFData -> Either EgisonError Integer fromIntegerWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0@@ -1522,11 +1526,11 @@  fromFloatWHNF :: WHNFData -> Either EgisonError Double fromFloatWHNF (Value (Float f 0)) = return f-fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf+fromFloatWHNF whnf                = throwError $ TypeMismatch "float" whnf  fromPortWHNF :: WHNFData -> Either EgisonError Handle fromPortWHNF (Value (Port h)) = return h-fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf+fromPortWHNF whnf             = throwError $ TypeMismatch "port" whnf  class (EgisonWHNF a) => EgisonObject a where   toObject :: a -> Object@@ -1559,32 +1563,32 @@   show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is  instance Show (Index ()) where-  show (Superscript ()) = "~"-  show (Subscript ()) = "_"+  show (Superscript ())  = "~"+  show (Subscript ())    = "_"   show (SupSubscript ()) = "~_"-  show (DFscript _ _) = ""-  show (Userscript _) = "|"+  show (DFscript _ _)    = ""+  show (Userscript _)    = "|"  instance Show (Index String) where-  show (Superscript s) = "~" ++ s-  show (Subscript s) = "_" ++ s+  show (Superscript s)  = "~" ++ s+  show (Subscript s)    = "_" ++ s   show (SupSubscript s) = "~_" ++ s-  show (DFscript _ _) = ""-  show (Userscript i) = "|" ++ show i+  show (DFscript _ _)   = ""+  show (Userscript i)   = "|" ++ show i  instance Show (Index EgisonExpr) where-  show (Superscript i) = "~" ++ show i-  show (Subscript i) = "_" ++ show i+  show (Superscript i)  = "~" ++ show i+  show (Subscript i)    = "_" ++ show i   show (SupSubscript i) = "~_" ++ show i-  show (DFscript _ _) = ""-  show (Userscript i) = "|" ++ show i+  show (DFscript _ _)   = ""+  show (Userscript i)   = "|" ++ show i  instance Show (Index ScalarData) where-  show (Superscript i) = "~" ++ show i-  show (Subscript i) = "_" ++ show i+  show (Superscript i)  = "~" ++ show i+  show (Subscript i)    = "_" ++ show i   show (SupSubscript i) = "~_" ++ show i-  show (DFscript _ _) = ""-  show (Userscript i) = "|" ++ show i+  show (DFscript _ _)   = ""+  show (Userscript i)   = "|" ++ show i  instance Show (Index EgisonValue) where   show (Superscript i) = case i of@@ -1614,58 +1618,26 @@  type Match = [Binding] -data PMMode = BFSMode | DFSMode Id+data PMMode = BFSMode | DFSMode  deriving (Show) -data MatchingState = MState PMMode Env [LoopPatContext] [Binding] [MatchingTree]+data MatchingState = MState Env [LoopPatContext] [SeqPatContext] [Binding] [MatchingTree]  instance Show MatchingState where-  show (MState mode _ _ bindings mtrees) = "(MState " ++ intercalate " " [show mode, "_", "_", show bindings, show mtrees] ++ ")"--pmMode :: MatchingState -> PMMode-pmMode (MState mode _ _ _ _) = mode+  show (MState _ _ _ bindings mtrees) = "(MState " ++ unwords ["_", "_", "_", show bindings, show mtrees] ++ ")"  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 _ (pattern:_)) = topDFS pattern-topDFS (LetPat _ pattern) = topDFS pattern-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 (LetPat _ pattern) = containBFS pattern-containBFS _ = False+data SeqPatContext = SeqPatContext [MatchingTree] EgisonPattern [Matcher] [WHNFData]+ deriving (Show)  -- -- Errors@@ -1754,6 +1726,7 @@ fromEgisonM :: EgisonM a -> IO (Either EgisonError a) fromEgisonM = modifyCounter . runEgisonM +{-# NOINLINE counter #-} counter :: IORef (Int, Int) counter = unsafePerformIO (newIORef (0, 0)) @@ -1789,24 +1762,24 @@   catchError m h = FreshT $ catchError (unFreshT m) (unFreshT . h)  instance (MonadState s m) => MonadState s (FreshT m) where-  get = lift $ get+  get = lift get   put s = lift $ put s  instance (MonadFresh m) => MonadFresh (StateT s m) where-  fresh = lift $ fresh-  freshV = lift $ freshV+  fresh = lift fresh+  freshV = lift freshV  instance (MonadFresh m) => MonadFresh (ExceptT e m) where-  fresh = lift $ fresh-  freshV = lift $ freshV+  fresh = lift fresh+  freshV = lift freshV  instance (MonadFresh m, Monoid e) => MonadFresh (ReaderT e m) where-  fresh = lift $ fresh-  freshV = lift $ freshV+  fresh = lift fresh+  freshV = lift freshV  instance (MonadFresh m, Monoid e) => MonadFresh (WriterT e m) where-  fresh = lift $ fresh-  freshV = lift $ freshV+  fresh = lift fresh+  freshV = lift freshV  instance MonadIO (FreshT IO) where   liftIO = lift@@ -1826,7 +1799,7 @@ data MList m a = MNil | MCons a (m (MList m a))  instance Show a => Show (MList m a) where-  show MNil = "MNil"+  show MNil        = "MNil"   show (MCons x _) = "(MCons " ++ show x ++ " ...)"  fromList :: Monad m => [a] -> MList m a@@ -1845,7 +1818,7 @@ msingleton = flip MCons $ return MNil  mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b-mfoldr f init MNil = init+mfoldr f init MNil         = init mfoldr f init (MCons x xs) = f x (xs >>= mfoldr f init)  mappend :: Monad m => MList m a -> m (MList m a) -> m (MList m a)@@ -1856,7 +1829,7 @@  mmap :: Monad m => (a -> m b) -> MList m a -> m (MList m b) mmap f = mfoldr g $ return MNil-  where g x xs = f x >>= return . flip MCons xs+  where g x xs = flip MCons xs <$> f x  mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b) mfor = flip mmap@@ -1865,87 +1838,87 @@  isBool :: EgisonValue -> Bool isBool (Bool _) = True-isBool _ = False+isBool _        = False  isBool' :: PrimitiveFunc isBool' (Value val) = return $ Value $ Bool $ isBool val  isInteger :: EgisonValue -> Bool-isInteger (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = True+isInteger (ScalarData (Div (Plus []) (Plus [Term 1 []])))          = True isInteger (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True-isInteger _ = False+isInteger _                                                        = False  isInteger' :: PrimitiveFunc isInteger' (Value val) = return $ Value $ Bool $ isInteger val  isRational :: EgisonValue -> Bool-isRational (ScalarData (Div (Plus []) (Plus [Term _ []]))) = True+isRational (ScalarData (Div (Plus []) (Plus [Term _ []])))          = True isRational (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []]))) = True-isRational _ = False+isRational _                                                        = False  isRational' :: PrimitiveFunc isRational' (Value val) = return $ Value $ Bool $ isRational val  isSymbol :: EgisonValue -> Bool-isSymbol (ScalarData (Div (Plus [Term 1 [(Symbol _ _ _, 1)]]) (Plus [Term 1 []]))) = True+isSymbol (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []]))) = True isSymbol _ = False  isScalar :: EgisonValue -> Bool isScalar (ScalarData _) = True-isScalar _ = False+isScalar _              = False  isScalar' :: PrimitiveFunc isScalar' (Value val) = return $ Value $ Bool $ isScalar val-isScalar' _ = return $ Value $ Bool False+isScalar' _           = return $ Value $ Bool False  isTensor :: EgisonValue -> Bool isTensor (TensorData _) = True-isTensor _ = False+isTensor _              = False  isTensor' :: PrimitiveFunc isTensor' (Value val) = return $ Value $ Bool $ isTensor val-isTensor' _ = return $ Value $ Bool False+isTensor' _           = return $ Value $ Bool False  isTensorWithIndex :: EgisonValue -> Bool isTensorWithIndex (TensorData (Tensor _ _ (_:_))) = True-isTensorWithIndex _ = False+isTensorWithIndex _                               = False  isTensorWithIndex' :: PrimitiveFunc isTensorWithIndex' (Value val) = return $ Value $ Bool $ isTensorWithIndex val-isTensorWithIndex' _ = return $ Value $ Bool False+isTensorWithIndex' _           = return $ Value $ Bool False  isFloat' :: PrimitiveFunc isFloat' (Value (Float _ 0)) = return $ Value $ Bool True-isFloat' _ = return $ Value $ Bool False+isFloat' _                   = return $ Value $ Bool False  isComplex' :: PrimitiveFunc isComplex' (Value (Float _ _)) = return $ Value $ Bool True-isComplex' _ = return $ Value $ Bool False+isComplex' _                   = return $ Value $ Bool False  isChar' :: PrimitiveFunc isChar' (Value (Char _)) = return $ Value $ Bool True-isChar' _ = return $ Value $ Bool False+isChar' _                = return $ Value $ Bool False  isString' :: PrimitiveFunc isString' (Value (String _)) = return $ Value $ Bool True-isString' _ = return $ Value $ Bool False+isString' _                  = return $ Value $ Bool False  isCollection' :: PrimitiveFunc-isCollection' (Value (Collection _)) = return $ Value $ Bool True+isCollection' (Value (Collection _))         = return $ Value $ Bool True isCollection' (Intermediate (ICollection _)) = return $ Value $ Bool True-isCollection' _ = return $ Value $ Bool False+isCollection' _                              = return $ Value $ Bool False  isArray' :: PrimitiveFunc-isArray' (Value (Array _)) = return $ Value $ Bool True+isArray' (Value (Array _))         = return $ Value $ Bool True isArray' (Intermediate (IArray _)) = return $ Value $ Bool True-isArray' _ = return $ Value $ Bool False+isArray' _                         = return $ Value $ Bool False  isHash' :: PrimitiveFunc-isHash' (Value (IntHash _)) = return $ Value $ Bool True-isHash' (Value (StrHash _)) = return $ Value $ Bool True+isHash' (Value (IntHash _))         = return $ Value $ Bool True+isHash' (Value (StrHash _))         = return $ Value $ Bool True isHash' (Intermediate (IIntHash _)) = return $ Value $ Bool True isHash' (Intermediate (IStrHash _)) = return $ Value $ Bool True-isHash' _ = return $ Value $ Bool False+isHash' _                           = return $ Value $ Bool False  readUTF8File :: FilePath -> IO String readUTF8File name = do@@ -1960,8 +1933,6 @@ varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is  where    f :: Index () -> Index String-   f (Superscript ()) = Superscript ""-   f (Subscript ()) = Subscript ""+   f (Superscript ())  = Superscript ""+   f (Subscript ())    = Subscript ""    f (SupSubscript ()) = SupSubscript ""--makeLenses ''MatchingStates

@@ -8,14 +8,14 @@  module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgison) where -import Data.List-import Text.Regex.TDFA-import System.Console.Haskeline hiding (handle, catch, throwTo)-import Control.Monad.Except (liftIO)+import           Control.Monad.Except       (liftIO)+import           Data.List+import           System.Console.Haskeline   hiding (catch, handle, throwTo)+import           Text.Regex.TDFA -import Language.Egison.Types-import Language.Egison.Parser as Parser-import Language.Egison.ParserNonS as ParserNonS+import           Language.Egison.Parser     as Parser+import           Language.Egison.ParserNonS as ParserNonS+import           Language.Egison.Types  -- |Get Egison expression from the prompt. We can handle multiline input. getEgisonExpr :: Bool -> String -> InputT IO (Maybe (String, EgisonTopExpr))@@ -25,20 +25,20 @@ getEgisonExpr' isSExpr prompt prev = do   mLine <- case prev of              "" -> getInputLine prompt-             _ -> getInputLine $ take (length prompt) (repeat ' ')+             _  -> getInputLine $ replicate (length prompt) ' '   case mLine of     Nothing -> return Nothing-    Just [] -> do+    Just [] ->       if null prev         then getEgisonExpr isSExpr prompt         else getEgisonExpr' isSExpr prompt prev     Just line -> do       let input = prev ++ line       case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of-        Left err | show err =~ "unexpected end of input" -> do+        Left err | show err =~ "unexpected end of input" ->           getEgisonExpr' isSExpr prompt $ input ++ "\n"         Left err -> do-          liftIO $ putStrLn $ show err+          liftIO $ print err           getEgisonExpr isSExpr prompt         Right topExpr -> return $ Just (input, topExpr) @@ -50,33 +50,33 @@ getEgisonExprOrNewLine' isSExpr prompt prev = do   mLine <- case prev of              "" -> getInputLine prompt-             _ -> getInputLine $ take (length prompt) (repeat ' ')+             _  -> getInputLine $ replicate (length prompt) ' '   case mLine of     Nothing -> return $ Left Nothing     Just [] -> return $ Left $ Just ""     Just line -> do       let input = prev ++ line       case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of-        Left err | show err =~ "unexpected end of input" -> do+        Left err | show err =~ "unexpected end of input" ->           getEgisonExprOrNewLine' isSExpr prompt $ input ++ "\n"         Left err -> do-          liftIO $ putStrLn $ show err+          liftIO $ print err           getEgisonExprOrNewLine isSExpr prompt         Right topExpr -> return $ Right (input, topExpr)  -- |Complete Egison keywords completeEgison :: Monad m => CompletionFunc m-completeEgison arg@((')':_), _) = completeParen arg-completeEgison arg@(('>':_), _) = completeParen arg-completeEgison arg@((']':_), _) = completeParen arg-completeEgison arg@(('}':_), _) = completeParen arg-completeEgison arg@(('(':_), _) = (completeWord Nothing " \t<>[]{}$," completeAfterOpenParen) arg-completeEgison arg@(('<':_), _) = (completeWord Nothing " \t()[]{}$," completeAfterOpenCons) arg-completeEgison arg@((' ':_), _) = (completeWord Nothing "" completeNothing) arg-completeEgison arg@(('[':_), _) = (completeWord Nothing "" completeNothing) arg-completeEgison arg@(('{':_), _) = (completeWord Nothing "" completeNothing) arg-completeEgison arg@([], _) = (completeWord Nothing "" completeNothing) arg-completeEgison arg@(_, _) = (completeWord Nothing " \t[]{}$," completeEgisonKeyword) arg+completeEgison arg@(')':_, _) = completeParen arg+completeEgison arg@('>':_, _) = completeParen arg+completeEgison arg@(']':_, _) = completeParen arg+completeEgison arg@('}':_, _) = completeParen arg+completeEgison arg@('(':_, _) = completeWord Nothing " \t<>[]{}$," completeAfterOpenParen arg+completeEgison arg@('<':_, _) = completeWord Nothing " \t()[]{}$," completeAfterOpenCons arg+completeEgison arg@(' ':_, _) = completeWord Nothing "" completeNothing arg+completeEgison arg@('[':_, _) = completeWord Nothing "" completeNothing arg+completeEgison arg@('{':_, _) = completeWord Nothing "" completeNothing arg+completeEgison arg@([], _) = completeWord Nothing "" completeNothing arg+completeEgison arg@(_, _) = completeWord Nothing " \t[]{}$," completeEgisonKeyword arg  completeAfterOpenParen :: Monad m => String -> m [Completion] completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) $ egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen@@ -90,44 +90,43 @@ completeEgisonKeyword :: Monad m => String -> m [Completion] completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords -egisonPrimitivesAfterOpenParen = map ((:) '(') $ ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"]-egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"]+egisonPrimitivesAfterOpenParen = map ((:) '(') ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"]+egisonKeywordsAfterOpenParen = map ((:) '(') ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"]                             ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "sort", "intersperse", "intercalate", "split", "split/m"] egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"]-egisonKeywordsInNeutral = ["something"]-                       ++ ["bool", "string", "integer", "nats", "primes"]+egisonKeywordsInNeutral = "something" : ["bool", "string", "integer", "nats", "primes"] egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral  completeParen :: Monad m => CompletionFunc m-completeParen (lstr, _) = case (closeParen lstr) of-  Nothing -> return (lstr, [])-  Just paren -> return (lstr, [(Completion paren paren False)])+completeParen (lstr, _) = case closeParen lstr of+  Nothing    -> return (lstr, [])+  Just paren -> return (lstr, [Completion paren paren False])  closeParen :: String -> Maybe String closeParen str = closeParen' 0 $ removeCharAndStringLiteral str  removeCharAndStringLiteral :: String -> String removeCharAndStringLiteral [] = []-removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':(removeCharAndStringLiteral str)+removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':(removeCharAndStringLiteral str)+removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':removeCharAndStringLiteral str removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral (c:str) = c:(removeCharAndStringLiteral str)+removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str  removeCharAndStringLiteral' :: String -> String-removeCharAndStringLiteral' [] = []-removeCharAndStringLiteral' ('"':'\\':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral' ('"':str) = removeCharAndStringLiteral str+removeCharAndStringLiteral' []              = []+removeCharAndStringLiteral' ('"':'\\':str)  = removeCharAndStringLiteral' str+removeCharAndStringLiteral' ('"':str)       = removeCharAndStringLiteral str removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral' ('\'':str) = removeCharAndStringLiteral str-removeCharAndStringLiteral' (_:str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral' ('\'':str)      = removeCharAndStringLiteral str+removeCharAndStringLiteral' (_:str)         = removeCharAndStringLiteral' str  closeParen' :: Integer -> String -> Maybe String-closeParen' _ [] = Nothing-closeParen' 0 ('(':_) = Just ")"-closeParen' 0 ('<':_) = Just ">"-closeParen' 0 ('[':_) = Just "]"-closeParen' 0 ('{':_) = Just "}"+closeParen' _ []        = Nothing+closeParen' 0 ('(':_)   = Just ")"+closeParen' 0 ('<':_)   = Just ">"+closeParen' 0 ('[':_)   = Just "]"+closeParen' 0 ('{':_)   = Just "}" closeParen' n ('(':str) = closeParen' (n - 1) str closeParen' n ('<':str) = closeParen' (n - 1) str closeParen' n ('[':str) = closeParen' (n - 1) str@@ -136,4 +135,4 @@ closeParen' n ('>':str) = closeParen' (n + 1) str closeParen' n (']':str) = closeParen' (n + 1) str closeParen' n ('}':str) = closeParen' (n + 1) str-closeParen' n (_:str) = closeParen' n str+closeParen' n (_:str)   = closeParen' n str

@@ -36,12 +36,12 @@     (if (gt? x y) x y)))  (define $min/fn-  (lambda [$compare $x $y]-    (if (eq? (compare x y) <Less>) x y)))+  (lambda [$f $xs]+    (foldl 2#(if (eq? (f %1 %2) <Less>) %1 %2) (car xs) (cdr xs))))  (define $max/fn-  (lambda [$compare $x $y]-    (if (eq? (compare x y) <Greater>) x y)))+  (lambda [$f $xs]+    (foldl 2#(if (eq? (f %1 %2) <Greater>) %1 %2) (car xs) (cdr xs))))  (define $min (cambda $xs (foldl b.min (car xs) (cdr xs)))) (define $max (cambda $xs (foldl b.max (car xs) (cdr xs))))

@@ -97,6 +97,12 @@       [(map 1#(lambda [$i] (nth i %1)) es)        (map 1#(lambda [$i] (nth i %1)) os)]))) +(define $even-and-odd-permutations0+  (lambda [$n]+    (let {[[$es $os] (even-and-odd-permutations' n)]}+      [(map 1#(lambda [$i] (nth (+ i 1) (map (- $ 1) %1))) es)+       (map 1#(lambda [$i] (nth (+ i 1) (map (- $ 1) %1))) os)])))+ (define $even-and-odd-permutations'   (lambda [$n]     (match n integer

@@ -28,7 +28,7 @@ (define $.   (cambda $xs     (match xs (list something)-      {[<join _ <cons (& ?scalar? ?tensor-symbol?) _>> (capply `. xs)]+      {;[<join _ <cons (& ?scalar? ?tensor-symbol?) _>> (capply `. xs)]        [_ (foldl b.. (car xs) (cdr xs))]})))  (define $T.+

@@ -0,0 +1,43 @@+(define $delete-literals+  (lambda [$ls $cnf]+    (map (lambda [$c] (match-all [c ls] [(multiset integer) (multiset integer)]+                        [[<cons $l _> !<cons ,l _>] l]))+         cnf)))++(define $delete-clauses-with+  (lambda [$ls $cnf]+    (match-all [ls cnf] [(multiset integer) (multiset (multiset integer))]+      [{[# <cons (& # $c) _>]+        ![<cons $l _> <cons ,l _>]}+       c])))++(define $assign-true+  (lambda [$l $cnf]+    (delete-literals {(neg l)} (delete-clauses-with {l} cnf))))++(define $resolve-on+  (lambda [$v $cnf]+    (match-all cnf (multiset (multiset integer))+      [{<cons <cons ,v (& # $xs)>+         <cons <cons ,(neg v) (and # $ys)>+          _>>+        ![<cons $l _> <cons ,(neg l) _>]}+       (unique {@xs @ys})])))++(define $dp+  (lambda [$vars $cnf]+    (match [vars cnf] [(multiset integer) (multiset (multiset integer))]+      {[[_ <nil>] #t]+       [[_ <cons <nil> _>] #f]+       [[_ <cons <cons $l <nil>> _>] (dp (delete (abs l) vars) (assign-true l cnf))]+       [[<cons $v $vs> !<cons <cons ,(neg v) _> _>] (dp vs (assign-true v cnf))]+       [[<cons $v $vs> !<cons <cons ,v _> _>] (dp vs (assign-true (neg v) cnf))]+       [[<cons $v $vs> _] (dp vs {@(resolve-on v cnf) @(delete-clauses-with {v (neg v)} cnf)})]})))++(dp {1} {{1}}) ; #t+(dp {1} {{1} {-1}}) ; #f+(dp {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t+(dp {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t+(dp {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f+(dp {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #t+(dp {1 2} {{-1 -2} {1}}) ; #t

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

@@ -1,54 +0,0 @@-(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'

@@ -1,37 +0,0 @@-(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'

@@ -0,0 +1,23 @@+(define $lexical-compare+  (lambda [$xs $ys]+    (match [xs ys] [(list ordering) (list ordering)]+      {[[<nil> <nil>] <Equal>]+       [[<nil> _] <Less>]+       [[_ <nil>] <Greater>]+       [[<cons $x $xs'> <cons ,x $ys'>] (lexical-compare xs' ys')]+       [[<cons $x _> <cons $y _>] (compare x y)]})))+++(define $lexical-compare+  (lambda [$xs $ys]+    (match [xs ys] [(list ordering) (list ordering)]+      {[(loop $i [1 _]+          {[<cons $x_i #> <cons ,x_i #>]+           @...}+          (& ![<cons $y _> <cons ,y _>]+             [$xs' $ys']))+        (match [xs' ys'] [(list ordering) (list ordering)]+          {[[<nil> <nil>] <Equal>]+           [[<nil> _] <Less>]+           [[_ <nil>] <Greater>]+           [[<cons $x _> <cons $y _>] (compare x y)]})]})))

@@ -0,0 +1,34 @@+;;;+;;; Travelling Salesman Problem+;;;++(define $station string)+(define $price   integer)+(define $graph   (multiset [station (multiset [station price])]))++(define $graph-data+  {["Berlin"    {              ["St. Louis" 14] ["Oxford"  2] ["Nara" 14] ["Vancouver" 13]}]+   ["St. Louis" {["Berlin" 14]                  ["Oxford" 12] ["Nara" 18] ["Vancouver"  6]}]+   ["Oxford"    {["Berlin"  2] ["St. Louis" 12]               ["Nara" 15] ["Vancouver" 10]}]+   ["Nara"      {["Berlin" 14] ["St. Louis" 18] ["Oxford" 15]             ["Vancouver" 12]}]+   ["Vancouver" {["Berlin" 13] ["St. Louis"  6] ["Oxford" 10] ["Nara" 12]                 }]})+++(define $trips ; List up all routes that visit each city exactly once and return to Tokyo+  (match-all graph-data graph+    [<cons [,"Berlin" <cons [$s_1 $p_1] _>]+           (loop $i [2 4]+             <cons [,s_(- i 1) <cons [$s_i $p_i] _>]+                   ...>+             <cons [,s_4 <cons [(& ,"Berlin" $s_5) $p_5] _>]+                   _>)>+     [(sum (map (lambda [$i] p_i) (between 1 5)))+      s]]))++(define $main+  (lambda [$args]+    (do {[(print "Route list:")]+         [(each (compose show print) trips)]+         [(write "Lowest price:")]+         [(print (show (min (map (lambda [$x $y] x) trips))))]})))+