packages feed

egison 4.1.2 → 4.1.3

raw patch · 85 files changed

+1448/−1065 lines, 85 filesdep −arraydep −ghcdep −ghc-pathsdep ~basedep ~containersdep ~directorysetup-changed

Dependencies removed: array, ghc, ghc-paths, split

Dependency ranges changed: base, containers, directory, hashable, haskeline, megaparsec, mtl, optparse-applicative, parsec, parser-combinators, prettyprinter, process, random, regex-tdfa, sweet-egison, text, transformers, unicode-show, unordered-containers, vector

Files

Changelog.md view
@@ -1,6 +1,28 @@ # Changelog  ## Latest+### New Features+* Added binary function notation for arbitrary 2-ary functions. ([#260](https://github.com/egison/egison/pull/260))+```hs+> let mod x y := x % y in 103 `mod` 10+3+```++### Backward-incompatible Changes+* Swapped the notation for `QuoteExpr` and `QuoteSymbolExpr`. ([#262](https://github.com/egison/egison/issues/262))+```hs+> `(a + b) + `(a + b) -- QuoteExpr, which prevents (a + b) from unpacking+2 * '(a + b)+> 'exp x              -- QuoteSymbolExpr+exp x+```+* Changed the specification of `generateTensor` so that the generation function takes indices as a collection. ([#267](https://github.com/egison/egison/pull/267))++## 4.1.2+* Nothing changed (bumped version of `sweet-egison` package)++## 4.1.1+* Fix compilation issue with GHC 8.10 ([#248](https://github.com/egison/egison/issues/248))  ## 4.1.0 ### New Features
Setup.hs view
@@ -1,5 +1,5 @@ #!/usr/bin/env runhaskell -import Distribution.Simple+import           Distribution.Simple  main = defaultMain
egison.cabal view
@@ -1,5 +1,5 @@ Name:                egison-Version:             4.1.2+Version:             4.1.3 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.@@ -84,30 +84,26 @@ Library   default-language:    Haskell2010   Build-Depends:-      base >= 4.7 && < 5-    , array-    , random-    , containers-    , unordered-containers-    , haskeline-    , transformers-    , mtl >=2.2.1-    , parsec >= 3.0-    , megaparsec >= 7.0.0-    , parser-combinators-    , directory-    , ghc-    , ghc-paths-    , text-    , regex-tdfa-    , process-    , vector-    , split-    , hashable-    , optparse-applicative-    , prettyprinter-    , unicode-show-    , sweet-egison >= 0.1.1.3+      base                 >= 4.8     && < 5+    , random               == 1.*+    , containers           == 0.6.*+    , unordered-containers >= 0.1.0.0 && < 0.3+    , haskeline            >= 0.7     && < 0.9+    , transformers         >= 0.4     && < 0.6+    , mtl                  >= 2.2.2   && < 3.0+    , parsec               >= 3.0+    , megaparsec           >= 7.0.0   && < 12.0+    , parser-combinators   >= 1.0     && < 2.0+    , directory            >= 1.3.0+    , text                 >= 0.2     && < 1.3+    , regex-tdfa           >= 1.2.0+    , process              >= 1.0     && < 2.0+    , vector               == 0.12.*+    , hashable             >= 1.0     && < 2.0+    , optparse-applicative >= 0.14    && < 0.20+    , prettyprinter        >= 1.0     && < 2.0+    , unicode-show         == 0.1.*+    , sweet-egison         == 0.1.1.3   if !impl(ghc > 8.0)     Build-Depends: fail   Hs-Source-Dirs:  hs-src@@ -160,7 +156,7 @@   Main-Is:        Test.hs   Build-Depends:       egison-    , base >= 4.0 && < 5+    , base >= 4.8 && < 5     , transformers     , mtl     , Glob@@ -176,10 +172,10 @@   default-language:    Haskell2010   Type:           exitcode-stdio-1.0   Hs-Source-Dirs: test-  Main-Is:        OptionsTest.hs+  Main-Is:        CLITest.hs   Build-Depends:       egison-    , base >= 4.0 && < 5+    , base >= 4.8 && < 5     , process     , HUnit     , test-framework@@ -195,7 +191,7 @@   Main-Is: Benchmark.hs   Build-Depends:       egison-    , base >= 4.0 && < 5+    , base >= 4.8 && < 5     , criterion >= 0.5     , transformers   Other-modules:   Paths_egison@@ -208,22 +204,13 @@   Build-depends:       egison     , base >= 4.0 && < 5-    , array-    , containers     , exceptions-    , unordered-containers     , haskeline-    , transformers     , mtl-    , parsec >= 3.1     , directory-    , ghc-    , ghc-paths     , filepath     , text-    , process     , regex-tdfa-    , vector     , optparse-applicative   if !impl(ghc > 8.0)     Build-Depends: semigroups@@ -237,8 +224,7 @@   Main-is:          translator.hs   Build-depends:       egison-    , base >= 4.0 && < 5+    , base >= 4.8 && < 5     , prettyprinter-    , split   Hs-Source-Dirs:   hs-src/Tool   ghc-options:  -Wall -Wno-name-shadowing
hs-src/Interpreter/egison.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE LambdaCase #-}  module Main where @@ -12,8 +12,7 @@  import           Data.Version -import           System.Console.Haskeline         (InputT, getInputLine, getHistory, putHistory,-                                                   runInputT, Settings (..))+import           System.Console.Haskeline         (InputT, Settings (..), getHistory, getInputLine, putHistory, runInputT) import           System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe) import           System.Directory                 (getHomeDirectory) import           System.Exit                      (exitFailure, exitSuccess)@@ -31,7 +30,7 @@  isInValidMathOption :: EgisonOpts -> Bool isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = lang `notElem` ["asciimath", "latex", "mathematica", "maxima", "haskell"]-isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False+isInValidMathOption EgisonOpts{ optMathExpr = Nothing }   = False  runWithOptions :: EgisonOpts -> IO () runWithOptions opts | isInValidMathOption opts =@@ -46,7 +45,7 @@   coreEnv <- initialEnv   mEnv <- fromEvalT $ evalTopExprs coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts)   case mEnv of-    Left err -> liftIO $ print err+    Left err  -> liftIO $ print err     Right env -> handleOption env opts  handleOption :: Env -> EgisonOpts -> RuntimeM ()@@ -133,7 +132,7 @@     Just topExpr -> do       result <- fromEvalT (evalTopExprStr env topExpr)       case result of-        Left err -> liftIO (print err) >> repl env+        Left err               -> liftIO (print err) >> repl env         Right (Just str, env') -> liftIO (putStrLn str) >> repl env'         Right (Nothing, env')  -> repl env'   )@@ -162,7 +161,7 @@           history <- getHistory           putHistory $ addHistoryUnlessConsecutiveDupe line history           let input = prev ++ line-          parsedExpr <- lift $ parseTopExpr input+          parsedExpr <- lift $ parseTopExpr (replaceNewLine input)           case parsedExpr of             Left err | err =~ "unexpected end of input" ->               getEgisonExpr' (input ++ "\n")@@ -172,3 +171,10 @@             Right topExpr -> do               -- outputStr $ show topExpr               return $ Just topExpr++replaceNewLine :: String -> String+replaceNewLine input =+  let (before, _, after) = input =~ "#newline" :: (String, String, String) in+    case after of+      "" -> before+      _ -> before ++ "\n" ++ replaceNewLine after
hs-src/Language/Egison.hs view
@@ -20,11 +20,11 @@        , version       ) where -import           Control.Monad.Reader        (asks, local)+import           Control.Monad.Reader       (asks, local) import           Control.Monad.State  import           Data.Version-import qualified Paths_egison                as P+import qualified Paths_egison               as P  import           Language.Egison.AST import           Language.Egison.CmdOptions@@ -59,10 +59,10 @@   [ "lib/core/base.egi"              -- Defines (&&) (||)   , "lib/math/common/arithmetic.egi" -- Defines (+) (-) (*) (/) (+') (-') (*') (/')   , "lib/math/algebra/tensor.egi"    -- Defines (.) (.')+  , "lib/core/collection.egi"        -- Defines (++) for patterns   , "lib/math/expression.egi"        -- Defines (+) (*) (/) (^) for patterns    , "lib/core/assoc.egi"-  , "lib/core/collection.egi"   , "lib/core/io.egi"   , "lib/core/maybe.egi"   , "lib/core/number.egi"
hs-src/Language/Egison/AST.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DeriveTraversable #-}  {- | Module      : Language.Egison.AST@@ -33,11 +32,12 @@   , reservedPatternOp   , findOpFrom   , stringToVarWithIndices+  , extractNameFromVarWithIndices   ) where -import           Data.List       (find)-import           Data.Maybe      (fromJust)-import           Data.Text       (Text)+import           Data.List  (find)+import           Data.Maybe (fromJust)+import           Data.Text  (Text)  data TopExpr   = Define VarWithIndices Expr@@ -75,7 +75,7 @@   | VectorExpr [Expr]    | LambdaExpr [Arg ArgPattern] Expr-  | LambdaExpr' [Arg String] Expr+  | LambdaExpr' [Arg VarWithIndices] Expr   | MemoizedLambdaExpr [String] Expr   | CambdaExpr String Expr   | PatternFunctionExpr [String] Pattern@@ -107,6 +107,8 @@   | ApplyExpr Expr [Expr]   | CApplyExpr Expr Expr   | AnonParamFuncExpr Integer Expr+  | AnonTupleParamFuncExpr Integer Expr+  | AnonListParamFuncExpr Integer Expr   | AnonParamExpr Integer    | GenerateTensorExpr Expr Expr@@ -121,7 +123,7 @@   deriving Show  data VarWithIndices = VarWithIndices String [VarIndex]-  deriving Show+  deriving (Show, Eq)  data Arg a   = ScalarArg a@@ -131,21 +133,23 @@  data ArgPattern   = APWildCard-  | APPatVar String+  | APPatVar VarWithIndices   | APInductivePat String [Arg ArgPattern]   | APTuplePat [Arg ArgPattern]   | APEmptyPat-  | APConsPat (Arg ArgPattern) (Arg ArgPattern)-  | APSnocPat (Arg ArgPattern) (Arg ArgPattern)+  | APConsPat (Arg ArgPattern) ArgPattern+  | APSnocPat ArgPattern (Arg ArgPattern)   deriving Show  data VarIndex   = VSubscript String   | VSuperscript String+  | VMultiSubscript String Integer String   -- _(a_1)..._(a_n) -> VMultiSubscript "a" 1 "n"+  | VMultiSuperscript String Integer String -- ~(a_1)...~(a_n) -> VMultiSuperscript "a" 1 "n"   | VGroupScripts [VarIndex]   | VSymmScripts [VarIndex]   | VAntiSymmScripts [VarIndex]-  deriving Show+  deriving (Show, Eq)  data IndexExpr a   = Subscript a@@ -256,8 +260,7 @@  reservedPatternOp :: [Op] reservedPatternOp =-  [ Op "::" 5 InfixR False  -- cons (desugared)-  , Op "++" 5 InfixR False  -- join (desugared)+  [ Op "::" 5 InfixR False  -- required for desugaring collection pattern   , Op "&"  3 InfixR False   , Op "|"  2 InfixR False   ]@@ -265,8 +268,12 @@ findOpFrom :: String -> [Op] -> Op findOpFrom op table = fromJust $ find ((== op) . repr) table +makeApply :: String -> [Expr] -> Expr+makeApply func args = ApplyExpr (VarExpr func) args+ stringToVarWithIndices :: String -> VarWithIndices stringToVarWithIndices name = VarWithIndices name [] -makeApply :: String -> [Expr] -> Expr-makeApply func args = ApplyExpr (VarExpr func) args+extractNameFromVarWithIndices :: VarWithIndices -> String+extractNameFromVarWithIndices (VarWithIndices name _) = name+
hs-src/Language/Egison/CmdOptions.hs view
@@ -15,7 +15,7 @@ import           Data.List           (intercalate) import           Data.Maybe          (maybeToList) import           Options.Applicative-import qualified Text.Parsec as P+import qualified Text.Parsec         as P  data EgisonOpts = EgisonOpts {     optExecFile         :: Maybe (String, [String]),
hs-src/Language/Egison/Completion.hs view
@@ -15,7 +15,7 @@  import           Language.Egison.Data        (Env (..)) import           Language.Egison.IExpr       (Var (..))-import           Language.Egison.Parser.NonS (upperReservedWords, lowerReservedWords)+import           Language.Egison.Parser.NonS (lowerReservedWords, upperReservedWords)  -- |Complete Egison keywords completeEgison :: Monad m => Env -> CompletionFunc m@@ -52,12 +52,12 @@ closeParen str = closeParen' 0 $ 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 (c:str) = c:removeCharAndStringLiteral str+removeCharAndStringLiteral ('\'':str)      = removeCharAndStringLiteral' str+removeCharAndStringLiteral (c:str)         = c:removeCharAndStringLiteral str  removeCharAndStringLiteral' :: String -> String removeCharAndStringLiteral' []              = []
hs-src/Language/Egison/Core.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE LambdaCase      #-}-{-# LANGUAGE TupleSections   #-}-{-# LANGUAGE ViewPatterns    #-}-{-# LANGUAGE MultiWayIf      #-}+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE MultiWayIf    #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns  #-}  {- | Module      : Language.Egison.Core@@ -22,36 +22,35 @@     , patternMatch     ) where -import           Prelude                     hiding (mapM, mappend, mconcat)+import           Prelude                         hiding (mapM, mappend, mconcat)  import           Control.Arrow-import           Control.Monad.Except        (throwError)-import           Control.Monad.State         hiding (mapM, join)+import           Control.Monad.Except            (throwError)+import           Control.Monad.State             hiding (join, mapM) import           Control.Monad.Trans.Maybe -import           Data.Char                   (isUpper)-import           Data.Foldable               (toList)+import           Data.Char                       (isUpper)+import           Data.Foldable                   (toList) import           Data.IORef-import           Data.List                   (partition)+import           Data.List                       (partition) import           Data.Maybe-import qualified Data.Sequence               as Sq-import           Data.Traversable            (mapM)+import qualified Data.Sequence                   as Sq+import           Data.Traversable                (mapM) -import qualified Data.HashMap.Lazy           as HL-import qualified Data.Vector                 as V+import qualified Data.HashMap.Lazy               as HL+import qualified Data.Vector                     as V  import           Language.Egison.Data import           Language.Egison.Data.Collection import           Language.Egison.Data.Utils-import           Language.Egison.EvalState   (MonadEval(..), mLabelFuncName)+import           Language.Egison.EvalState       (MonadEval (..), mLabelFuncName) import           Language.Egison.IExpr+import           Language.Egison.MList import           Language.Egison.Match import           Language.Egison.Math-import           Language.Egison.MList import           Language.Egison.RState import           Language.Egison.Tensor - evalConstant :: ConstantExpr -> EgisonValue evalConstant (CharExpr c)    = Char c evalConstant (StringExpr s)  = toEgison s@@ -68,14 +67,14 @@   whnf <- evalExprShallow env expr   case whnf of     Value (ScalarData s) -> return . Value . ScalarData $ SingleTerm 1 [(Quote s, 1)]-    _ -> throwError =<< TypeMismatch "scalar in quote" whnf <$> getFuncNameStack+    _                    -> throwErrorWithTrace (TypeMismatch "scalar in quote" whnf)  evalExprShallow env (IQuoteSymbolExpr expr) = do   whnf <- evalExprShallow env expr   case whnf of-    Value (Func (Just name) _ _ _) -> return . Value $ symbolScalarData "" name-    Value (ScalarData _) -> return whnf-    _ -> throwError =<< TypeMismatch "value in quote-function" whnf <$> getFuncNameStack+    Value (Func (Just (Var name [])) _ _ _) -> return . Value $ symbolScalarData "" name+    Value (ScalarData _)                    -> return whnf+    _                                       -> throwErrorWithTrace (TypeMismatch "value in quote-function" whnf)  evalExprShallow env (IVarExpr name) =   case refVar env (Var name []) of@@ -107,35 +106,19 @@   innersSeq <- liftIO $ newIORef $ Sq.fromList [ISubCollection xs', ISubCollection ys']   return $ ICollection innersSeq -evalExprShallow env@(Env frame maybe_vwi) (IVectorExpr exprs) = do+evalExprShallow env (IVectorExpr exprs) = do   let n = toInteger (length exprs)-  whnfs <- zipWithM evalWithIndex exprs [1..]+  whnfs <- mapM (evalExprShallow env) exprs   case whnfs of     ITensor Tensor{}:_ ->-      zipWithM f whnfs [1..] >>= tConcat' >>= fromTensor+      mapM f whnfs >>= tConcat' >>= fromTensor     _ -> makeITensorFromWHNF [n] whnfs   where-    evalWithIndex :: IExpr -> Integer -> EvalM WHNFData-    evalWithIndex expr index = evalExprShallow env' expr-      where-        env' = case maybe_vwi of-          Nothing -> env-          Just (name, indices) ->-            Env frame (Just (name, zipWith changeIndex indices [toEgison index]))-    f (ITensor (Tensor ns xs indices)) i = do-      xs <- mapM evalRef xs-      let xs' = V.zipWith g xs $ V.fromList (map (\ms -> map toEgison (i:ms)) $ enumTensorIndices ns)-      xs' <- mapM newEvaluatedObjectRef xs'-      return $ Tensor ns xs' indices-    f x _ = Scalar <$> newEvaluatedObjectRef x-    g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p))) ms =-      Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p))-      where-        fn' = case maybe_vwi of-          Nothing -> fn-          Just (name, indices) ->-            symbolScalarData' (name ++ concatMap show (zipWith changeIndex indices ms))-    g x _ = x+    f (ITensor (Tensor ns xs indices)) = do+      xs' <- mapM evalRef xs+      xs'' <- mapM newEvaluatedObjectRef xs'+      return $ Tensor ns xs'' indices+    f x = Scalar <$> newEvaluatedObjectRef x  evalExprShallow env (ITensorExpr nsExpr xsExpr) = do   nsWhnf <- evalExprShallow env nsExpr@@ -144,7 +127,7 @@   xs <- collectionToRefs xsWhnf >>= fromMList >>= mapM evalRef   if product ns == toInteger (length xs)     then makeITensorFromWHNF ns xs-    else throwError =<< InconsistentTensorShape <$> getFuncNameStack+    else throwErrorWithTrace InconsistentTensorShape  evalExprShallow env (IHashExpr assocs) = do   let (keyExprs, exprs) = unzip assocs@@ -168,22 +151,27 @@       ScalarData _ -> IntKey <$> fromEgison val       Char c       -> return (CharKey c)       String str   -> return (StrKey str)-      _ -> throwError =<< TypeMismatch "integer or string" (Value val) <$> getFuncNameStack-  makeHashKey whnf = throwError =<< TypeMismatch "integer or string" whnf <$> getFuncNameStack+      _            -> throwErrorWithTrace (TypeMismatch "integer or string" (Value val))+  makeHashKey whnf = throwErrorWithTrace (TypeMismatch "integer or string" whnf) -evalExprShallow env (IIndexedExpr override expr indices) = do+evalExprShallow env@(Env fs _) (IIndexedExpr override expr indices) = do   -- Tensor or hash-  tensor <- case expr of-              IVarExpr xs -> do-                let mObjRef = refVar env (Var xs (map (const () <$>) indices))+  whnf <- case expr of+              IVarExpr v -> do+                let mObjRef = refVar env (Var v (map (fmap (const Nothing)) indices))                 case mObjRef of                   Just objRef -> evalRef objRef                   Nothing     -> evalExprShallow env expr               _ -> evalExprShallow env expr-  case tensor of+  case whnf of     Value (ScalarData (SingleTerm 1 [(Symbol id name js', 1)])) -> do       js2 <- mapM evalIndexToScalar indices       return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (js' ++ js2), 1)]))+    Value (Func v@(Just (Var fnName is)) env args body) -> do+      js <- mapM evalIndex indices+      frame <- pmIndices is js+      let env' = extendEnv env frame+      return $ Value (Func v env' args body)     Value (TensorData t@Tensor{}) -> do       js <- mapM evalIndex indices       Value <$> refTensorWithOverride override js t@@ -192,7 +180,7 @@       refTensorWithOverride override js t     _ -> do       js <- mapM evalIndex indices-      refHash tensor (map extractIndex js)+      refHash whnf (map extractIndex js)  where   evalIndex :: Index IExpr -> EvalM (Index EgisonValue)   evalIndex index = traverse (evalExprDeep env) index@@ -204,7 +192,7 @@   js <- map Sub <$> (evalExprDeep env jsExpr >>= collectionToList)   tensor <- case expr of               IVarExpr xs -> do-                let mObjRef = refVar env (Var xs (map (\_ -> Sub ()) js))+                let mObjRef = refVar env (Var xs (map (\_ -> Sub Nothing) js))                 case mObjRef of                   Just objRef -> evalRef objRef                   Nothing     -> evalExprShallow env expr@@ -213,13 +201,13 @@     Value (ScalarData _)          -> return tensor     Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t     ITensor t@Tensor{}            -> refTensorWithOverride override js t-    _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack+    _                             -> throwErrorWithTrace (NotImplemented "subrefs")  evalExprShallow env (ISuprefsExpr override expr jsExpr) = do   js <- map Sup <$> (evalExprDeep env jsExpr >>= collectionToList)   tensor <- case expr of               IVarExpr xs -> do-                let mObjRef = refVar env (Var xs (map (\_ -> Sup ()) js))+                let mObjRef = refVar env (Var xs (map (\_ -> Sup Nothing) js))                 case mObjRef of                   Just objRef -> evalRef objRef                   Nothing     -> evalExprShallow env expr@@ -228,7 +216,7 @@     Value (ScalarData _)          -> return tensor     Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t     ITensor t@Tensor{}            -> refTensorWithOverride override js t-    _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack+    _                             -> throwErrorWithTrace (NotImplemented "suprefs")  evalExprShallow env (IUserrefsExpr _ expr jsExpr) = do   val <- evalExprDeep env expr@@ -236,12 +224,16 @@   case val of     ScalarData (SingleTerm 1 [(Symbol id name is, 1)]) ->       return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (is ++ js), 1)]))-    ScalarData (SingleTerm 1 [(FunctionData name argnames args is, 1)]) ->-      return $ Value (ScalarData (SingleTerm 1 [(FunctionData name argnames args (is ++ js), 1)]))-    _ -> throwError =<< NotImplemented "user-refs" <$> getFuncNameStack+    ScalarData (SingleTerm 1 [(FunctionData sym argnames args, 1)]) ->+      case sym of+        SingleTerm 1 [(Symbol id name is, 1)] -> do+          let sym' = SingleTerm 1 [(Symbol id name (is ++ js), 1)]+          return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym' argnames args, 1)]))+        _ -> throwErrorWithTrace (NotImplemented "user-refs")+    _ -> throwErrorWithTrace (NotImplemented "user-refs") -evalExprShallow env (ILambdaExpr fnname names expr) = do-  return . Value $ Func fnname env names expr+evalExprShallow env (ILambdaExpr vwi names expr) = do+  return . Value $ Func vwi env names expr  evalExprShallow env (IMemoizedLambdaExpr names body) = do   hashRef <- liftIO $ newIORef HL.empty@@ -255,7 +247,15 @@  evalExprShallow env@(Env _ (Just (name, is))) (IFunctionExpr args) = do   args' <- mapM (evalExprDeep env . IVarExpr) args >>= mapM extractScalar-  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (symbolScalarData' (name ++ concatMap show is)) (map symbolScalarData' args) args' [], 1)])+  is' <- mapM unwrapMaybeFromIndex is+  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (SingleTerm 1 [(Symbol "" name is', 1)]) (map symbolScalarData' args) args', 1)])+ where+  unwrapMaybeFromIndex :: Index (Maybe ScalarData) -> EvalM (Index ScalarData) -- Maybe we can refactor this function+--  unwrapMaybeFromIndex = return . (fmap fromJust)+  unwrapMaybeFromIndex (Sub Nothing) = throwError $ Default "function symbol can be used only with generateTensor"+  unwrapMaybeFromIndex (Sup Nothing) = throwError $ Default "function symbol can be used only with generateTensor"+  unwrapMaybeFromIndex (Sub (Just i)) = return (Sub i)+  unwrapMaybeFromIndex (Sup (Just i)) = return (Sup i)  evalExprShallow env (IIfExpr test expr expr') = do   test <- evalExprDeep env test >>= fromEgison@@ -267,7 +267,7 @@  where   extractBindings :: IBindingExpr -> EvalM [Binding]   extractBindings (PDPatVar var, expr) =-    makeBindings [var] . (:[]) <$> newThunkRef (memorizeVarInEnv env var) expr+    newThunkRef (memorizeVarInEnv env var) expr >>= makeBindings [var] . (:[])   extractBindings (pdp, expr) = do     thunk <- newThunkRef env expr     bindPrimitiveDataPattern pdp thunk@@ -314,7 +314,7 @@  evalExprShallow env (IDoExpr bindings expr) = return $ Value $ IOFunc $ do   let body = foldr genLet (IApplyExpr expr [IVarExpr "#1"]) bindings-  applyObj env (Value $ Func Nothing env ["#1"] body) [WHNF (Value World)]+  applyObj env (Value $ Func Nothing env [stringToVar "#1"] body) [WHNF (Value World)]  where   genLet (names, expr) expr' =     ILetExpr [(PDTuplePat (map PDPatVar [stringToVar "#1", stringToVar "#2"]), IApplyExpr expr [IVarExpr "#1"])] $@@ -405,14 +405,17 @@ evalExprShallow env (IGenerateTensorExpr fnExpr shapeExpr) = do   shape <- evalExprDeep env shapeExpr >>= collectionToList   ns    <- mapM fromEgison shape :: EvalM Shape-  xs    <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns)+  xs    <- mapM (evalWithIndex env . map (\n -> SingleTerm n [])) (enumTensorIndices ns)   return $ newITensor ns xs  where-  indexToWHNF :: Env -> [EgisonValue] {- index -} -> EvalM ObjectRef-  indexToWHNF (Env frame maybe_vwi) ms = do+  evalWithIndex :: Env -> [ScalarData] {- index -} -> EvalM ObjectRef+  evalWithIndex env@(Env frame maybe_vwi) ms = do     let env' = maybe env (\(name, indices) -> Env frame $ Just (name, zipWith changeIndex indices ms)) maybe_vwi     fn <- evalExprShallow env' fnExpr-    newApplyObjThunkRef env fn (map (WHNF . Value) ms)+    newApplyObjThunkRef env fn [WHNF (Value (Collection (Sq.fromList (map ScalarData ms))))]+  changeIndex :: Index (Maybe a) -> a -> Index (Maybe a) -- Maybe we can refactor this function+  changeIndex (Sup Nothing) m = Sup (Just m)+  changeIndex (Sub Nothing) m = Sub (Just m)  evalExprShallow env (ITensorContractExpr tExpr) = do   whnf <- evalExprShallow env tExpr@@ -472,7 +475,7 @@         newApplyThunkRef env fn [x, y]) t2 >>= fromTensor     _ -> applyObj env fn [WHNF whnf1, WHNF whnf2] -evalExprShallow _ expr = throwError =<< NotImplemented ("evalExprShallow for " ++ show expr) <$> getFuncNameStack+evalExprShallow _ expr = throwErrorWithTrace (NotImplemented ("evalExprShallow for " ++ show expr))  evalExprDeep :: Env -> IExpr -> EvalM EgisonValue evalExprDeep env expr = evalExprShallow env expr >>= evalWHNF@@ -492,7 +495,7 @@       return val  evalMemoizedFunc-  :: (IORef (HL.HashMap [Integer] WHNFData)) -> Env -> [String] -> IExpr+  :: IORef (HL.HashMap [Integer] WHNFData) -> Env -> [String] -> IExpr   -> [EgisonValue] -> EvalM WHNFData evalMemoizedFunc hashRef env names body args = do   indices <- mapM fromEgison args@@ -500,7 +503,7 @@   case HL.lookup indices hash of     Just whnf -> return whnf     Nothing -> do-      whnf <- applyObj env (Value (Func Nothing env names body)) (map (WHNF . Value) args)+      whnf <- applyObj env (Value (Func Nothing env (map stringToVar names) body)) (map (WHNF . Value) args)       liftIO $ modifyIORef hashRef (HL.insert indices whnf)       return whnf @@ -563,13 +566,16 @@ applyRef env' (Value (Func mFuncName env names body)) refs =   mLabelFuncName mFuncName $     if | length names == length refs -> do-         evalExprShallow (extendEnv env (makeBindings' names refs)) body+         frame <- makeBindings names refs+         evalExprShallow (extendEnv env frame) body        | length names > length refs -> do -- Currying          let (bound, rest) = splitAt (length refs) names-         return . Value $ Func mFuncName (extendEnv env (makeBindings' bound refs)) rest body+         frame <- makeBindings bound refs+         return . Value $ Func mFuncName (extendEnv env frame) rest body        | otherwise -> do          let (used, rest) = splitAt (length names) refs-         func <- evalExprShallow (extendEnv env (makeBindings' names used)) body+         frame <- makeBindings names used+         func <- evalExprShallow (extendEnv env frame) body          applyRef env' func rest applyRef _ (Value (CFunc env name body)) refs = do   seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs)@@ -585,14 +591,14 @@   args <- mapM evalRef refs   case args of     [Value World] -> m-    arg : _ -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack+    arg : _       -> throwErrorWithTrace (TypeMismatch "world" arg) applyRef _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol{}, 1)]))) refs = do   args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs   mExprs <- mapM (\arg -> case arg of                             ScalarData _ -> extractScalar arg-                            _ -> throwError =<< EgisonBug "to use undefined functions, you have to use ScalarData args" <$> getFuncNameStack) args+                            _            -> throwErrorWithTrace (EgisonBug "to use undefined functions, you have to use ScalarData args")) args   return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)])))-applyRef _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack+applyRef _ whnf _ = throwErrorWithTrace (TypeMismatch "function" whnf)  applyObj :: Env -> WHNFData -> [Object] -> EvalM WHNFData applyObj env fn args = do@@ -609,7 +615,7 @@     IIntHash hash         -> irefHash hash     ICharHash hash        -> irefHash hash     IStrHash hash         -> irefHash hash-    _ -> throwError =<< TypeMismatch "hash" val <$> getFuncNameStack+    _                     -> throwErrorWithTrace (TypeMismatch "hash" val)  where   refHash' hash = do     key <- fromEgison index@@ -623,20 +629,6 @@       Just ref -> evalRef ref >>= flip refHash indices       Nothing  -> return $ Value Undefined -updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData-updateHash [index] tgt (IIntHash hash) = do-  targetRef <- newEvaluatedObjectRef tgt-  return . IIntHash $ HL.insert index targetRef hash-updateHash (index:indices) tgt (IIntHash hash) = do-  val <- maybe (return $ IIntHash HL.empty) evalRef $ HL.lookup index hash-  ref <- updateHash indices tgt val >>= newEvaluatedObjectRef-  return . IIntHash $ HL.insert index ref hash-updateHash indices tgt (Value (IntHash hash)) = do-  let keys = HL.keys hash-  vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash-  updateHash indices tgt (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@@ -672,7 +664,7 @@     -- Modify |env'| for some cases     let env'' = case pd of                   PDPatVar var -> memorizeVarInEnv env' var-                  _ -> env'+                  _            -> env'     thunk <- newThunkRef env'' expr     binds <- bindPrimitiveDataPattern pd thunk     forM_ binds $ \(var, objref) -> do@@ -684,7 +676,7 @@  memorizeVarInEnv :: Env -> Var -> Env memorizeVarInEnv (Env frame _) (Var var is) =-  Env frame (Just (var, map (fmap (const "")) is))+  Env frame (Just (var, map (fmap (\_ -> Nothing)) is))  -- -- Pattern Match@@ -704,14 +696,14 @@                         }  processMStatesAllDFS :: MList EvalM MatchingState -> EvalM (MList EvalM Match)-processMStatesAllDFS MNil = return MNil+processMStatesAllDFS MNil                                   = return MNil processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms-processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS+processMStatesAllDFS (MCons mstate ms)                      = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS  processMStatesAllDFSForall :: MList EvalM MatchingState -> EvalM (MList EvalM MatchingState)-processMStatesAllDFSForall MNil = return MNil+processMStatesAllDFSForall MNil                                                           = return MNil processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms-processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall+processMStatesAllDFSForall (MCons mstate ms)                                              = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall  processMStatesAll :: [MList EvalM MatchingState] -> EvalM (MList EvalM Match) processMStatesAll [] = return MNil@@ -720,7 +712,7 @@   mappend (fromList matches) $ processMStatesAll streams'  processMStates :: MList EvalM MatchingState -> EvalM [MList EvalM MatchingState]-processMStates MNil = return []+processMStates MNil                 = return [] processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream  extractMatches :: [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState])@@ -735,7 +727,7 @@  gatherBindings :: MatchingState -> Maybe [Binding] gatherBindings MState{ seqPatCtx = [], mStateBindings = b, mTrees = [] } = return b-gatherBindings _ = Nothing+gatherBindings _                                                         = Nothing  processMState :: MatchingState -> EvalM (MList EvalM MatchingState) processMState state | nullMState state = processMState' state@@ -754,11 +746,11 @@                             processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states       b <- mAny (\case                    MNil -> return True-                   _ -> return False) statess'+                   _    -> return False) statess'       if b         then return MNil --        else return MNil-        else do nstatess <- mmap (\states' -> mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees) states') statess'+        else do nstatess <- mmap (mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees)) statess'                 mconcat nstatess     _ -> processMState' state  where@@ -772,7 +764,7 @@       where (f, state1, state2) = splitMState state'  processMState' :: MatchingState -> EvalM (MList EvalM MatchingState)---processMState' MState{ seqPatCtx = [], mTrees = [] } = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack+--processMState' MState{ seqPatCtx = [], mTrees = [] } = throwErrorWithTrace (EgisonBug "should not reach here (empty matching-state)") processMState' mstate@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS)  -- Sequential patterns and forall pattern@@ -786,7 +778,7 @@   return . msingleton $ mstate  -- Matching Nodes---processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack+--processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwErrorWithTrace (EgisonBug "should not reach here (empty matching-node)") processMState' mstate@MState{ mTrees = MNode _ MState{ seqPatCtx = [], mTrees = [] }:trees } = return . msingleton $ mstate { mTrees = trees }  processMState' ms1@MState{ mTrees = MNode penv ms2@MState{ mTrees = MAtom (IVarPat name) target matcher:trees' }:trees } =@@ -795,7 +787,7 @@       case trees' of         [] -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:trees }         _  -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:MNode penv (ms2 { mTrees = trees' }):trees }-    Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack+    Nothing -> throwErrorWithTrace (UnboundVariable name)  processMState' ms1@(MState _ _ _ bindings (MNode penv ms2@(MState env' loops' _ _ (MAtom (IIndexedPat (IVarPat name) indices) target matcher:trees')):trees)) =   case lookup name penv of@@ -806,7 +798,7 @@       case trees' of         [] -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:trees }         _  -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:MNode penv (ms2 { mTrees = trees' }):trees }-    Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack+    Nothing -> throwErrorWithTrace (UnboundVariable name)  processMState' mstate@MState{ mTrees = MNode penv state:trees } =   processMState' state >>= mmap (\state' -> case state' of@@ -828,7 +820,7 @@             _                   ->               processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees }) -    INotPat _ -> throwError =<< EgisonBug "should not reach here (not-pattern)" <$> getFuncNameStack+    INotPat _ -> throwErrorWithTrace (EgisonBug "should not reach here (not-pattern)")     IVarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern      ILetPat bindings' pattern' -> do@@ -851,7 +843,7 @@         Value (PatternFunc env'' names expr) ->           return . msingleton $ mstate { mTrees = MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees }             where penv = zip names args-        _ -> throwError =<< TypeMismatch "pattern constructor" func' <$> getFuncNameStack+        _ -> throwErrorWithTrace (TypeMismatch "pattern constructor" func')      IDApplyPat func args ->       return . msingleton $ mstate { mTrees = MAtom (IInductivePat "apply" [func, toListPat args]) target matcher:trees }@@ -895,7 +887,7 @@                             mstate { loopPatCtx = LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }]                 | otherwise ->                   fromList [mstate { loopPatCtx = LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }]-    ISeqNilPat -> throwError =<< EgisonBug "should not reach here (seq nil pattern)" <$> getFuncNameStack+    ISeqNilPat -> throwErrorWithTrace (EgisonBug "should not reach here (seq nil pattern)")     ISeqConsPat pattern pattern' -> return . msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher]     ILaterPatVar ->       case seqs of@@ -934,8 +926,8 @@             IIndexedPat _ _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }             ITuplePat patterns -> do               targets <- tupleToListWHNF target-              when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack-              when (length patterns /= length matchers) $ throwError =<< TupleLength (length patterns) (length matchers) <$> getFuncNameStack+              when (length patterns /= length targets) $ throwErrorWithTrace (TupleLength (length patterns) (length targets))+              when (length patterns /= length matchers) $ throwErrorWithTrace (TupleLength (length patterns) (length matchers))               let trees' = zipWith3 MAtom patterns targets matchers ++ trees               return . msingleton $ mstate { mTrees = trees' }             _ ->  throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern@@ -960,16 +952,16 @@                   obj <- evalRef ref >>= updateHash indices target >>= newEvaluatedObjectRef                   return . msingleton $ mstate { mStateBindings = subst name obj bindings, mTrees = trees }                 Nothing  -> do-                  obj <- updateHash indices target (IIntHash (HL.empty)) >>= newEvaluatedObjectRef+                  obj <- updateHash indices target (IIntHash HL.empty) >>= newEvaluatedObjectRef                   return . msingleton $ mstate { mStateBindings = (name,obj):bindings, mTrees = trees }             IIndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern)             ITuplePat patterns -> do               targets <- tupleToListWHNF target-              when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack+              when (length patterns /= length targets) $ throwErrorWithTrace (TupleLength (length patterns) (length targets))               let trees' = zipWith3 MAtom patterns targets (map (const Something) patterns) ++ trees               return . msingleton $ mstate { mTrees = 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) <$> getFuncNameStack+        _ ->  throwErrorWithTrace (EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern))  inductiveMatch :: Env -> IPattern -> WHNFData -> Matcher ->                   EvalM ([IPattern], MList EvalM ObjectRef, [Matcher])@@ -997,7 +989,7 @@         evalExprShallow env expr >>= collectionToRefs       _ -> cont   failPPPatternMatch = throwError (Default "failed primitive pattern pattern match")-  failPDPatternMatch = throwError =<< PrimitiveMatchFailure <$> getFuncNameStack+  failPDPatternMatch = throwErrorWithTrace PrimitiveMatchFailure  primitivePatPatternMatch :: Env -> PrimitivePatPattern -> IPattern ->                             MatchM ([IPattern], [Binding])@@ -1020,7 +1012,7 @@ bindPrimitiveDataPattern pdp ref = do   r <- runMaybeT $ primitiveDataPatternMatch pdp ref   case r of-    Nothing -> throwError =<< PrimitiveMatchFailure <$> getFuncNameStack+    Nothing      -> throwErrorWithTrace PrimitiveMatchFailure     Just binding -> return binding  primitiveDataPatternMatch :: IPrimitiveDataPattern -> ObjectRef -> MatchM [Binding]@@ -1062,7 +1054,7 @@   whnf <- lift $ evalRef ref   case whnf of     Value val | val == evalConstant expr -> return []-    _ -> matchFail+    _                                    -> matchFail  extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext (name, ref) _ _ _ _) -> (stringToVar name, ref)) loops@@ -1075,7 +1067,7 @@   whnfs <- mapM evalRef refs   ms <- mapM evalMatcherWHNF whnfs   return $ Tuple ms-evalMatcherWHNF whnf = throwError =<< TypeMismatch "matcher" whnf <$> getFuncNameStack+evalMatcherWHNF whnf = throwErrorWithTrace (TypeMismatch "matcher" whnf)  -- -- Util@@ -1098,3 +1090,20 @@   tref js' (Tensor ns xs js') >>= tContract' >>= fromTensor     where       js' = if override then js else is ++ js++makeBindings :: [Var] -> [ObjectRef] -> EvalM [Binding]+makeBindings vs refs = zipWithM makeBinding vs refs >>= return . concat+  where+    makeBinding :: Var -> ObjectRef -> EvalM [Binding]+    makeBinding v@(Var _ [])    ref = return [(v, ref)]+    makeBinding v@(Var name is) ref = do+      val <- evalRefDeep ref+      case val of+        TensorData (Tensor _ _ js) -> do+          frame <- pmIndices is js+          return ((v, ref) : frame)+        _ -> throwErrorWithTrace (TypeMismatch "tensor" (Value val))++makeBindings' :: [String] -> [ObjectRef] -> [Binding]+makeBindings' xs = zip (map stringToVar xs)+
hs-src/Language/Egison/Data.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE QuasiQuotes           #-}  {- | Module      : Language.Egison.Data@@ -42,6 +41,7 @@     , refVar     -- * Errors     , EgisonError (..)+    , throwErrorWithTrace     -- * Monads     , EvalM     , fromEvalM@@ -50,20 +50,20 @@  import           Control.Exception -import           Control.Monad.Except      hiding (join)+import           Control.Monad.Except             hiding (join) import           Control.Monad.Trans.State.Strict -import           Data.Foldable             (toList)-import           Data.HashMap.Strict       (HashMap)-import qualified Data.HashMap.Strict       as HashMap+import           Data.Foldable                    (toList)+import           Data.HashMap.Strict              (HashMap)+import qualified Data.HashMap.Strict              as HashMap import           Data.IORef-import           Data.Sequence             (Seq)-import qualified Data.Sequence             as Sq-import qualified Data.Vector               as V+import           Data.Sequence                    (Seq)+import qualified Data.Sequence                    as Sq+import qualified Data.Vector                      as V -import           Data.List                 (intercalate)-import           Data.Text                 (Text)-import           Text.Show.Unicode         (ushow)+import           Data.List                        (intercalate)+import           Data.Text                        (Text)+import           Text.Show.Unicode                (ushow)  import           Data.Ratio import           System.IO@@ -93,7 +93,7 @@   | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)   | UserMatcher Env [IPatternDef]-  | Func (Maybe String) Env [String] IExpr+  | Func (Maybe Var) Env [Var] IExpr   | CFunc Env String IExpr   | MemoizedFunc (IORef (HashMap [Integer] WHNFData)) Env [String] IExpr   | PatternFunc Env [String] IPattern@@ -157,15 +157,13 @@   f js = Collection (Sq.fromList (map scalarIndexToEgison js)) symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [ScalarData fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]-symbolExprToEgison (FunctionData name argnames args js, n) =-  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args)), f js], toEgison n]- where-  f js = Collection (Sq.fromList (map scalarIndexToEgison js))+symbolExprToEgison (FunctionData name argnames args, n) =+  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args))], toEgison n]  scalarIndexToEgison :: Index ScalarData -> EgisonValue-scalarIndexToEgison (Sup k)   = InductiveData "Sup"  [ScalarData k]-scalarIndexToEgison (Sub k)   = InductiveData "Sub"  [ScalarData k]-scalarIndexToEgison (User k)  = InductiveData "User" [ScalarData k]+scalarIndexToEgison (Sup k)  = InductiveData "Sup"  [ScalarData k]+scalarIndexToEgison (Sub k)  = InductiveData "Sub"  [ScalarData k]+scalarIndexToEgison (User k) = InductiveData "User" [ScalarData k]  -- Implementation of 'toMathExpr' (Primitive function) egisonToScalarData :: EgisonValue -> EvalM ScalarData@@ -186,15 +184,15 @@ egisonToScalarData s1@(InductiveData "Function" _) = do   s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])   return $ SingleTerm 1 [s1']-egisonToScalarData val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack+egisonToScalarData val = throwErrorWithTrace (TypeMismatch "math expression" (Value val))  egisonToPolyExpr :: EgisonValue -> EvalM PolyExpr egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts)-egisonToPolyExpr val = throwError =<< TypeMismatch "math poly expression" (Value val) <$> getFuncNameStack+egisonToPolyExpr val                                    = throwErrorWithTrace (TypeMismatch "math poly expression" (Value val))  egisonToTermExpr :: EgisonValue -> EvalM TermExpr egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts)-egisonToTermExpr val = throwError =<< TypeMismatch "math term expression" (Value val) <$> getFuncNameStack+egisonToTermExpr val                                       = throwErrorWithTrace (TypeMismatch "math term expression" (Value val))  egisonToSymbolExpr :: EgisonValue -> EvalM (SymbolExpr, Integer) egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do@@ -213,22 +211,20 @@   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], n]) = do   name' <- extractScalar name   argnames' <- mapM extractScalar (toList argnames)   args' <- mapM extractScalar (toList args)-  let js = toList seq-  js' <- mapM egisonToScalarIndex js   n' <- fromEgison n-  return (FunctionData name' argnames' args' js', n')-egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack+  return (FunctionData name' argnames' args', n')+egisonToSymbolExpr val = throwErrorWithTrace (TypeMismatch "math symbol expression" (Value val))  egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData) egisonToScalarIndex j = case j of   InductiveData "Sup"  [ScalarData k] -> return (Sup k)   InductiveData "Sub"  [ScalarData k] -> return (Sub k)   InductiveData "User" [ScalarData k] -> return (User k)-  _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack+  _                                   -> throwErrorWithTrace (TypeMismatch "math symbol expression" (Value j))  -- -- ExtractScalar@@ -236,7 +232,7 @@  extractScalar :: EgisonValue -> EvalM ScalarData extractScalar (ScalarData mExpr) = return mExpr-extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack+extractScalar val                = throwErrorWithTrace (TypeMismatch "math expression" (Value val))  -- New-syntax version of EgisonValue pretty printer. -- TODO(momohatt): Don't make it a show instance of EgisonValue.@@ -281,25 +277,25 @@ isAtomic :: EgisonValue -> Bool isAtomic (InductiveData _ []) = True isAtomic (InductiveData _ _)  = False-isAtomic (ScalarData m) = isAtom m-isAtomic _ = True+isAtomic (ScalarData m)       = isAtom m+isAtomic _                    = True  instance Eq EgisonValue where-  (Char c) == (Char c') = c == c'-  (String str) == (String str') = str == str'-  (Bool b) == (Bool b') = b == b'-  (ScalarData x) == (ScalarData y) = x == y+  (Char c) == (Char c')                                            = c == c'+  (String str) == (String str')                                    = str == str'+  (Bool b) == (Bool b')                                            = b == b'+  (ScalarData x) == (ScalarData y)                                 = x == y   (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = js == js' && xs == xs'-  (Float x) == (Float x') = x == x'-  (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals'-  (Tuple vals) == (Tuple vals') = vals == vals'-  (Collection vals) == (Collection vals') = vals == vals'-  (IntHash vals) == (IntHash vals') = vals == vals'-  (CharHash vals) == (CharHash vals') = vals == vals'-  (StrHash vals) == (StrHash vals') = vals == vals'+  (Float x) == (Float x')                                          = x == x'+  (InductiveData name vals) == (InductiveData name' vals')         = name == name' && vals == vals'+  (Tuple vals) == (Tuple vals')                                    = vals == vals'+  (Collection vals) == (Collection vals')                          = vals == vals'+  (IntHash vals) == (IntHash vals')                                = vals == vals'+  (CharHash vals) == (CharHash vals')                              = vals == vals'+  (StrHash vals) == (StrHash vals')                                = vals == vals'   -- Temporary: searching a better solution-  (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2-  _ == _ = False+  (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _)           = name1 == name2+  _ == _                                                           = False  -- -- Egison data and Haskell data@@ -311,55 +307,55 @@ instance EgisonData Char where   toEgison = Char   fromEgison (Char c) = return c-  fromEgison val      = throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack+  fromEgison val      = throwErrorWithTrace (TypeMismatch "char" (Value val))  instance EgisonData Text where   toEgison = String   fromEgison (String str) = return str-  fromEgison val          = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack+  fromEgison val          = throwErrorWithTrace (TypeMismatch "string" (Value val))  instance EgisonData Bool where   toEgison = Bool   fromEgison (Bool b) = return b-  fromEgison val      = throwError =<< TypeMismatch "bool" (Value val) <$> getFuncNameStack+  fromEgison val      = throwErrorWithTrace (TypeMismatch "bool" (Value val))  instance EgisonData Integer where   toEgison 0 = ScalarData (Div (Plus []) (Plus [Term 1 []]))   toEgison i = ScalarData (SingleTerm i [])   fromEgison (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0-  fromEgison (ScalarData (SingleTerm x [])) = return x-  fromEgison val = throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack+  fromEgison (ScalarData (SingleTerm x []))                  = return x+  fromEgison val                                             = throwErrorWithTrace (TypeMismatch "integer" (Value val))  instance EgisonData Rational where   toEgison r = ScalarData $ mathNormalize' (Div (Plus [Term (numerator r) []]) (Plus [Term (denominator r) []]))-  fromEgison (ScalarData (Div (Plus []) _)) = return 0+  fromEgison (ScalarData (Div (Plus []) _))                           = return 0   fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return (x % y)-  fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack+  fromEgison val                                                      = throwErrorWithTrace (TypeMismatch "rational" (Value val))  instance EgisonData Double where   toEgison f = Float f   fromEgison (Float f) = return f-  fromEgison val       = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+  fromEgison val       = throwErrorWithTrace (TypeMismatch "float" (Value val))  instance EgisonData Handle where   toEgison = Port   fromEgison (Port h) = return h-  fromEgison val      = throwError =<< TypeMismatch "port" (Value val) <$> getFuncNameStack+  fromEgison val      = throwErrorWithTrace (TypeMismatch "port" (Value val))  instance EgisonData a => EgisonData [a] where   toEgison xs = Collection $ Sq.fromList (map toEgison xs)   fromEgison (Collection seq) = mapM fromEgison (toList seq)-  fromEgison val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack+  fromEgison val              = throwErrorWithTrace (TypeMismatch "collection" (Value val))  instance EgisonData () where   toEgison () = Tuple []   fromEgison (Tuple []) = return ()-  fromEgison val = throwError =<< TypeMismatch "zero element tuple" (Value val) <$> getFuncNameStack+  fromEgison val        = throwErrorWithTrace (TypeMismatch "zero element tuple" (Value val))  instance (EgisonData a, EgisonData b) => EgisonData (a, b) where   toEgison (x, y) = Tuple [toEgison x, toEgison y]   fromEgison (Tuple [x, y]) = liftM2 (,) (fromEgison x) (fromEgison y)-  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack+  fromEgison val            = throwErrorWithTrace (TypeMismatch "two elements tuple" (Value val))  instance (EgisonData a, EgisonData b, EgisonData c) => EgisonData (a, b, c) where   toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z]@@ -368,7 +364,7 @@     y' <- fromEgison y     z' <- fromEgison z     return (x', y', z')-  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack+  fromEgison val = throwErrorWithTrace (TypeMismatch "two elements tuple" (Value val))  instance (EgisonData a, EgisonData b, EgisonData c, EgisonData d) => EgisonData (a, b, c, d) where   toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w]@@ -378,12 +374,12 @@     z' <- fromEgison z     w' <- fromEgison w     return (x', y', z', w')-  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack+  fromEgison val = throwErrorWithTrace (TypeMismatch "two elements tuple" (Value val))  instance EgisonData (IORef EgisonValue) where   toEgison = RefBox   fromEgison (RefBox ref) = return ref-  fromEgison val      = throwError =<< TypeMismatch "ioRef" (Value val) <$> getFuncNameStack+  fromEgison val          = throwErrorWithTrace (TypeMismatch "ioRef" (Value val))  -- -- Internal Data@@ -411,15 +407,15 @@   | ISubCollection ObjectRef  instance Show WHNFData where-  show (Value val) = show val-  show (IInductiveData name _) = "<" ++ name ++ " ...>"-  show (ITuple _) = "(...)"-  show (ICollection _) = "[...]"-  show (IIntHash _) = "{|...|}"-  show (ICharHash _) = "{|...|}"-  show (IStrHash _) = "{|...|}"+  show (Value val)                = show val+  show (IInductiveData name _)    = "<" ++ name ++ " ...>"+  show (ITuple _)                 = "(...)"+  show (ICollection _)            = "[...]"+  show (IIntHash _)               = "{|...|}"+  show (ICharHash _)              = "{|...|}"+  show (IStrHash _)               = "{|...|}"   show (ITensor (Tensor ns xs _)) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]"-  show (ITensor (Scalar _)) = "scalar"+  show (ITensor (Scalar _))       = "scalar"  instance Show Object where   show (Thunk _)   = "#<thunk>"@@ -432,21 +428,21 @@ -- Environment -- -data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index String]))+data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index (Maybe ScalarData)]))  type Binding = (Var, ObjectRef)  instance {-# OVERLAPPING #-} Show (Index EgisonValue) where   show (Sup i) = case i of     ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "~[" ++ show i ++ "]"-    _ -> "~" ++ show i+    _                                                 -> "~" ++ show i   show (Sub i) = case i of     ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"-    _ -> "_" ++ show i+    _                                                 -> "_" ++ show i   show (SupSub i) = "~_" ++ show i   show (User i) = case i of     ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"-    _ -> "|" ++ show i+    _                                                 -> "|" ++ show i   show (DF i j) = "_d" ++ show i ++ show j  nullEnv :: Env@@ -466,7 +462,7 @@ -- Errors -- -type CallStack = [String]+type CallStack = [Var]  data EgisonError   = UnboundVariable String CallStack@@ -505,7 +501,7 @@   show (Default message) = "Error: " ++ message  showTrace :: CallStack -> String-showTrace stack = "\n  stack trace: " ++ intercalate ", " stack+showTrace stack = "\n  stack trace: " ++ intercalate ", " (map show stack)  instance Exception EgisonError @@ -517,8 +513,8 @@  type EvalM = EvalT RuntimeM -instance {-# OVERLAPPING #-} MonadFail EvalM where-  fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack+throwErrorWithTrace :: (CallStack -> EgisonError) -> EvalM a+throwErrorWithTrace e = throwError . e =<< getFuncNameStack  instance MonadRuntime EvalM where   fresh = lift $ lift fresh
hs-src/Language/Egison/Data/Collection.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE TupleSections #-}  {- | Module      : Language.Egison.Data.Collection@@ -18,26 +18,25 @@   , makeICollection   ) where -import           Control.Monad.Except        (throwError, lift, liftIO)-import           Control.Monad.Trans.Maybe   (runMaybeT)+import           Control.Monad.Except       (lift, liftIO)+import           Control.Monad.Trans.Maybe  (runMaybeT) -import           Data.Foldable               (toList)+import           Data.Foldable              (toList) import           Data.IORef-import           Data.Maybe                  (fromJust)-import           Data.Sequence               (Seq, ViewL (..), ViewR (..), (><))-import qualified Data.Sequence               as Sq+import           Data.Maybe                 (fromJust)+import           Data.Sequence              (Seq, ViewL (..), ViewR (..), (><))+import qualified Data.Sequence              as Sq  import           Language.Egison.Data import           Language.Egison.Data.Utils-import           Language.Egison.EvalState   (MonadEval(..))-import           Language.Egison.Match import           Language.Egison.MList+import           Language.Egison.Match  expandCollection :: WHNFData -> EvalM (Seq Inner) expandCollection (Value (Collection vals)) =   mapM (fmap IElement . newEvaluatedObjectRef . Value) vals expandCollection (ICollection innersRef) = liftIO $ readIORef innersRef-expandCollection val = throwError =<< TypeMismatch "collection" val <$> getFuncNameStack+expandCollection val = throwErrorWithTrace (TypeMismatch "collection" val)  isEmptyCollection :: WHNFData -> EvalM Bool isEmptyCollection (Value (Collection col)) = return $ Sq.null col@@ -104,11 +103,11 @@       (head, tail) <- fromJust <$> runMaybeT (unconsCollection whnf)       tail' <- evalRef tail       return $ MCons head (collectionToRefs tail')-collectionToRefs whnf = throwError =<< TypeMismatch "collection" whnf <$> getFuncNameStack+collectionToRefs whnf = throwErrorWithTrace (TypeMismatch "collection" whnf)  collectionToList :: EgisonValue -> EvalM [EgisonValue] collectionToList (Collection sq) = return $ toList sq-collectionToList val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack+collectionToList val             = throwErrorWithTrace (TypeMismatch "collection" (Value val))  makeICollection :: [WHNFData] -> EvalM WHNFData makeICollection xs  = do
hs-src/Language/Egison/Data/Utils.hs view
@@ -10,21 +10,24 @@   , evalObj   , writeObjectRef   , newEvaluatedObjectRef-  , makeBindings-  , makeBindings'   , tupleToRefs   , tupleToListWHNF   , tupleToList   , makeTuple   , makeITuple+  , pmIndices+  , updateHash   ) where +import           Control.Monad import           Control.Monad.State   (liftIO)+import           Control.Monad.Except            (throwError)  import           Data.IORef+import qualified Data.HashMap.Lazy               as HL  import           Language.Egison.Data-import           Language.Egison.IExpr (Var, stringToVar)+import           Language.Egison.IExpr   evalRef :: ObjectRef -> EvalM WHNFData@@ -38,7 +41,7 @@       return val  evalObj :: Object -> EvalM WHNFData-evalObj (WHNF val) = return val+evalObj (WHNF val)    = return val evalObj (Thunk thunk) = thunk  writeObjectRef :: ObjectRef -> WHNFData -> EvalM ()@@ -47,16 +50,10 @@ newEvaluatedObjectRef :: WHNFData -> EvalM ObjectRef newEvaluatedObjectRef = liftIO . newIORef . WHNF -makeBindings :: [Var] -> [ObjectRef] -> [Binding]-makeBindings = zip--makeBindings' :: [String] -> [ObjectRef] -> [Binding]-makeBindings' xs = zip (map stringToVar xs)- tupleToRefs :: WHNFData -> EvalM [ObjectRef]-tupleToRefs (ITuple refs) = return refs+tupleToRefs (ITuple refs)        = return refs tupleToRefs (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals-tupleToRefs whnf = return <$> newEvaluatedObjectRef whnf+tupleToRefs whnf                 = return <$> newEvaluatedObjectRef whnf  tupleToListWHNF :: WHNFData -> EvalM [WHNFData] tupleToListWHNF (ITuple refs)        = mapM evalRef refs@@ -76,3 +73,59 @@ makeITuple []  = return (ITuple []) makeITuple [x] = return x makeITuple xs  = ITuple <$> mapM newEvaluatedObjectRef xs++pmIndices :: [Index (Maybe Var)] -> [Index EgisonValue] -> EvalM [Binding]+pmIndices [] [] = return []+pmIndices (MultiSub (Just a) s (Just e):xs) vs = do+  let (vs1, vs2) = span isSub vs+  let l = fromIntegral (length vs1)+  eRef <- newEvaluatedObjectRef (Value (toEgison l))+  let hash = (IIntHash HL.empty)+  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sub v) -> Value v) vs1)) +  aRef <- newEvaluatedObjectRef hash+  bs <- pmIndices xs vs2+  return ((a, aRef) : (e, eRef) : bs)+ where+  isSub (Sub _) = True+  isSub _       = False+pmIndices (MultiSup (Just a) s (Just e):xs) vs = do+  let (vs1, vs2) = span isSup vs+  let l = fromIntegral (length vs1)+  eRef <- newEvaluatedObjectRef (Value (toEgison l))+  let hash = (IIntHash HL.empty)+  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sup v) -> Value v) vs1)) +  aRef <- newEvaluatedObjectRef hash+  bs <- pmIndices xs vs2+  return ((a, aRef) : (e, eRef) : bs)+ where+  isSup (Sup _) = True+  isSup _       = False++pmIndices (x:xs) (v:vs) = do+  bs <- pmIndex x v+  bs' <- pmIndices xs vs+  return (bs ++ bs')+pmIndices _ _ = throwErrorWithTrace InconsistentTensorIndex++pmIndex :: Index (Maybe Var) -> Index EgisonValue -> EvalM [Binding]+pmIndex (Sub (Just var)) (Sub val) = do+  ref <- newEvaluatedObjectRef (Value val)+  return [(var, ref)]+pmIndex (Sup (Just var)) (Sup val) = do+  ref <- newEvaluatedObjectRef (Value val)+  return [(var, ref)]+pmIndex _ _ = throwErrorWithTrace InconsistentTensorIndex++updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData+updateHash [index] tgt (IIntHash hash) = do+  targetRef <- newEvaluatedObjectRef tgt+  return . IIntHash $ HL.insert index targetRef hash+updateHash (index:indices) tgt (IIntHash hash) = do+  val <- maybe (return $ IIntHash HL.empty) evalRef $ HL.lookup index hash+  ref <- updateHash indices tgt val >>= newEvaluatedObjectRef+  return . IIntHash $ HL.insert index ref hash+updateHash indices tgt (Value (IntHash hash)) = do+  let keys = HL.keys hash+  vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash+  updateHash indices tgt (IIntHash $ HL.fromList $ zip keys vals)+updateHash _ _ v = throwError $ Default $ "expected hash value: " ++ show v
hs-src/Language/Egison/Desugar.hs view
@@ -13,10 +13,10 @@     , desugarExpr     ) where -import           Control.Monad.Except  (throwError)-import           Data.Char             (toUpper)-import           Data.Foldable         (foldrM)-import           Data.List             (union)+import           Control.Monad.Except   (throwError)+import           Data.Char              (toUpper)+import           Data.Foldable          (foldrM)+import           Data.List              (union)  import           Language.Egison.AST import           Language.Egison.Data@@ -25,11 +25,6 @@   desugarTopExpr :: TopExpr -> EvalM (Maybe ITopExpr)-desugarTopExpr (Define (VarWithIndices name []) expr) = do-  expr' <- desugar expr-  case expr' of-    ILambdaExpr Nothing args body -> return . Just $ IDefine (Var name []) (ILambdaExpr (Just name) args body)-    _                             -> return . Just $ IDefine (Var name []) expr' desugarTopExpr (Define vwi expr) = do   (var, iexpr) <- desugarDefineWithIndices vwi expr   return . Just $ IDefine var iexpr@@ -127,39 +122,51 @@  desugar (MatchAllLambdaExpr matcher clauses) = do   name <- fresh-  ILambdaExpr Nothing [name] <$>+  ILambdaExpr Nothing [stringToVar name] <$>     desugar (MatchAllExpr BFSMode (VarExpr name) matcher clauses)  desugar (MatchLambdaExpr matcher clauses) = do   name <- fresh-  ILambdaExpr Nothing [name] <$>+  ILambdaExpr Nothing [stringToVar name] <$>     desugar (MatchExpr BFSMode (VarExpr name) matcher clauses) --- TODO: Allow nested MultiSubscript and MultiSuperscript-desugar (IndexedExpr b expr indices) =-  case indices of-    [MultiSubscript x y] ->-      case (x, y) of-        (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) ->-          desugarMultiScript ISubrefsExpr b1 e1 n1 n2-        _ -> throwError $ Default "Index should be IndexedExpr for multi subscript"-    [MultiSuperscript x y] ->-      case (x, y) of-        (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) ->-          desugarMultiScript ISuprefsExpr b1 e1 n1 n2-        _ -> throwError $ Default "Index should be IndexedExpr for multi superscript"-    _ -> IIndexedExpr b <$> desugar expr <*> mapM desugarIndex indices+desugar (IndexedExpr b expr indices) = do+  expr' <- desugar expr+  desugarIndexedExpr b expr' indices   where-    desugarMultiScript refExpr b1 e1 n1 n2 = do+    desugarIndexedExpr :: Bool -> IExpr -> [IndexExpr Expr] -> EvalM IExpr+    desugarIndexedExpr b expr' indices =+      case indices of+        [] -> return expr'+        (MultiSubscript x y:indices') ->+          case (x, y) of+            (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> do+              expr'' <- desugarMultiScript b expr' ISubrefsExpr b1 e1 n1 n2+              desugarIndexedExpr False expr'' indices'+            _ -> throwError $ Default "Index should be IndexedExpr for multi subscript"+        (MultiSuperscript x y:indices') ->+          case (x, y) of+            (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> do+              expr'' <- desugarMultiScript b expr' ISuprefsExpr b1 e1 n1 n2+              desugarIndexedExpr False expr'' indices'+            _ -> throwError $ Default "Index should be IndexedExpr for multi superscript"+        _ -> do+          let (is, indices') = break isMulti indices+          expr'' <- IIndexedExpr b expr' <$> mapM desugarIndex is+          desugarIndexedExpr False expr'' indices'+    desugarMultiScript b expr' refExpr b1 e1 n1 n2 = do       k     <- fresh       n1'   <- desugar (extractIndexExpr n1)       n2'   <- desugar (extractIndexExpr n2)       e1'   <- desugar e1-      expr' <- desugar expr       return $ refExpr b expr' (makeIApply "map"-                                           [ILambdaExpr Nothing [k] (IIndexedExpr b1 e1' [Sub (IVarExpr k)]),+                                           [ILambdaExpr Nothing [stringToVar k] (IIndexedExpr b1 e1' [Sub (IVarExpr k)]),                                             makeIApply "between" [n1', n2']])+    isMulti (MultiSubscript _ _)   = True+    isMulti (MultiSuperscript _ _) = True+    isMulti _                      = False + desugar (SubrefsExpr bool expr1 expr2) =   ISubrefsExpr bool <$> desugar expr1 <*> desugar expr2 @@ -190,7 +197,7 @@   (args', expr') <- foldrM desugarArg ([], expr) args   desugar $ LambdaExpr' args' expr'   where-    desugarArg :: Arg ArgPattern -> ([Arg String], Expr) -> EvalM ([Arg String], Expr)+    desugarArg :: Arg ArgPattern -> ([Arg VarWithIndices], Expr) -> EvalM ([Arg VarWithIndices], Expr)     desugarArg (TensorArg x) (args, expr) = do       (var, expr') <- desugarArgPat x expr       return (TensorArg var : args, expr')@@ -204,50 +211,58 @@     -- Desugar argument patterns. Examples:     -- \$(%x, %y) -> expr   ==> \$tmp -> let (tmp1, tmp2) := tmp in (\%x %y -> expr) tmp1 tmp2     -- \(x, (y, z)) -> expr ==> \tmp  -> let (tmp1, tmp2) := tmp in (\x (y, z) -> expr) tmp1 tmp2-    desugarArgPat :: ArgPattern -> Expr -> EvalM (String, Expr)+    -- \%($x :: xs) -> expr ==> \%tmp -> let (tmp1 :: xs) := tmp in (\$x %xs -> expr) tmp1 tmp2+    desugarArgPat :: ArgPattern -> Expr -> EvalM (VarWithIndices, Expr)     desugarArgPat APWildCard expr = do       tmp <- fresh-      return (tmp, LetExpr [Bind PDWildCard (VarExpr tmp)] expr)+      let tmp' = stringToVarWithIndices tmp+      return (tmp', LetExpr [Bind PDWildCard (VarExpr tmp)] expr)     desugarArgPat (APPatVar var) expr = return (var, expr)     desugarArgPat (APTuplePat args) expr = do       tmp  <- fresh+      let tmp' = stringToVarWithIndices tmp       tmps <- mapM (const fresh) args-      return (tmp, LetExpr [Bind (PDTuplePat (map PDPatVar tmps)) (VarExpr tmp)]-                     (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps)))+      return (tmp', LetExpr [Bind (PDTuplePat (map PDPatVar tmps)) (VarExpr tmp)]+                      (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps)))     desugarArgPat (APInductivePat ctor args) expr = do       tmp  <- fresh+      let tmp' = stringToVarWithIndices tmp       tmps <- mapM (const fresh) args-      return (tmp, LetExpr [Bind (PDInductivePat ctor (map PDPatVar tmps)) (VarExpr tmp)]-                     (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps)))+      return (tmp', LetExpr [Bind (PDInductivePat ctor (map PDPatVar tmps)) (VarExpr tmp)]+                      (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps)))     desugarArgPat APEmptyPat expr = do       tmp <- fresh-      return (tmp, LetExpr [Bind PDEmptyPat (VarExpr tmp)] expr)+      let tmp' = stringToVarWithIndices tmp+      return (tmp', LetExpr [Bind PDEmptyPat (VarExpr tmp)] expr)     desugarArgPat (APConsPat arg1 arg2) expr = do       tmp  <- fresh+      let tmp' = stringToVarWithIndices tmp       tmp1 <- fresh       tmp2 <- fresh-      return (tmp, LetExpr [Bind (PDConsPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)]-                     (ApplyExpr (LambdaExpr [arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2]))+      return (tmp', LetExpr [Bind (PDConsPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)]+                     (ApplyExpr (LambdaExpr [arg1, TensorArg arg2] expr) [VarExpr tmp1, VarExpr tmp2]))     desugarArgPat (APSnocPat arg1 arg2) expr = do       tmp  <- fresh+      let tmp' = stringToVarWithIndices tmp       tmp1 <- fresh       tmp2 <- fresh-      return (tmp, LetExpr [Bind (PDSnocPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)]-                     (ApplyExpr (LambdaExpr [arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2]))+      return (tmp', LetExpr [Bind (PDSnocPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)]+                     (ApplyExpr (LambdaExpr [TensorArg arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2])) -desugar (LambdaExpr' names expr) = do-  let (args', expr') = foldr desugarInvertedArgs ([], expr) names+desugar (LambdaExpr' vwis expr) = do+  let (vwis', expr') = foldr desugarInvertedArgs ([], expr) vwis+  let args' = map varWithIndicesToVar vwis'   expr' <- desugar expr'   return $ ILambdaExpr Nothing args' expr'   where-    desugarInvertedArgs :: Arg String -> ([String], Expr) -> ([String], Expr)+    desugarInvertedArgs :: Arg VarWithIndices -> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr)     desugarInvertedArgs (TensorArg x) (args, expr) = (x : args, expr)     desugarInvertedArgs (ScalarArg x) (args, expr) =       (x : args,-       TensorMapExpr (LambdaExpr' [TensorArg x] expr) (VarExpr x))+       TensorMapExpr (LambdaExpr' [TensorArg x] expr) (VarExpr (extractNameFromVarWithIndices x)))     desugarInvertedArgs (InvertedScalarArg x) (args, expr) =       (x : args,-       TensorMapExpr (LambdaExpr' [TensorArg x] expr) (FlipIndicesExpr (VarExpr x)))+       TensorMapExpr (LambdaExpr' [TensorArg x] expr) (FlipIndicesExpr (VarExpr (extractNameFromVarWithIndices x))))  desugar (MemoizedLambdaExpr names expr) =   IMemoizedLambdaExpr names <$> desugar expr@@ -308,15 +323,15 @@ desugar (SectionExpr op Nothing Nothing) = do   x <- fresh   y <- fresh-  ILambdaExpr Nothing [x, y] <$> desugar (InfixExpr op (VarExpr x) (VarExpr y))+  ILambdaExpr Nothing [stringToVar x, stringToVar y] <$> desugar (InfixExpr op (VarExpr x) (VarExpr y))  desugar (SectionExpr op Nothing (Just expr2)) = do   x <- fresh-  ILambdaExpr Nothing [x] <$> desugar (InfixExpr op (VarExpr x) expr2)+  ILambdaExpr Nothing [stringToVar x] <$> desugar (InfixExpr op (VarExpr x) expr2)  desugar (SectionExpr op (Just expr1) Nothing) = do   y <- fresh-  ILambdaExpr Nothing [y] <$> desugar (InfixExpr op expr1 (VarExpr y))+  ILambdaExpr Nothing [stringToVar y] <$> desugar (InfixExpr op expr1 (VarExpr y))  desugar SectionExpr{} = throwError $ Default "Cannot reach here: section with both arguments" @@ -362,10 +377,25 @@ desugar (AnonParamExpr n) = return $ IVarExpr ('%' : show n)  desugar (AnonParamFuncExpr n expr) = do-  expr' <- desugar expr-  let lambda = ILambdaExpr Nothing (map (\n -> '%' : show n) [1..n]) expr'+  let args = map (\n -> stringToVarWithIndices ('%' : show n)) [1..n]+  lambda <- desugar $ LambdaExpr' (map TensorArg args) expr   return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") +desugar (AnonTupleParamFuncExpr 1 expr) = do+  lambda <- desugar $ LambdaExpr' [TensorArg (stringToVarWithIndices "%1")] expr+  return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0")+desugar (AnonTupleParamFuncExpr n expr) = do+  let args = map (\n -> stringToVarWithIndices ('%' : show n)) [1..n]+  lambda <- desugar $+    LambdaExpr [TensorArg (APTuplePat $ map (TensorArg . APPatVar) args)] expr+  return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0")++desugar (AnonListParamFuncExpr n expr) = do+  let args' = map (\n -> TensorArg (APPatVar (stringToVarWithIndices ('%' : show n)))) [1..n]+  let args = foldr APConsPat APEmptyPat args'+  lambda <- desugar $ LambdaExpr [TensorArg args] expr+  return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0")+ desugar (QuoteExpr expr) =   IQuoteExpr <$> desugar expr @@ -394,20 +424,20 @@    collectNames pats = foldl union [] (map collectName pats)     collectName :: Pattern -> [String]-   collectName (ForallPat pat1 pat2) = collectName pat1 `union` collectName pat2-   collectName (InfixPat _ pat1 pat2) = collectName pat1 `union` collectName pat2-   collectName (NotPat pat)  = collectName pat-   collectName (AndPat pat1 pat2) = collectName pat1 `union` collectName pat2-   collectName (OrPat pat1 pat2)  = collectName pat1 `union` collectName pat2-   collectName (TuplePat pats) = collectNames pats-   collectName (InductiveOrPApplyPat _ pats) = collectNames pats-   collectName (InductivePat _ pats) = collectNames pats-   collectName (PApplyPat _ pats) = collectNames pats-   collectName (DApplyPat _ pats) = collectNames pats+   collectName (ForallPat pat1 pat2)                           = collectName pat1 `union` collectName pat2+   collectName (InfixPat _ pat1 pat2)                          = collectName pat1 `union` collectName pat2+   collectName (NotPat pat)                                    = collectName pat+   collectName (AndPat pat1 pat2)                              = collectName pat1 `union` collectName pat2+   collectName (OrPat pat1 pat2)                               = collectName pat1 `union` collectName pat2+   collectName (TuplePat pats)                                 = collectNames pats+   collectName (InductiveOrPApplyPat _ pats)                   = collectNames pats+   collectName (InductivePat _ pats)                           = collectNames pats+   collectName (PApplyPat _ pats)                              = collectNames pats+   collectName (DApplyPat _ pats)                              = collectNames pats    collectName (LoopPat _ (LoopRange _ _ endNumPat) pat1 pat2) = collectName endNumPat `union` collectName pat1 `union` collectName pat2-   collectName (LetPat _ pat) = collectName pat-   collectName (IndexedPat (PatVar var) _) = [var]-   collectName _ = []+   collectName (LetPat _ pat)                                  = collectName pat+   collectName (IndexedPat (PatVar var) _)                     = [var]+   collectName _                                               = []     makeBinding :: String -> IBindingExpr    makeBinding var = (PDPatVar (stringToVar var), IHashExpr [])@@ -453,7 +483,7 @@       expr' <- desugar expr       case (name, expr') of         (PDPatVar var, ILambdaExpr Nothing args body) ->-          return (name', ILambdaExpr (Just var) args body)+          return (name', ILambdaExpr (Just (Var var [])) args body)         _ -> return (name', expr')     desugarBinding (BindWithIndices vwi expr) = do       (var, iexpr) <- desugarDefineWithIndices vwi expr@@ -470,6 +500,12 @@ desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (fmap stringToVar pd,) <$> desugar expr)  desugarDefineWithIndices :: VarWithIndices -> Expr -> EvalM (Var, IExpr)+desugarDefineWithIndices var@(VarWithIndices _ _) expr@(LambdaExpr _ _) = do+  let var' = varWithIndicesToVar var+  expr' <- desugar expr+  case expr' of+    ILambdaExpr Nothing args body -> return (var', ILambdaExpr (Just var') args body)+    _                             -> return (var', expr') desugarDefineWithIndices (VarWithIndices name is) expr = do   let (isSubs, indexNames) = unzip $ concatMap extractSubSupIndex is   expr <- if any isExtendedIndice is@@ -477,12 +513,24 @@              else return expr   body <- desugar expr   let indexNamesCollection = ICollectionExpr (map IVarExpr indexNames)-  let is' = map (\b -> if b then Sub () else Sup ()) isSubs+  let is' = map (\b -> if b then Sub Nothing else Sup Nothing) isSubs   return (Var name is', IWithSymbolsExpr indexNames (ITransposeExpr indexNamesCollection body)) +varWithIndicesToVar :: VarWithIndices -> Var+varWithIndicesToVar (VarWithIndices name is) = Var name (concatMap transVarIndex is)++transVarIndex :: VarIndex -> [Index (Maybe Var)]+transVarIndex (VSubscript x)            = [Sub (Just (stringToVar x))]+transVarIndex (VSuperscript x)          = [Sup (Just (stringToVar x))]+transVarIndex (VMultiSubscript x s e)   = [MultiSub (Just (stringToVar x)) s (Just (stringToVar e))]+transVarIndex (VMultiSuperscript x s e) = [MultiSup (Just (stringToVar x)) s (Just (stringToVar e))]+transVarIndex (VGroupScripts xs)        = concatMap transVarIndex xs+transVarIndex (VSymmScripts xs)         = concatMap transVarIndex xs+transVarIndex (VAntiSymmScripts xs)     = concatMap transVarIndex xs+ extractSubSupIndex :: VarIndex -> [(Bool, String)]-extractSubSupIndex (VSubscript x)   = [(True, x)]-extractSubSupIndex (VSuperscript x) = [(False, x)]+extractSubSupIndex (VSubscript x)        = [(True, x)]+extractSubSupIndex (VSuperscript x)      = [(False, x)] extractSubSupIndex (VGroupScripts xs)    = concatMap extractSubSupIndex xs extractSubSupIndex (VSymmScripts xs)     = concatMap extractSubSupIndex xs extractSubSupIndex (VAntiSymmScripts xs) = concatMap extractSubSupIndex xs@@ -491,7 +539,7 @@ desugarExtendedIndices indices isSubs indexNames tensorBody = do   tensorName <- fresh   tensorGenExpr <- f indices (VarExpr tensorName) [] []-  let indexFunctionExpr = LambdaExpr' (map TensorArg indexNames) tensorGenExpr+  let indexFunctionExpr = LambdaExpr [TensorArg $ foldr APConsPat APEmptyPat (map (TensorArg . APPatVar) (map stringToVarWithIndices indexNames))] tensorGenExpr   let genTensorExpr = GenerateTensorExpr indexFunctionExpr (makeApply "tensorShape" [VarExpr tensorName])   let tensorIndices = zipWith (\isSub name -> if isSub then Subscript (VarExpr name) else Superscript (VarExpr name)) isSubs indexNames   return $ LetExpr [Bind (PDPatVar tensorName) tensorBody] (IndexedExpr True genTensorExpr tensorIndices)@@ -507,7 +555,7 @@     symbols <- mapM (const fresh) isSubs     let is = zipWith (\x isSub -> (if isSub then Subscript else Superscript) (VarExpr x)) symbols isSubs     f indices (IndexedExpr True expr is)-      (signs ++ signs') (bindings ++ bindings' ++ [Bind (foldr PDConsPat PDEmptyPat (map PDPatVar symbols)) indices'])+      (signs ++ signs') (bindings ++ bindings' ++ [Bind (foldr (PDConsPat . PDPatVar) PDEmptyPat symbols) indices'])    subOrSupScripts :: VarIndex -> [Bool]   subOrSupScripts VSubscript{}          = [True]
hs-src/Language/Egison/Eval.hs view
@@ -15,14 +15,15 @@   , evalTopExprsNoPrint   , runExpr   , runTopExpr+  , runTopExprStr   , runTopExprs   -- * Load Egison files   , loadEgisonLibrary   , loadEgisonFile   ) where -import           Control.Monad.Except        (throwError)-import           Control.Monad.Reader        (ask, asks)+import           Control.Monad.Except       (throwError)+import           Control.Monad.Reader       (ask, asks) import           Control.Monad.State  import           Language.Egison.AST@@ -30,9 +31,9 @@ import           Language.Egison.Core import           Language.Egison.Data import           Language.Egison.Desugar-import           Language.Egison.EvalState   (MonadEval(..))+import           Language.Egison.EvalState  (MonadEval (..)) import           Language.Egison.IExpr-import           Language.Egison.MathOutput  (prettyMath)+import           Language.Egison.MathOutput (prettyMath) import           Language.Egison.Parser  @@ -45,7 +46,7 @@ evalTopExpr env topExpr = do   topExpr <- desugarTopExpr topExpr   case topExpr of-    Nothing -> return (Nothing, env)+    Nothing      -> return (Nothing, env)     Just topExpr -> evalTopExpr' env topExpr  -- | Evaluate an Egison top expression.@@ -98,6 +99,11 @@ runTopExpr env input =   readTopExpr input >>= evalTopExpr env +-- | Evaluate an Egison top expression. Input is a Haskell string.+runTopExprStr :: Env -> String -> EvalM (Maybe String, Env)+runTopExprStr env input =+  readTopExpr input >>= evalTopExprStr env+ -- | Evaluate Egison top expressions. Input is a Haskell string. runTopExprs :: Env -> String -> EvalM Env runTopExprs env input =@@ -144,16 +150,16 @@   env' <- recursiveBind env [(name, expr)]   return (Nothing, env') evalTopExpr' env (ITest expr) = do-  pushFuncName "<stdin>"+  pushFuncName (stringToVar "<stdin>")   val <- evalExprDeep env expr   popFuncName   return (Just val, env) evalTopExpr' env (IExecute expr) = do-  pushFuncName "<stdin>"+  pushFuncName (stringToVar "<stdin>")   io <- evalExprShallow env expr   case io of     Value (IOFunc m) -> m >> popFuncName >> return (Nothing, env)-    _                -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack+    _                -> throwErrorWithTrace (TypeMismatch "io" io) evalTopExpr' env (ILoad file) = do   opts <- ask   when (optNoIO opts) $ throwError (Default "No IO support")
hs-src/Language/Egison/EvalState.hs view
@@ -17,20 +17,22 @@ import           Control.Monad.Except import           Control.Monad.Trans.State.Strict +import           Language.Egison.IExpr + newtype EvalState = EvalState   -- Names of called functions for improved error message-  { funcNameStack :: [String]+  { funcNameStack :: [Var]   }  initialEvalState :: EvalState initialEvalState = EvalState { funcNameStack = [] }  class (Applicative m, Monad m) => MonadEval m where-  pushFuncName :: String -> m ()-  topFuncName :: m String+  pushFuncName :: Var -> m ()+  topFuncName :: m Var   popFuncName :: m ()-  getFuncNameStack :: m [String]+  getFuncNameStack :: m [Var]  instance Monad m => MonadEval (StateT EvalState m) where   pushFuncName name = do@@ -50,7 +52,7 @@   popFuncName = lift popFuncName   getFuncNameStack = lift getFuncNameStack -mLabelFuncName :: MonadEval m => Maybe String -> m a -> m a+mLabelFuncName :: MonadEval m => Maybe Var -> m a -> m a mLabelFuncName Nothing m = m mLabelFuncName (Just name) m = do   pushFuncName name
hs-src/Language/Egison/IExpr.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE DeriveTraversable  #-}-{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}  {- | Module      : Language.Egison.IExpr@@ -21,6 +20,7 @@   , IPrimitiveDataPattern   , Var (..)   , stringToVar+  , extractNameFromVar   , Index (..)   , extractSupOrSubIndex   , extractIndex@@ -32,14 +32,10 @@   , PDPatternBase (..)   ) where -import           Data.Hashable       (Hashable)+import           Data.Hashable import           GHC.Generics        (Generic) -import           Language.Egison.AST ( ConstantExpr (..)-                                     , PMMode (..)-                                     , PrimitivePatPattern (..)-                                     , PDPatternBase (..)-                                     )+import           Language.Egison.AST (ConstantExpr (..), PDPatternBase (..), PMMode (..), PrimitivePatPattern (..))  data ITopExpr   = IDefine Var IExpr@@ -63,7 +59,7 @@   | IJoinExpr IExpr IExpr   | IHashExpr [(IExpr, IExpr)]   | IVectorExpr [IExpr]-  | ILambdaExpr (Maybe String) [String] IExpr+  | ILambdaExpr (Maybe Var) [Var] IExpr   | IMemoizedLambdaExpr [String] IExpr   | ICambdaExpr String IExpr   | IPatternFunctionExpr [String] IPattern@@ -127,6 +123,8 @@ data Index a   = Sub a   | Sup a+  | MultiSub a Integer a+  | MultiSup a Integer a   | SupSub a   | User a   | DF Integer Integer@@ -145,14 +143,32 @@ extractIndex (User x)   = x extractIndex DF{}       = undefined -data Var = Var String [Index ()]+data Var = Var String [Index (Maybe Var)]+  deriving (Generic, Show)++-- for eq and hashable+data Var' = Var' String [Index ()]   deriving (Eq, Generic, Show) -instance Hashable (Index ())-instance Hashable Var+instance Eq Var where+  Var name (MultiSup _ _ _:_) == Var name' is' = Var name [] == Var name' is'+  Var name (MultiSub _ _ _:_) == Var name' is' = Var name [] == Var name' is'+  Var name is == Var name' (MultiSup _ _ _:_)  = Var name is == Var name' []+  Var name is == Var name' (MultiSub _ _ _:_)  = Var name is == Var name' []+  Var name is == Var name' is'                 = Var' name (map (fmap (\_ -> ())) is) == Var' name' (map (fmap (\_ -> ())) is') +instance Hashable a => Hashable (Index a)+instance Hashable Var'+instance Hashable Var where+  hashWithSalt salt (Var name (MultiSup _ _ _:_)) = hashWithSalt salt (Var' name [])+  hashWithSalt salt (Var name (MultiSub _ _ _:_)) = hashWithSalt salt (Var' name [])+  hashWithSalt salt (Var name is) = hashWithSalt salt (Var' name (map (fmap (\_ -> ())) is))+ stringToVar :: String -> Var stringToVar name = Var name []++extractNameFromVar :: Var -> String+extractNameFromVar (Var name _) = name  makeIApply :: String -> [IExpr] -> IExpr makeIApply func args = IApplyExpr (IVarExpr func) args
hs-src/Language/Egison/MList.hs view
@@ -19,8 +19,8 @@   , mAny   ) where -import           Prelude       hiding (mappend, mconcat,) import           Data.Sequence (Seq)+import           Prelude       hiding (mappend, mconcat)  data MList m a = MNil | MCons a (m (MList m a))
hs-src/Language/Egison/Match.hs view
@@ -37,7 +37,7 @@            }  instance Show MatchingState where-  show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")" +  show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")"  data MatchingTree   = MAtom IPattern WHNFData Matcher@@ -53,9 +53,9 @@   | ForallPatContext [Matcher] [WHNFData]  nullMState :: MatchingState -> Bool-nullMState MState{ mTrees = [] } = True+nullMState MState{ mTrees = [] }                = True nullMState MState{ mTrees = MNode _ state : _ } = nullMState state-nullMState _ = False+nullMState _                                    = False  -- -- Monads
hs-src/Language/Egison/Math.hs view
@@ -27,7 +27,7 @@   , mathNegate   ) where -import           Language.Egison.Math.Expr import           Language.Egison.Math.Arith+import           Language.Egison.Math.Expr import           Language.Egison.Math.Normalize import           Language.Egison.Math.Rewrite
hs-src/Language/Egison/Math/Arith.hs view
@@ -32,8 +32,8 @@ mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2)  mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr-mathMultPoly (Plus []) (Plus _) = Plus []-mathMultPoly (Plus _) (Plus []) = Plus []+mathMultPoly (Plus []) (Plus _)    = Plus []+mathMultPoly (Plus _) (Plus [])    = Plus [] mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1)  mathDiv :: ScalarData -> ScalarData -> ScalarData
hs-src/Language/Egison/Math/Expr.hs view
@@ -45,13 +45,13 @@     , mathNegate     ) where -import           Prelude                   hiding (foldr, mappend, mconcat)-import           Data.List                 (intercalate)+import           Data.List             (intercalate)+import           Prelude               hiding (foldr, mappend, mconcat) -import           Control.Monad             ( MonadPlus(..) ) import           Control.Egison+import           Control.Monad         (MonadPlus (..)) -import           Language.Egison.IExpr     (Index(..))+import           Language.Egison.IExpr (Index (..))  -- -- Data@@ -76,7 +76,7 @@   = Symbol Id String [Index ScalarData]   | Apply ScalarData [ScalarData]   | Quote ScalarData-  | FunctionData ScalarData [ScalarData] [ScalarData] [Index ScalarData] -- fnname argnames args indices+  | FunctionData ScalarData [ScalarData] [ScalarData] -- fnname argnames args   deriving Eq  type Id = String@@ -103,12 +103,12 @@ symbolM :: SymbolM -> p -> Eql symbolM SymbolM _ = Eql -func :: Pattern (PP ScalarData, PP [ScalarData], PP [Index ScalarData])-                SymbolM SymbolExpr (ScalarData, [ScalarData], [Index ScalarData])-func _ _ (FunctionData name _ args js) = pure (name, args, js)+func :: Pattern (PP ScalarData, PP [ScalarData])+                SymbolM SymbolExpr (ScalarData, [ScalarData])+func _ _ (FunctionData name _ args) = pure (name, args) func _ _ _                             = mzero-funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM, Multiset Eql)-funcM SymbolM _ = (ScalarM, List ScalarM, Multiset Eql)+funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM)+funcM SymbolM _ = (ScalarM, List ScalarM)  apply :: Pattern (PP String, PP [ScalarData]) SymbolM SymbolExpr (String, [ScalarData]) apply _ _ (Apply (SingleSymbol (Symbol _ fn _)) args) = pure (fn, args)@@ -238,24 +238,25 @@ instance Printable SymbolExpr where   isAtom Symbol{}     = True   isAtom (Apply _ []) = True+  isAtom Quote{}      = True   isAtom _            = False    pretty (Symbol _ (':':':':':':_) []) = "#"-  pretty (Symbol _ s []) = s-  pretty (Symbol _ s js) = s ++ concatMap show js-  pretty (Apply fn mExprs) = unwords (map pretty' (fn : mExprs))-  pretty (Quote mExprs) = "'" ++ pretty' mExprs-  pretty (FunctionData name _ _ js) = pretty name ++ concatMap show js+  pretty (Symbol _ s [])               = s+  pretty (Symbol _ s js)               = s ++ concatMap show js+  pretty (Apply fn mExprs)             = unwords (map pretty' (fn : mExprs))+  pretty (Quote mExprs)                = "`" ++ pretty' mExprs+  pretty (FunctionData name _ _)    = pretty name  instance Printable TermExpr where   isAtom (Term _ [])  = True   isAtom (Term 1 [_]) = True   isAtom _            = False -  pretty (Term a []) = show a-  pretty (Term 1 xs) = intercalate " * " (map prettyPoweredSymbol xs)+  pretty (Term a [])    = show a+  pretty (Term 1 xs)    = intercalate " * " (map prettyPoweredSymbol xs)   pretty (Term (-1) xs) = "- " ++ intercalate " * " (map prettyPoweredSymbol xs)-  pretty (Term a xs) = intercalate " * " (show a : map prettyPoweredSymbol xs)+  pretty (Term a xs)    = intercalate " * " (show a : map prettyPoweredSymbol xs)  prettyPoweredSymbol :: (SymbolExpr, Integer) -> String prettyPoweredSymbol (x, 1) = show x
hs-src/Language/Egison/Math/Normalize.hs view
@@ -122,7 +122,7 @@   f [] = []   f (t:ts) =     match dfs (t, ts) (Pair TermM (Multiset TermM))-      [ [mc| (term $a $xs, term $b ($ys & equalMonomial $sgn #xs) : $tss) ->-               f (Term (sgn * a + b) ys : tss) |]+      [ [mc| (term $a $xs, term $b (equalMonomial $sgn #xs) : $tss) ->+               f (Term (sgn * a + b) xs : tss) |]       , [mc| _ -> t : f ts |]       ]
hs-src/Language/Egison/Math/Rewrite.hs view
@@ -164,13 +164,9 @@              let d@(Term c z) = termsGcd [Term n x, Term m y]                  Term n' x' = mathDivideTerm (Term n x) d                  Term m' y' = mathDivideTerm (Term m y) d-                 sqrtxy = (if x' == [] then [] else [(makeApply "sqrt" [SingleTerm 1 x'], 1)]) ++ -                            (if y' == [] then [] else [(makeApply "sqrt" [SingleTerm 1 y'], 1)])-              in mathMult-                   (SingleTerm c z)-                   (SingleTerm-                     a-                     ((makeApply "sqrt" [SingleTerm (n' * m') []], 1) : sqrtxy ++ xss)) |]+                 in case (n' * m', Term n' x', Term m' y') of+                      (1, Term _ [], Term _ []) -> mathMult (SingleTerm c z) (SingleTerm a xss)+                      (_, _, _) -> mathMult (SingleTerm c z) (SingleTerm a ((makeApply "sqrt" [SingleTerm (n' * m') (x' ++ y')], 1) : xss)) |]       , [mc| _ -> SingleTerm a xs |]       ] @@ -186,7 +182,7 @@       ]  rewriteRtu :: ScalarData -> ScalarData-rewriteRtu = mapTerms f+rewriteRtu = mapTerms' g . mapTerms f  where   f term@(Term a xs) =     match dfs xs (Multiset (Pair SymbolM Eql))@@ -194,6 +190,14 @@                Term a ((rtun, k `mod` n) : r) |]       , [mc| _ -> term |]       ]+  g (Term a xs) =+    match dfs xs (Multiset (Pair SymbolM Eql))+      [ [mc| (apply #"rtu" [singleTerm $n #1 []] & $rtun, ?(== n - 1)) : $mr ->+               mathMult+                 (foldl mathMinus (SingleTerm (-1) []) (map (\k -> SingleTerm 1 [(rtun, k)]) [1..(n-2)]))+                 (g (Term a mr)) |]+      , [mc| _ -> SingleTerm a xs |]+      ]  rewriteDd :: ScalarData -> ScalarData rewriteDd (Div (Plus p1) (Plus p2)) =@@ -201,8 +205,8 @@  where   rewriteDdPoly poly =     match dfs poly (Multiset TermM)-      [ [mc| term $a (($f & func $g $arg $js, $n) : $mr) :-               term $b ((func #g #arg #js, #n) : #mr) : $pr ->+      [ [mc| term $a (($f & func $g $arg, $n) : $mr) :+               term $b ((func #g #arg, #n) : #mr) : $pr ->                  rewriteDdPoly (Term (a + b) ((f, n) : mr) : pr) |]       , [mc| _ -> poly |]       ]
hs-src/Language/Egison/Parser.hs view
@@ -20,21 +20,21 @@        , removeShebang        , readUTF8File        ) where- -import           Control.Monad.Except           (lift, liftIO, throwError)-import           Control.Monad.State            (unless)-import           Control.Monad.Reader           (asks, local) -import           System.Directory               (doesFileExist, getHomeDirectory)+import           Control.Monad.Except         (lift, liftIO, throwError)+import           Control.Monad.Reader         (asks, local)+import           Control.Monad.State          (unless)++import           System.Directory             (doesFileExist, getHomeDirectory) import           System.IO  import           Language.Egison.AST import           Language.Egison.CmdOptions import           Language.Egison.Data+import qualified Language.Egison.Parser.NonS  as NonS+import qualified Language.Egison.Parser.SExpr as SExpr import           Language.Egison.RState-import qualified Language.Egison.Parser.SExpr   as SExpr-import qualified Language.Egison.Parser.NonS    as NonS-import           Paths_egison                   (getDataFileName)+import           Paths_egison                 (getDataFileName)  readTopExprs :: String -> EvalM [TopExpr] readTopExprs expr = do
hs-src/Language/Egison/Parser/NonS.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE NamedFieldPuns #-}  {- | Module      : Language.Egison.Parser.NonS@@ -23,8 +22,9 @@  import           Data.Char                      (isAsciiUpper, isLetter) import           Data.Either                    (isRight)+import           Data.Function                  (on) import           Data.Functor                   (($>))-import           Data.List                      (groupBy, insertBy)+import           Data.List                      (groupBy, insertBy, sortOn) import           Data.Maybe                     (isJust, isNothing) import           Data.Text                      (pack) @@ -33,7 +33,7 @@ import           Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer     as L -import           Language.Egison.AST            hiding (Assoc(..))+import           Language.Egison.AST            hiding (Assoc (..)) import qualified Language.Egison.AST            as E import           Language.Egison.RState @@ -122,7 +122,7 @@   return (InfixDecl isPattern newop)   where     check :: String -> Parser String-    check ('!':_) = fail $ "cannot declare infix starting with '!'"+    check ('!':_) = fail "cannot declare infix starting with '!'"     check x | x `elem` reservedOp = fail $ show x ++ " cannot be a new infix"             | otherwise           = return x @@ -151,7 +151,7 @@   body <- exprWithoutWhere   bindings <- optional (reserved "where" >> alignSome binding)   return $ case bindings of-             Nothing -> body+             Nothing       -> body              Just bindings -> LetRecExpr bindings body  exprWithoutWhere :: Parser Expr@@ -186,7 +186,8 @@ makeExprTable :: [Op] -> [[Operator Parser Expr]] makeExprTable ops =   -- Generate binary operator table from |ops|-  map (map toOperator) (groupBy (\x y -> priority x == priority y) ops)+  reverse $ map (map snd) $ groupBy ((==) `on` fst) $ sortOn fst $+    (infixFuncOpPriority, infixFuncOperator) : map (\op -> (priority op, toOperator op)) ops   where     -- notFollowedBy (in unary and binary) is necessary for section expression.     unary :: String -> Parser (Expr -> Expr)@@ -207,6 +208,17 @@         E.InfixN -> InfixN (binary op)         E.Prefix -> Prefix (unary (repr op)) +    infixFuncOperator :: Operator Parser Expr+    infixFuncOperator = InfixL $ InfixExpr <$> infixFuncOp++infixFuncOp :: Parser Op+infixFuncOp = do+  func <- try (indented >> between (symbol "`") (symbol "`") ident)+  return $ Op { repr = func, priority = infixFuncOpPriority, assoc = E.InfixL, isWedge = False }++infixFuncOpPriority :: Int+infixFuncOpPriority = 7+ ifExpr :: Parser Expr ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr @@ -266,7 +278,12 @@ argPatternAtom   =   APWildCard <$  symbol "_"   <|> APTuplePat <$> parens (sepBy arg comma)-  <|> APPatVar   <$> ident+  <|> collectionPattern+  <|> APPatVar   <$> varWithIndicesLiteral+    where+      collectionPattern = brackets $ do+        elems <- sepBy arg comma+        return $ foldr APConsPat APEmptyPat elems  letExpr :: Parser Expr letExpr = do@@ -388,7 +405,7 @@     leftSection :: Parser Expr     leftSection = do       ops  <- gets exprOps-      op   <- choice $ map (infixLiteral . repr) ops+      op   <- choice $ infixFuncOp : map (infixLiteral . repr) ops       rarg <- optional expr       case rarg of         -- Disabling for now... (See issue 159)@@ -402,7 +419,7 @@     rightSection = do       ops  <- gets exprOps       larg <- opExpr-      op   <- choice $ map (infixLiteral . repr) ops+      op   <- choice $ infixFuncOp : map (infixLiteral . repr) ops       case larg of         -- InfixExpr op' _ _         --   | assoc op' /= InfixL && priority op >= priority op' ->@@ -457,7 +474,9 @@  -- Atomic expressions without index atomExpr' :: Parser Expr-atomExpr' = anonParamFuncExpr    -- must come before |constantExpr|+atomExpr' = anonParamFuncExpr      -- must come before |constantExpr|+        <|> anonTupleParamFuncExpr -- must come before |tupleOrParenExpr|+        <|> anonListParamFuncExpr  -- must come before |collectionExpr|         <|> ConstantExpr <$> constantExpr         <|> FreshVarExpr <$ symbol "#"         <|> VarExpr <$> ident@@ -465,8 +484,8 @@         <|> collectionExpr         <|> tupleOrParenExpr         <|> hashExpr-        <|> QuoteExpr <$> (char '\'' >> atomExpr') -- must come after |constantExpr|-        <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')+        <|> QuoteExpr <$> (try (symbol "`" <* notFollowedBy ident) >> atomExpr') -- must come after |constantExpr|+        <|> QuoteSymbolExpr <$> try (char '\'' >> atomExpr')         <|> AnonParamExpr  <$> try (char '%' >> positiveIntegerLiteral)         <?> "atomic expression" @@ -476,6 +495,16 @@   body <- atomExpr                    -- No space after '#'   return $ AnonParamFuncExpr n body +anonTupleParamFuncExpr :: Parser Expr+anonTupleParamFuncExpr = do+  n <- try (char '(' *> L.decimal <* string ")#")+  AnonTupleParamFuncExpr n <$> atomExpr++anonListParamFuncExpr :: Parser Expr+anonListParamFuncExpr = do+  n <- try (char '[' *> L.decimal <* string "]#")+  AnonListParamFuncExpr n <$> atomExpr+ constantExpr :: Parser ConstantExpr constantExpr = numericExpr            <|> BoolExpr <$> boolLiteral@@ -683,11 +712,24 @@   lexeme (VarWithIndices <$> ident' <*> some varIndex)  varIndex :: Parser VarIndex-varIndex = (char '_' >> VSubscript <$> ident')-       <|> (char '~' >> VSuperscript <$> ident')+varIndex = (char '_' >> subscript)+       <|> (char '~' >> supscript)        <|> parens (VGroupScripts <$> some varIndex)        <|> braces (VSymmScripts <$> some varIndex)        <|> brackets (VAntiSymmScripts <$> some varIndex)+  where+    subscript = VSubscript <$> ident'+            <|> (do+              (n, s) <- parens $ (,) <$> ident' <*> (char '_' >> positiveIntegerLiteral)+              _ <- string "..." >> char '_'+              e <- parens $ string n >> char '_' >> ident'+              return (VMultiSubscript n s e))+    supscript = VSuperscript <$> ident'+            <|> (do+              (n, s) <- parens $ (,) <$> ident' <*> (char '_' >> positiveIntegerLiteral)+              _ <- string "..." >> char '~'+              e <- parens $ string n >> char '_' >> ident'+              return (VMultiSuperscript n s e))  patVarLiteral :: Parser String patVarLiteral = char '$' >> ident
hs-src/Language/Egison/Parser/SExpr.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns  #-}-{-# OPTIONS_GHC -Wno-all   #-} -- Since we will soon deprecate this parser+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-all  #-} -- Since we will soon deprecate this parser  {- | Module      : Language.Egison.Parser.SExpr@@ -18,21 +17,20 @@        , parseExpr        ) where -import           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>))-import           Control.Monad.Except    (throwError)-import           Control.Monad.Identity  (Identity)+import           Control.Applicative    (pure, (*>), (<$>), (<*), (<*>))+import           Control.Monad.Except   (throwError)+import           Control.Monad.Identity (Identity) -import           Data.Char               (isLower, isUpper, toUpper)+import           Data.Char              (isLower, isUpper, toUpper) import           Data.Either-import           Data.Functor            (($>))-import           Data.List.Split         (splitOn)+import           Data.Functor           (($>)) import           Data.Ratio-import qualified Data.Set                as Set-import qualified Data.Text               as T+import qualified Data.Set               as Set+import qualified Data.Text              as T  import           Text.Parsec import           Text.Parsec.String-import qualified Text.Parsec.Token       as P+import qualified Text.Parsec.Token      as P  import           Language.Egison.AST @@ -195,12 +193,12 @@   isElementExpr _             = False    f :: [Expr] -> [InnerExpr] -> Expr-  f xs [] = CollectionExpr xs-  f xs [ElementExpr y] = CollectionExpr (xs ++ [y])-  f []  [SubCollectionExpr y] = y-  f [x] [SubCollectionExpr y] = ConsExpr x y-  f xs  [SubCollectionExpr y] = JoinExpr (CollectionExpr xs) y-  f xs (ElementExpr y : ys) = f (xs ++ [y]) ys+  f xs []                          = CollectionExpr xs+  f xs [ElementExpr y]             = CollectionExpr (xs ++ [y])+  f []  [SubCollectionExpr y]      = y+  f [x] [SubCollectionExpr y]      = ConsExpr x y+  f xs  [SubCollectionExpr y]      = JoinExpr (CollectionExpr xs) y+  f xs (ElementExpr y : ys)        = f (xs ++ [y]) ys   f []  (SubCollectionExpr y : ys) = JoinExpr y (f [] ys)   f [x] (SubCollectionExpr y : ys) = ConsExpr x (JoinExpr y (f [] ys))   f xs  (SubCollectionExpr y : ys) = JoinExpr (CollectionExpr xs) (JoinExpr y (f [] ys))@@ -385,7 +383,7 @@       <|> try (TensorArg <$> (char '%' >> argPattern))  argPattern :: Parser ArgPattern-argPattern = APPatVar <$> ident+argPattern = APPatVar <$> identVarWithIndices  seqExpr :: Parser Expr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr@@ -404,7 +402,7 @@         let n = toInteger (length vars)             args' = f args 1          in return $ AnonParamFuncExpr n $ ApplyExpr func args'-      | all (not . null) vars ->+      | not (any null vars) ->         let ns = Set.fromList $ map read vars             n = Set.size ns         in if Set.findMin ns == 1 && Set.findMax ns == n@@ -417,9 +415,9 @@   arg = try (Right <$> expr)          <|> char '$' *> (Left <$> option "" index)   index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit-  f [] _                   = []-  f (Left _ : args) n      = AnonParamExpr n : f args (n + 1)-  f (Right expr : args) n  = expr : f args n+  f [] _                  = []+  f (Left _ : args) n     = AnonParamExpr n : f args (n + 1)+  f (Right expr : args) n = expr : f args n   g (Left arg)   = AnonParamExpr (read arg)   g (Right expr) = expr @@ -859,8 +857,17 @@   , ("rdc",         "init")   ] +splitOn :: Eq a => a -> [a] -> [[a]]+splitOn sep list =+  case span (/= sep) list of+    ([], [])    -> []+    ([], _ : t) -> splitOn sep t+    (h, [])     -> [h]+    (h, _ : t)  -> h : splitOn sep t+ -- Translate identifiers for Non-S syntax toCamelCase :: String -> String+toCamelCase "-" = "-" toCamelCase "-'" = "-'" toCamelCase "f.-'" = "f.-'" toCamelCase "b.." = "b."@@ -870,8 +877,8 @@ toCamelCase (reverse -> 'm':'/':xs) =   toCamelCase (reverse xs ++ "-as") toCamelCase x =-  let heads:tails = splitOn "-" x+  let heads:tails = splitOn '-' x    in concat $ heads : map capitalize tails   where-    capitalize [] = "-"+    capitalize []     = "-"     capitalize (x:xs) = toUpper x : xs
hs-src/Language/Egison/Pretty.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE ViewPatterns           #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-} {-# OPTIONS_GHC -Wno-orphans        #-}  {- |@@ -18,11 +16,11 @@     , showTSV     ) where -import           Data.Foldable             (toList)-import           Data.List                 (intercalate)+import           Data.Foldable                           (toList)+import           Data.List                               (intercalate) import           Data.Text.Prettyprint.Doc import           Data.Text.Prettyprint.Doc.Render.String (renderString)-import           Text.Show.Unicode         (ushow)+import           Text.Show.Unicode                       (ushow)  import           Language.Egison.AST import           Language.Egison.Data@@ -51,8 +49,8 @@   pretty (BoolExpr x)    = pretty x   pretty (IntegerExpr x) = pretty x   pretty (FloatExpr x)   = pretty x-  pretty SomethingExpr = pretty "something"-  pretty UndefinedExpr = pretty "undefined"+  pretty SomethingExpr   = pretty "something"+  pretty UndefinedExpr   = pretty "undefined"  instance Pretty Expr where   pretty (ConstantExpr c) = pretty c@@ -194,8 +192,8 @@   pretty (VarWithIndices xs is) = pretty xs <> hcat (map pretty is)  instance Pretty VarIndex where-  pretty (VSubscript x)   = pretty ('_' : x)-  pretty (VSuperscript x) = pretty ('~' : x)+  pretty (VSubscript x)        = pretty ('_' : x)+  pretty (VSuperscript x)      = pretty ('~' : x)   pretty (VSymmScripts xs)     = pretty '{' <> hcat (map pretty xs) <> pretty '}'   pretty (VAntiSymmScripts xs) = pretty '[' <> hcat (map pretty xs) <> pretty ']' @@ -217,12 +215,12 @@   pretty _                = undefined  instance (Pretty a, Complex a) => Pretty (IndexExpr a) where-  pretty (Subscript i) = pretty '_' <> pretty' i-  pretty (Superscript i) = pretty '~' <> pretty' i-  pretty (SupSubscript i) = pretty "~_" <> pretty' i-  pretty (MultiSubscript i j) = pretty '_' <> pretty' i <> pretty "..._" <> pretty' j+  pretty (Subscript i)          = pretty '_' <> pretty' i+  pretty (Superscript i)        = pretty '~' <> pretty' i+  pretty (SupSubscript i)       = pretty "~_" <> pretty' i+  pretty (MultiSubscript i j)   = pretty '_' <> pretty' i <> pretty "..._" <> pretty' j   pretty (MultiSuperscript i j) = pretty '~' <> pretty' i <> pretty "...~" <> pretty' j-  pretty (Userscript i) = pretty '|' <> pretty' i+  pretty (Userscript i)         = pretty '|' <> pretty' i  instance Pretty Pattern where   pretty WildCard     = pretty "_"@@ -259,9 +257,9 @@   pretty SeqNilPat = pretty "{}"   pretty (SeqConsPat p1 p2) = listoid "{" "}" (f p1 p2)     where-      f p1 SeqNilPat = [pretty p1]+      f p1 SeqNilPat          = [pretty p1]       f p1 (SeqConsPat p2 p3) = pretty p1 : f p2 p3-      f p1 p2 = [pretty p1, pretty p2]+      f p1 p2                 = [pretty p1, pretty p2]   pretty LaterPatVar = pretty "@"   pretty (DApplyPat p ps) = applyLike (map pretty' (p : ps))   pretty e            = pretty (show e)@@ -273,21 +271,21 @@   pretty (LoopRange from to pat) = tupled [pretty from, pretty to, pretty pat]  instance Pretty PrimitivePatPattern where-  pretty PPWildCard     = pretty "_"-  pretty PPPatVar       = pretty "$"-  pretty (PPValuePat x) = pretty ('#' : '$' : x)+  pretty PPWildCard                = pretty "_"+  pretty PPPatVar                  = pretty "$"+  pretty (PPValuePat x)            = pretty ('#' : '$' : x)   pretty (PPInductivePat x pppats) = hsep (pretty x : map pretty pppats)-  pretty (PPTuplePat pppats) = tupled (map pretty pppats)+  pretty (PPTuplePat pppats)       = tupled (map pretty pppats)  instance Pretty PrimitiveDataPattern where-  pretty PDWildCard   = pretty "_"-  pretty (PDPatVar x) = pretty x+  pretty PDWildCard                = pretty "_"+  pretty (PDPatVar x)              = pretty x   pretty (PDInductivePat x pdpats) = applyLike (pretty x : map pretty' pdpats)-  pretty (PDTuplePat pdpats) = tupled (map pretty pdpats)-  pretty PDEmptyPat = pretty "[]"-  pretty (PDConsPat pdp1 pdp2) = pretty'' pdp1 <+> pretty "::" <+> pretty'' pdp2-  pretty (PDSnocPat pdp1 pdp2) = applyLike [pretty "snoc", pretty' pdp1, pretty' pdp2]-  pretty (PDConstantPat expr) = pretty expr+  pretty (PDTuplePat pdpats)       = tupled (map pretty pdpats)+  pretty PDEmptyPat                = pretty "[]"+  pretty (PDConsPat pdp1 pdp2)     = pretty'' pdp1 <+> pretty "::" <+> pretty'' pdp2+  pretty (PDSnocPat pdp1 pdp2)     = applyLike [pretty "snoc", pretty' pdp1, pretty' pdp2]+  pretty (PDConstantPat expr)      = pretty expr  instance Pretty Op where   pretty op | isWedge op = pretty ("!" ++ repr op)@@ -338,11 +336,11 @@   isAtom TransposeExpr{}          = False   isAtom _                        = True -  isAtomOrApp ApplyExpr{}         = True-  isAtomOrApp e                   = isAtom e+  isAtomOrApp ApplyExpr{} = True+  isAtomOrApp e           = isAtom e -  isInfix InfixExpr{}             = True-  isInfix _                       = False+  isInfix InfixExpr{} = True+  isInfix _           = False  instance Complex a => Complex (Arg a) where   isAtom (TensorArg x) = isAtom x@@ -363,11 +361,11 @@   isInfix _ = False  instance Complex Pattern where-  isAtom (LetPat _ _)        = False+  isAtom LetPat{}            = False   isAtom (InductivePat _ []) = True   isAtom (InductivePat _ _)  = False-  isAtom (InfixPat _ _ _)    = False-  isAtom (LoopPat _ _ _ _)   = False+  isAtom InfixPat{}          = False+  isAtom LoopPat{}           = False   isAtom (PApplyPat _ [])    = True   isAtom (PApplyPat _ _)     = False   isAtom _                   = True@@ -382,8 +380,8 @@ instance Complex PrimitiveDataPattern where   isAtom (PDInductivePat _ []) = True   isAtom (PDInductivePat _ _)  = False-  isAtom (PDConsPat _ _)       = False-  isAtom (PDSnocPat _ _)       = False+  isAtom PDConsPat{}           = False+  isAtom PDSnocPat{}           = False   isAtom _                     = True    isAtomOrApp PDInductivePat{} = True@@ -404,7 +402,7 @@ -- Display "hoge" instead of "() := hoge" prettyDoBinds :: BindingExpr -> Doc ann prettyDoBinds (Bind (PDTuplePat []) expr) = pretty expr-prettyDoBinds bind = pretty "let" <+> pretty bind+prettyDoBinds bind                        = pretty "let" <+> pretty bind  prettyMatch :: Expr -> [MatchClause] -> Doc ann prettyMatch matcher clauses =@@ -449,8 +447,8 @@  showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map show vals)-showTSV (Collection vals) = intercalate "\t" (map show (toList vals))-showTSV val = show val+showTSV (Collection vals)  = intercalate "\t" (map show (toList vals))+showTSV val                = show val  -- -- Pretty printer for error messages
hs-src/Language/Egison/PrettyMath/AST.hs view
@@ -13,12 +13,12 @@   , parseExpr   ) where -import           Data.Foldable             (toList)+import           Data.Foldable                 (toList) import           Text.ParserCombinators.Parsec hiding (spaces) -import qualified Language.Egison.Data      as E-import qualified Language.Egison.IExpr     as E-import qualified Language.Egison.Math.Expr as E+import qualified Language.Egison.Data          as E+import qualified Language.Egison.IExpr         as E+import qualified Language.Egison.Math.Expr     as E  data MathExpr   = Atom String [MathIndex]@@ -49,19 +49,24 @@   toMathExpr :: a -> MathExpr  instance ToMathExpr E.EgisonValue where-  toMathExpr (E.ScalarData s) = toMathExpr s-  toMathExpr (E.Tuple es) = Tuple (map toMathExpr es)+  toMathExpr (E.ScalarData s)  = toMathExpr s+  toMathExpr (E.Tuple es)      = Tuple (map toMathExpr es)   toMathExpr (E.Collection es) = Collection (map toMathExpr (toList es))-  toMathExpr (E.TensorData t) = toMathExpr t-  toMathExpr e = Atom (show e) []+  toMathExpr (E.TensorData t)  = toMathExpr t+  toMathExpr e                 = Atom (show e) []  instance ToMathExpr a => ToMathExpr (E.Tensor a) where-  toMathExpr (E.Scalar _) = undefined-  toMathExpr (E.Tensor _ xs js) = Tensor (map toMathExpr (toList xs)) (map toMathIndex js)+  toMathExpr (E.Scalar _)       = undefined+  toMathExpr (E.Tensor [_] xs js) = Tensor (map toMathExpr (toList xs)) (map toMathIndex js)+  toMathExpr (E.Tensor [_, n] xs js) = Tensor (f (fromIntegral n) (map toMathExpr (toList xs))) (map toMathIndex js)+    where+      f _ [] = []+      f n xs = Tensor (take n xs) [] : f n (drop n xs)+  toMathExpr (E.Tensor _ _ _) = undefined  instance ToMathExpr E.ScalarData where   toMathExpr (E.Div p (E.Plus [E.Term 1 []])) = toMathExpr p-  toMathExpr (E.Div p1 p2) = Div (toMathExpr p1) (toMathExpr p2)+  toMathExpr (E.Div p1 p2)                    = Div (toMathExpr p1) (toMathExpr p2)  instance ToMathExpr E.PolyExpr where   toMathExpr (E.Plus [])  = Atom "0" []@@ -100,12 +105,21 @@       (Atom "^" [], [x, y]) -> Power (toMathExpr x) (toMathExpr y)       _                     -> Func (toMathExpr fn) (map toMathExpr mExprs)   toMathExpr (E.Quote mExpr) = Quote (toMathExpr mExpr)-  toMathExpr (E.FunctionData _ _ _ _) = undefined -- TODO+  toMathExpr (E.FunctionData (E.SingleTerm 1 [(E.Symbol _ s js, 1)]) _ _) = toMathExpr' js (Atom s [])+    where+      toMathExpr' [] acc = acc+      toMathExpr' (E.User x:js) (Partial e ps) =+        toMathExpr' js (Partial e (ps ++ [toMathExpr x]))+      toMathExpr' (E.User x:js) e@Atom{} =+        toMathExpr' js (Partial e [toMathExpr x])+      toMathExpr' (j:js) (Atom e is) =+        toMathExpr' js (Atom e (is ++ [toMathIndex j]))+      toMathExpr' _ _ = undefined -- TODO  toMathIndex :: ToMathExpr a => E.Index a -> MathIndex toMathIndex (E.Sub x) = Sub (toMathExpr x) toMathIndex (E.Sup x) = Super (toMathExpr x)-toMathIndex _ = undefined -- TODO+toMathIndex _         = undefined -- TODO  -- -- Parser
hs-src/Language/Egison/PrettyMath/AsciiMath.hs view
@@ -7,7 +7,7 @@   ( showMathExpr   ) where -import           Data.List                     (intercalate)+import           Data.List                      (intercalate)  import           Language.Egison.PrettyMath.AST @@ -18,11 +18,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs  where   showMathExprForPlus :: [MathExpr] -> String-  showMathExprForPlus [] = ""-  showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+  showMathExprForPlus []                                  = ""+  showMathExprForPlus (NegativeAtom a:xs)                 = " - " ++ a ++ showMathExprForPlus xs   showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs-  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ " " ++ showMathExprForPlus xs-  showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs+  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs)   = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ " " ++ showMathExprForPlus xs+  showMathExprForPlus (x:xs)                              = " + " ++ showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs)@@ -36,14 +36,14 @@ showMathExpr (Tensor lvs mis)   | null mis = "(" ++ showMathExprArg lvs ++ ")"   | not (any isSub mis) = "(" ++ showMathExprArg lvs ++ ")^(" ++ showMathExprIndices mis ++ ")"-  | not (any (not . isSub) mis) = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices mis ++ ")"+  | all isSub mis = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices mis ++ ")"   | otherwise = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")" showMathExpr (Tuple lvs) = "(" ++ showMathExprArg lvs ++ ")" showMathExpr (Collection lvs) = "{" ++ showMathExprArg lvs ++ "}"  showMathExpr' :: MathExpr -> String showMathExpr' (Plus lvs) = "(" ++ showMathExpr (Plus lvs) ++ ")"-showMathExpr' val = showMathExpr val+showMathExpr' val        = showMathExpr val  showMathExprArg :: [MathExpr] -> String showMathExprArg exprs = intercalate ", " $ map showMathExpr exprs
hs-src/Language/Egison/PrettyMath/Latex.hs view
@@ -7,7 +7,7 @@   ( showMathExpr   ) where -import           Data.List                     (intercalate)+import           Data.List                      (intercalate)  import           Language.Egison.PrettyMath.AST @@ -31,11 +31,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs  where   showMathExprForPlus :: [MathExpr] -> String-  showMathExprForPlus [] = ""-  showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+  showMathExprForPlus []                                  = ""+  showMathExprForPlus (NegativeAtom a:xs)                 = " - " ++ a ++ showMathExprForPlus xs   showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs-  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs-  showMathExprForPlus (x:xs) = " + " ++  showMathExpr x ++ showMathExprForPlus xs+  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs)   = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs+  showMathExprForPlus (x:xs)                              = " + " ++  showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs)@@ -74,10 +74,10 @@ showMathExprScript is = "_{" ++ concatMap showMathExprSub is ++ "}^{" ++ concatMap showMathExprSuper is ++ "}"  showMathExprVectors :: [MathExpr] -> String-showMathExprVectors [] = ""+showMathExprVectors []                = "" showMathExprVectors (Tensor lvs []:r) = showMathExprArg lvs " & " ++ " \\\\ " ++ showMathExprVectors r-showMathExprVectors lvs = showMathExprArg lvs " \\\\ " ++ "\\\\ "+showMathExprVectors lvs               = showMathExprArg lvs " \\\\ " ++ "\\\\ "  elemCount :: Eq a => [a] -> [(a, Int)]-elemCount [] = []+elemCount []     = [] elemCount (x:xs) = (x, length (filter (== x) xs) + 1) : elemCount (filter (/= x) xs)
hs-src/Language/Egison/PrettyMath/Mathematica.hs view
@@ -7,7 +7,7 @@   ( showMathExpr   ) where -import           Data.List                     (intercalate)+import           Data.List                      (intercalate)  import           Language.Egison.PrettyMath.AST @@ -20,11 +20,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs  where   showMathExprForPlus :: [MathExpr] -> String-  showMathExprForPlus [] = ""-  showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+  showMathExprForPlus []                                  = ""+  showMathExprForPlus (NegativeAtom a:xs)                 = " - " ++ a ++ showMathExprForPlus xs   showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs-  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs-  showMathExprForPlus (x:xs) = " + " ++  showMathExpr x ++ showMathExprForPlus xs+  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs)   = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs+  showMathExprForPlus (x:xs)                              = " + " ++  showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs)@@ -42,7 +42,7 @@ showMathExpr (Tensor lvs mis)   | null mis = "{" ++ showMathExprArg lvs ++ "}"   | not (any isSub mis) = "{" ++ showMathExprArg lvs ++ "}^(" ++ showMathExprIndices mis ++ ")"-  | not (any (not . isSub) mis) = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices mis ++ ")"+  | all isSub mis = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices mis ++ ")"   | otherwise = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")" showMathExpr (Tuple xs) = "(" ++ showMathExprArg xs ++ ")" showMathExpr (Collection xs) = "{" ++ showMathExprArg xs ++ "}"@@ -50,7 +50,7 @@  showMathExpr' :: MathExpr -> String showMathExpr' (Plus xs) = "(" ++ showMathExpr (Plus xs) ++ ")"-showMathExpr' x = showMathExpr x+showMathExpr' x         = showMathExpr x  showMathExprs :: String -> [MathExpr] -> String showMathExprs sep exprs = intercalate sep $ map showMathExpr exprs
hs-src/Language/Egison/PrettyMath/Maxima.hs view
@@ -17,11 +17,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs  where   showMathExprForPlus :: [MathExpr] -> String-  showMathExprForPlus [] = ""-  showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs+  showMathExprForPlus []                                  = ""+  showMathExprForPlus (NegativeAtom a:xs)                 = " - " ++ a ++ showMathExprForPlus xs   showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs-  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs-  showMathExprForPlus (x:xs) = " + " ++  showMathExpr x ++ showMathExprForPlus xs+  showMathExprForPlus (Multiply (NegativeAtom a:ys):xs)   = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs+  showMathExprForPlus (x:xs)                              = " + " ++  showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs)@@ -43,10 +43,10 @@  showMathExpr' :: MathExpr -> String showMathExpr' x@(Plus _) = "(" ++ showMathExpr x ++ ")"-showMathExpr' x         = showMathExpr x+showMathExpr' x          = showMathExpr x  showMathExprArg :: [MathExpr] -> String-showMathExprArg [] = ""+showMathExprArg []            = "" showMathExprArg [Tensor _ []] = "undefined"-showMathExprArg [a] = showMathExpr a-showMathExprArg lvs = showMathExpr (head lvs) ++ ", " ++ showMathExprArg (tail lvs)+showMathExprArg [a]           = showMathExpr a+showMathExprArg lvs           = showMathExpr (head lvs) ++ ", " ++ showMathExprArg (tail lvs)
hs-src/Language/Egison/Primitives.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase       #-}  {- | Module      : Language.Egison.Primitives@@ -17,23 +16,22 @@  import           Data.IORef -import qualified Data.Sequence             as Sq-import qualified Data.Vector               as V+import qualified Data.Sequence                     as Sq+import qualified Data.Vector                       as V   {--  -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite  --}  -- for 'egison-sqlite'  import           Language.Egison.Data-import           Language.Egison.Data.Collection  (makeICollection)-import           Language.Egison.EvalState        (MonadEval(..))-import           Language.Egison.IExpr            (stringToVar, Index(..))+import           Language.Egison.Data.Collection   (makeICollection)+import           Language.Egison.IExpr             (Index (..), stringToVar)+import           Language.Egison.Math import           Language.Egison.Primitives.Arith import           Language.Egison.Primitives.IO import           Language.Egison.Primitives.String import           Language.Egison.Primitives.Types import           Language.Egison.Primitives.Utils-import           Language.Egison.Math  primitiveEnv :: IO Env primitiveEnv = do@@ -122,7 +120,7 @@       return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sub s]))))     (ScalarData (SingleSymbol (Symbol id name is)), ScalarData s@(SingleTerm _ [])) ->       return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sub s]))))-    _ -> throwError =<< TypeMismatch "symbol or integer" (Value fn) <$> getFuncNameStack+    _ -> throwErrorWithTrace (TypeMismatch "symbol or integer" (Value fn))  addSuperscript :: String -> PrimitiveFunc addSuperscript = twoArgs $ \fn sub ->@@ -131,21 +129,21 @@       return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sup s]))))     (ScalarData (SingleSymbol (Symbol id name is)), ScalarData s@(SingleTerm _ [])) ->       return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sup s]))))-    _ -> throwError =<< TypeMismatch "symbol" (Value fn) <$> getFuncNameStack+    _ -> throwErrorWithTrace (TypeMismatch "symbol" (Value fn))  assert ::  String -> PrimitiveFunc assert = twoArgs' $ \label test -> do   test <- fromEgison test   if test     then return $ Bool True-    else throwError =<< Assertion (show label) <$> getFuncNameStack+    else throwErrorWithTrace (Assertion (show label))  assertEqual :: String -> PrimitiveFunc assertEqual = threeArgs' $ \label actual expected ->   if actual == expected      then return $ Bool True-     else throwError =<< Assertion-       (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual) <$> getFuncNameStack+     else throwErrorWithTrace (Assertion+            (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual))   {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc
hs-src/Language/Egison/Primitives/Arith.hs view
@@ -12,11 +12,9 @@   ( primitiveArithFunctions   ) where -import           Control.Monad.Except import           Language.Egison.Data-import           Language.Egison.EvalState        (MonadEval(..))-import           Language.Egison.Primitives.Utils import           Language.Egison.Math+import           Language.Egison.Primitives.Utils  primitiveArithFunctions :: [(String, EgisonValue)] primitiveArithFunctions =@@ -96,8 +94,8 @@ scalarBinaryOp mOp = twoArgs scalarBinaryOp'  where   scalarBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData) (mOp m1 m2)-  scalarBinaryOp' (ScalarData _)  val             = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryOp' val             _               = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryOp' (ScalarData _)  val             = throwErrorWithTrace (TypeMismatch "number" (Value val))+  scalarBinaryOp' val             _               = throwErrorWithTrace (TypeMismatch "number" (Value val))  plus :: String -> PrimitiveFunc plus = scalarBinaryOp mathPlus@@ -115,19 +113,19 @@ numerator' = oneArg numerator''  where   numerator'' (ScalarData m) = return $ ScalarData (mathNumerator m)-  numerator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack+  numerator'' val            = throwErrorWithTrace (TypeMismatch "rational" (Value val))  denominator' :: String -> PrimitiveFunc denominator' = oneArg denominator''  where   denominator'' (ScalarData m) = return $ ScalarData (mathDenominator m)-  denominator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack+  denominator'' val            = throwErrorWithTrace (TypeMismatch "rational" (Value val))  fromScalarData :: String -> PrimitiveFunc fromScalarData = oneArg fromScalarData'  where   fromScalarData' (ScalarData m) = return $ mathExprToEgison m-  fromScalarData' val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  fromScalarData' val            = throwErrorWithTrace (TypeMismatch "number" (Value val))  toScalarData :: String -> PrimitiveFunc toScalarData = oneArg $ \val ->@@ -137,7 +135,7 @@ symbolNormalize = oneArg $ \val ->   case val of     ScalarData s -> return $ ScalarData (rewriteSymbol s)-    _ -> throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack+    _            -> throwErrorWithTrace (TypeMismatch "math expression" (Value val))  -- -- Pred@@ -154,14 +152,14 @@       r2 <- fromEgison val2 :: EvalM Rational       return $ Bool (cmp r1 r2)     (Float f1, Float f2) -> return $ Bool (cmp f1 f2)-    (ScalarData _, _) -> throwError =<< TypeMismatch "number" (Value val2) <$> getFuncNameStack-    (Float _,      _) -> throwError =<< TypeMismatch "float"  (Value val2) <$> getFuncNameStack-    _                 -> throwError =<< TypeMismatch "number" (Value val1) <$> getFuncNameStack+    (ScalarData _, _) -> throwErrorWithTrace (TypeMismatch "number" (Value val2))+    (Float _,      _) -> throwErrorWithTrace (TypeMismatch "float"  (Value val2))+    _                 -> throwErrorWithTrace (TypeMismatch "number" (Value val1))  truncate' :: String -> PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val  where-  numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer)+  numberUnaryOp' (ScalarData (Div (Plus []) _))                           = return $ toEgison (0 :: Integer)   numberUnaryOp' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return $ toEgison (quot x y)-  numberUnaryOp' (Float x)             = return $ toEgison (truncate x :: Integer)-  numberUnaryOp' val                   = throwError =<< TypeMismatch "rational or float" (Value val) <$> getFuncNameStack+  numberUnaryOp' (Float x)                                                = return $ toEgison (truncate x :: Integer)+  numberUnaryOp' val                                                      = throwErrorWithTrace (TypeMismatch "rational or float" (Value val))
hs-src/Language/Egison/Primitives/IO.hs view
@@ -22,7 +22,6 @@  import           Language.Egison.Core             (evalWHNF) import           Language.Egison.Data-import           Language.Egison.EvalState        (MonadEval(..)) import           Language.Egison.Primitives.Utils  @@ -195,5 +194,5 @@       val <- m >>= evalWHNF       case val of         Tuple [_, val'] -> return $ Value val'-        _ -> throwError =<< TypeMismatch "io" (Value val) <$> getFuncNameStack-    io' whnf = throwError =<< TypeMismatch "io" whnf <$> getFuncNameStack+        _               -> throwErrorWithTrace (TypeMismatch "io" (Value val))+    io' whnf = throwErrorWithTrace (TypeMismatch "io" whnf)
hs-src/Language/Egison/Primitives/String.hs view
@@ -55,7 +55,7 @@   str <- fromEgison val   case T.uncons str of     Just (c, rest) -> return $ Tuple [Char c, String rest]-    Nothing -> throwError $ Default "Tried to unsnoc empty string"+    Nothing        -> throwError $ Default "Tried to unsnoc empty string"  lengthString :: String -> PrimitiveFunc lengthString = unaryOp (toInteger . T.length)@@ -74,7 +74,7 @@   patStr <- fromEgison pat   srcStr <- fromEgison src   case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of-    Nothing -> return . Collection . Sq.fromList $ []+    Nothing      -> return . Collection . Sq.fromList $ []     Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String (T.pack a), String (T.pack b), String (T.pack c)]]  regexStringCaptureGroup :: String -> PrimitiveFunc
hs-src/Language/Egison/Primitives/Types.hs view
@@ -10,13 +10,10 @@   ( primitiveTypeFunctions   ) where -import           Control.Monad.Except- import           Data.Char                        (chr, ord) import           Data.Ratio                       ((%))  import           Language.Egison.Data-import           Language.Egison.EvalState        (MonadEval(..)) import           Language.Egison.Math import           Language.Egison.Primitives.Utils @@ -109,9 +106,9 @@ rationalToFloat :: String -> PrimitiveFunc rationalToFloat = oneArg $ \val ->   case val of-    ScalarData (Div (Plus []) _) -> return $ Float 0+    ScalarData (Div (Plus []) _)                           -> return $ Float 0     ScalarData (Div (Plus [Term x []]) (Plus [Term y []])) -> return $ Float (fromRational (x % y))-    _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack+    _                                                      -> throwErrorWithTrace (TypeMismatch "integer or rational number" (Value val))  charToInteger :: String -> PrimitiveFunc charToInteger = unaryOp ctoi
hs-src/Language/Egison/Primitives/Utils.hs view
@@ -15,12 +15,9 @@   , binaryOp   ) where -import           Control.Monad.Except--import qualified Data.Vector               as V+import qualified Data.Vector            as V  import           Language.Egison.Data-import           Language.Egison.EvalState (MonadEval(..)) import           Language.Egison.Tensor  {-# INLINE noArg #-}@@ -30,7 +27,7 @@     [] -> f     [Tuple []] -> f     _ ->-      throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack+      throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args))  {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc@@ -41,22 +38,22 @@       return $ TensorData (Tensor ns ds' js)     [arg] -> f arg     _ ->-      throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack+      throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args))  {-# INLINE oneArg' #-} oneArg' :: (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc oneArg' f name args =   case args of     [arg] -> f arg-    _     -> -      throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack+    _     ->+      throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args))  {-# INLINE twoArgs #-} twoArgs :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc twoArgs f name args =   case args of     [TensorData t1@Tensor{}, TensorData t2@Tensor{}] ->-      tProduct (\x y -> f x y) t1 t2 >>= fromTensor+      tProduct f t1 t2 >>= fromTensor     [TensorData(Tensor ns ds js), val] -> do       ds' <- V.mapM (`f` val) ds       return $ TensorData (Tensor ns ds' js)@@ -65,7 +62,7 @@       return $ TensorData (Tensor ns ds' js)     [val, val'] -> f val val'     [val] -> return . PrimitiveFunc $ oneArg (f val) name-    _ -> throwError =<< ArgumentsNumPrimitive name 2 (length args) <$> getFuncNameStack+    _ -> throwErrorWithTrace (ArgumentsNumPrimitive name 2 (length args))  {-# INLINE twoArgs' #-} twoArgs' :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc@@ -73,7 +70,7 @@   case args of     [val, val'] -> f val val'     [val]       -> return . PrimitiveFunc $ oneArg' (f val) name-    _           -> throwError =<< ArgumentsNumPrimitive name 2 (length args) <$> getFuncNameStack+    _           -> throwErrorWithTrace (ArgumentsNumPrimitive name 2 (length args))  {-# INLINE threeArgs' #-} threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc@@ -82,13 +79,13 @@     [val, val', val''] -> f val val' val''     [val, val']        -> return . PrimitiveFunc $ oneArg' (f val val') name     [val]              -> return . PrimitiveFunc $ twoArgs' (f val) name-    _                  -> throwError =<< ArgumentsNumPrimitive name 3 (length args) <$> getFuncNameStack+    _                  -> throwErrorWithTrace (ArgumentsNumPrimitive name 3 (length args))  lazyOneArg :: (WHNFData -> EvalM WHNFData) -> String -> LazyPrimitiveFunc lazyOneArg f name args =   case args of     [arg] -> f arg-    _     -> throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack+    _     -> throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args))  unaryOp :: (EgisonData a, EgisonData b) => (a -> b) -> String -> PrimitiveFunc unaryOp op = oneArg $ \val -> do
hs-src/Language/Egison/RState.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}  {- | Module      : Language.Egison.RState@@ -30,8 +29,8 @@  data RState = RState   { indexCounter :: Int-  , exprOps :: [Op]-  , patternOps :: [Op]+  , exprOps      :: [Op]+  , patternOps   :: [Op]   }  initialRState :: RState
hs-src/Language/Egison/Tensor.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE QuasiQuotes            #-}-{-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE QuasiQuotes            #-} {-# LANGUAGE ViewPatterns           #-}  {- |@@ -17,7 +16,6 @@     -- * Tensor     , tref     , enumTensorIndices-    , changeIndex     , tTranspose     , tTranspose'     , tFlipIndices@@ -31,19 +29,18 @@     , tConcat'     ) where -import           Prelude                   hiding (foldr, mappend, mconcat)+import           Prelude                    hiding (foldr, mappend, mconcat) -import           Control.Monad.Except      hiding (join)-import qualified Data.Vector               as V-import           Data.List                 (delete, intersect, partition, (\\))+import           Control.Monad.Except       (mzero, throwError, zipWithM)+import           Data.List                  (delete, intersect, partition, (\\))+import qualified Data.Vector                as V  import           Control.Egison-import qualified Control.Egison            as M+import qualified Control.Egison             as M  import           Language.Egison.Data import           Language.Egison.Data.Utils-import           Language.Egison.EvalState (getFuncNameStack)-import           Language.Egison.IExpr     (Index(..), extractSupOrSubIndex)+import           Language.Egison.IExpr      (Index (..), extractSupOrSubIndex) import           Language.Egison.Math import           Language.Egison.RState @@ -105,26 +102,26 @@ tIntRef' i (Tensor [n] xs _) =   if 0 < i && i <= n      then return . Scalar $ xs V.! fromIntegral (i - 1)-     else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack+     else throwErrorWithTrace (TensorIndexOutOfBounds i n) tIntRef' i (Tensor (n:ns) xs js) =   if 0 < i && i <= n    then let w = fromIntegral (product ns)             ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs)          in return $ Tensor ns ys (cdr js)-   else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack+   else throwErrorWithTrace (TensorIndexOutOfBounds i n) tIntRef' _ _ = throwError $ Default "More indices than the order of the tensor"  tIntRef :: [Integer] -> Tensor a -> EvalM (Tensor a) tIntRef [] (Tensor [] xs _)   | V.length xs == 1 = return $ Scalar (xs V.! 0)-  | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack+  | otherwise = throwErrorWithTrace (EgisonBug "sevaral elements in scalar tensor") tIntRef [] t = return t tIntRef (m:ms) t = tIntRef' m t >>= tIntRef ms  tIntRef1 :: [Integer] -> Tensor a -> EvalM a tIntRef1 [] (Scalar x) = return x tIntRef1 [] (Tensor [] xs _) | V.length xs == 1 = return (xs V.! 0)-tIntRef1 [] _ = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack+tIntRef1 [] _ = throwErrorWithTrace (EgisonBug "sevaral elements in scalar tensor") tIntRef1 (m:ms) t = tIntRef' m t >>= tIntRef1 ms  pattern SupOrSubIndex :: a -> Index a@@ -133,7 +130,7 @@ tref :: [Index EgisonValue] -> Tensor a -> EvalM (Tensor a) tref [] (Tensor [] xs _)   | V.length xs == 1 = return $ Scalar (xs V.! 0)-  | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack+  | otherwise = throwErrorWithTrace (EgisonBug "sevaral elements in scalar tensor") tref [] t = return t tref (s@(SupOrSubIndex (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do   let yss = split (product ns) xs@@ -162,13 +159,9 @@ -- >>> enumTensorIndices [2,2,2] -- [[1,1,1],[1,1,2],[1,2,1],[1,2,2],[2,1,1],[2,1,2],[2,2,1],[2,2,2]] enumTensorIndices :: Shape -> [[Integer]]-enumTensorIndices [] = [[]]+enumTensorIndices []     = [[]] enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n] -changeIndex :: Index String -> EgisonValue -> Index String-changeIndex (Sup s) m = Sup (s ++ show m)-changeIndex (Sub s) m = Sub (s ++ show m)- -- transIndex [a, b, c] [c, a, b] [2, 3, 4] = [4, 2, 3] transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> Shape -> EvalM Shape transIndex is js ns = do@@ -184,13 +177,13 @@   let js' = take (length is) js   let ds = complementWithDF ns is   ns' <- transIndex (js' ++ ds) (is ++ ds) ns-  xs' <- V.fromList <$> mapM (transIndex (is ++ ds) (js' ++ ds)) (enumTensorIndices ns') >>= mapM (`tIntRef1` t)+  xs' <- mapM (transIndex (is ++ ds) (js' ++ ds)) (enumTensorIndices ns') >>= mapM (`tIntRef1` t) . V.fromList   return $ Tensor ns' xs' is  tTranspose' :: [EgisonValue] -> Tensor a -> EvalM (Tensor a) tTranspose' is t@(Tensor _ _ js) =   case mapM (\i -> f i js) is of-    Nothing -> return t+    Nothing  -> return t     Just is' -> tTranspose is' t  where   f :: EgisonValue -> [Index EgisonValue] -> Maybe (Index EgisonValue)
hs-src/Tool/translator.hs view
@@ -62,10 +62,10 @@   toNonS :: a -> a  instance SyntaxElement TopExpr where-  toNonS (Define x y)   = Define (toNonS x) (toNonS y)-  toNonS (Test x)       = Test (toNonS x)-  toNonS (Execute x)    = Execute (toNonS x)-  toNonS x              = x+  toNonS (Define x y) = Define (toNonS x) (toNonS y)+  toNonS (Test x)     = Test (toNonS x)+  toNonS (Execute x)  = Execute (toNonS x)+  toNonS x            = x  instance SyntaxElement Expr where   toNonS (VarExpr (lookupVarExprInfix -> Just op)) =@@ -176,15 +176,15 @@  instance SyntaxElement PrimitivePatPattern where   toNonS (PPInductivePat x pps) = PPInductivePat x (map toNonS pps)-  toNonS (PPTuplePat pps) = PPTuplePat (map toNonS pps)-  toNonS pp = pp+  toNonS (PPTuplePat pps)       = PPTuplePat (map toNonS pps)+  toNonS pp                     = pp  instance SyntaxElement PrimitiveDataPattern where   toNonS (PDInductivePat x pds) = PDInductivePat x (map toNonS pds)-  toNonS (PDTuplePat pds) = PDTuplePat (map toNonS pds)-  toNonS (PDConsPat pd1 pd2) = PDConsPat (toNonS pd1) (toNonS pd2)-  toNonS (PDSnocPat pd1 pd2) = PDSnocPat (toNonS pd1) (toNonS pd2)-  toNonS pd = pd+  toNonS (PDTuplePat pds)       = PDTuplePat (map toNonS pds)+  toNonS (PDConsPat pd1 pd2)    = PDConsPat (toNonS pd1) (toNonS pd2)+  toNonS (PDSnocPat pd1 pd2)    = PDSnocPat (toNonS pd1) (toNonS pd2)+  toNonS pd                     = pd  instance SyntaxElement LoopRange where   toNonS (LoopRange e1 e2 p) = LoopRange (toNonS e1) (toNonS e2) (toNonS p)@@ -193,7 +193,7 @@   toNonS script = toNonS <$> script  instance SyntaxElement BindingExpr where-  toNonS (Bind pdp x) = Bind (toNonS pdp) (toNonS x)+  toNonS (Bind pdp x)            = Bind (toNonS pdp) (toNonS x)   toNonS (BindWithIndices var x) = BindWithIndices var (toNonS x)  instance SyntaxElement MatchClause where
lib/core/assoc.egi view
@@ -17,36 +17,6 @@     | ($x, $n) :: $rs -> take n (repeat1 x) ++ fromAssoc rs  ----- Assoc List----def assocList a :=-  matcher-    | [] as () with-      | [] -> [()]-      | _ -> []-    | $ :: $ as (a, assocList a) with-      | $tgt ->-        match tgt as list (something, integer) with-          | ($x, #1) :: $rs -> [(x, rs)]-          | ($x, $n) :: $rs -> [(x, (x, n - 1) :: rs)]-          | _ -> []-    | ncons $ #$k $ as (a, assocList a) with-      | $tgt ->-        match tgt as list (something, integer) with-          | ($x, #k) :: $rs -> [(x, rs)]-          | ($x, ?(> k) & $n) :: $rs -> [(x, (x, n - k) :: rs)]-          | _ -> []-    | ncons $ $ $ as (a, integer, assocList a) with-      | $tgt ->-        match tgt as list (something, integer) with-          | ($x, $k) :: $rs -> [(x, k, rs)]-          | _ -> []-    | #$val as () with-      | $tgt -> if val = tgt then [()] else []-    | $ as (something) with-      | $tgt -> [tgt]---- -- Assoc Multiset -- def assocMultiset a :=@@ -54,41 +24,41 @@     | [] as () with       | [] -> [()]       | _ -> []-    | #$x :: $ as (assocMultiset a) with-      | $tgt ->-        matchAll tgt as list (a, integer) with-          | $hs ++ (#x, $n) :: $ts ->-            if n = 1 then hs ++ ts else hs ++ (x, n - 1) :: ts-    | $ :: $ as (a, assocMultiset a) with-      | $tgt ->-        matchAll tgt as list (a, integer) with-          | $hs ++ ($x, $n) :: $ts ->-            if n = 1 then (x, hs ++ ts) else (x, hs ++ (x, n - 1) :: ts)-    | ncons #$x #$n $ as (assocMultiset a) with+    | #$x ^ #$n :: $ as (assocMultiset a) with       | $tgt ->         matchAll tgt as list (a, integer) with           | $hs ++ (#x, ?(>= n) & $k) :: $ts ->             if k - n = 0 then hs ++ ts else hs ++ (x, k - n) :: ts-    | ncons $ #$n $ as (a, assocMultiset a) with+    | $ ^ #$n :: $ as (a, assocMultiset a) with       | $tgt ->         matchAll tgt as list (a, integer) with           | $hs ++ ($x, ?(>= n) & $k) :: $ts ->             if k - n = 0 then (x, hs ++ ts) else (x, hs ++ (x, k - n) :: ts)-    | ncons #$x $ $ as (integer, assocMultiset a) with+    | #$x ^ $ :: $ as (integer, assocMultiset a) with       | $tgt ->         matchAll tgt as list (a, integer) with           | $hs ++ (#x, $n) :: $ts -> (n, hs ++ ts)-    | ncons $ $ $ as (a, integer, assocMultiset a) with+    | $ ^ $ :: $ as (a, integer, assocMultiset a) with       | $tgt ->         matchAll tgt as list (a, integer) with           | $hs ++ ($x, $n) :: $ts -> (x, n, hs ++ ts)+    | #$x :: $ as (assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ (#x, $n) :: $ts ->+            if n = 1 then hs ++ ts else hs ++ (x, n - 1) :: ts+    | $ :: $ as (a, assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ ($x, $n) :: $ts ->+            if n = 1 then (x, hs ++ ts) else (x, hs ++ (x, n - 1) :: ts)     | $ as (something) with       | $tgt -> [tgt]  def AC.intersect xs ys :=   matchAll (xs, ys) as (assocMultiset something, assocMultiset something) with-    | (ncons $x $m _, ncons #x $n _) -> (x, min m n)+    | ($x ^ $m :: _, #x ^ $n :: _) -> (x, min m n)  def AC.intersectAs a xs ys :=   matchAll (xs, ys) as (assocMultiset a, assocMultiset a) with-    | (ncons $x $m _, ncons #x $n _) -> (x, min m n)+    | ($x ^ $m :: _, #x ^ $n :: _) -> (x, min m n)
lib/core/base.egi view
@@ -22,8 +22,8 @@  def id := 1#%1 -def fst (x, y) := x-def snd (x, y) := y+def fst (x, _) := x+def snd (_, y) := y  infixr expression 0 $
lib/core/collection.egi view
@@ -4,6 +4,8 @@ -- -- +infixr pattern 5 +++ -- -- List --@@ -148,7 +150,7 @@     | [] -> True     | _  -> False -def length xs := foldl 2#(%1 + 1) 0 xs+def length xs := foldl (\acc _ -> acc + 1) 0 xs  def map fn xs :=   match xs as list something with
lib/core/number.egi view
@@ -120,7 +120,7 @@    in (q, map fst s, map fst c)  def showDecimal c x :=-  match (\(x, y) -> (x, take c y)) (rtod x) as (integer, list integer) with+  match (2)#(%1, take c %2) (rtod x) as (integer, list integer) with     | ($q, $sc) -> foldl S.append (S.append (show q) ".") (map show sc)  def showDecimal' x :=@@ -158,7 +158,7 @@    in if x = 0         then (n, [])         else ( n-        , map (\(_, _, z) -> z) (regularContinuedFractionOfSqrtHelper m (n / x) (1 / x)) )+        , map (3)#%3 (regularContinuedFractionOfSqrtHelper m (n / x) (1 / x)) )  def regularContinuedFractionOfSqrt' m :=   let n := floor (sqrt (rtof m))@@ -170,6 +170,6 @@                                 m                                 (n / x)                                 (1 / x))-              in (n, map (\(_, _, x) -> x) s, map (\(_, _, x) -> x) c)+              in (n, map (3)#%3 s, map (3)#%3 c)  def pi := f.pi
lib/core/order.egi view
@@ -26,8 +26,8 @@ def min $x $y := if x < y then x else y def max $x $y := if x > y then x else y -def min/fn f $xs := foldl1 2#(if f %1 %2 = Less then %1 else %2) xs-def max/fn f $xs := foldl1 2#(if f %1 %2 = Greater then %1 else %2) xs+def min/fn f $xs := foldl1 (\x y -> if f x y = Less then x else y) xs+def max/fn f $xs := foldl1 (\x y -> if f x y = Greater then x else y) xs  def minimum $xs := foldl1 min xs def maximum $xs := foldl1 max xs@@ -57,7 +57,7 @@        in sort/fn f ys1 ++ ys2 ++ sort/fn f ys3  def sortStrings xs :=-  sort/fn 2#(compareC (map ctoi (unpack %1)) (map ctoi (unpack %2))) xs+  sort/fn (\x y -> compareC (map ctoi (unpack x)) (map ctoi (unpack y))) xs  def merge xs ys :=   match (xs, ys) as (list something, list something) with@@ -74,7 +74,7 @@     | (_, $y :: $tys) -> y :: merge xs tys  def minimize f xs :=-  foldl1 2#(if compare (f %1) (f %2) = Less then %1 else %2) xs+  foldl1 (\x y -> if compare (f x) (f y) = Less then x else y) xs  def maximize f xs :=-  foldl1 2#(if compare (f %1) (f %2) = Greater then %1 else %2) xs+  foldl1 (\x y -> if compare (f x) (f y) = Greater then x else y) xs
lib/core/shell.egi view
@@ -1,25 +1,16 @@+-- Get input and parse them into the format specified with sopts and copts.+-- Used in --map and --filter options. def SH.genInput sopts copts :=-  if io $ isEof ()-    then []-    else let line := io $ readLine ()-             x := TSV.parseLine sopts copts line-          in seq x (x :: SH.genInput sopts copts)--def TSV.map fn showFn := do-  let eof := isEof ()-  if eof-     then return ()-     else do let line := readLine ()-             print (showFn (fn (readTsv line)))-             TSV.map fn showFn--def TSV.filter fn := do-  let eof := isEof ()-  if eof-     then return ()-     else do let line := readLine ()-             if fn (readTsv line) then print line else return ()-             TSV.filter fn+  map (TSV.parseLine sopts copts) (io (readLines ()))+  where+    -- Read multiple lines from stdin until EOF.+    readLines () := do+      let eof := isEof ()+      if eof+        then return []+        else do let line := readLine ()+                let lines := readLines ()+                return (line :: lines)  def TSV.parseLine sopts copts line :=   readTsv (S.intercalate "\t" (fnC copts (fnS sopts (S.split "\t" line))))@@ -33,7 +24,7 @@           let (hs, ts') := splitAt (m - 1) xs               (mf, ts)  := uncons ts'            in fnS opts' (hs ++ S.concat ["\"", mf, "\""] :: ts)-        | [$m, $n] :: $opts' ->+        | [$m, $n & ?(> m)] :: $opts' ->           let (hs, ts') := splitAt (m - 1) xs               (ms, ts)  := splitAt (n - m + 1) ts'            in fnS opts' (hs ++ map (\m -> S.concat ["\"", m, "\""]) ms ++ ts)@@ -48,7 +39,7 @@           let (hs, ts') := splitAt (m - 1) xs               (mf, ts)  := uncons ts'            in fnC opts' (hs ++ S.concat ["[", mf, "]"] :: ts)-        | [$m, $n] :: $opts' ->+        | [$m, $n & ?(> m)] :: $opts' ->           let (hs, ts') := splitAt (m - 1) xs               (ms, ts)  := splitAt (n - m + 1) ts'            in fnC opts' (hs ++ S.concat ["[", S.intercalate ", " ms, "]"] :: ts)
lib/core/sort.egi view
@@ -15,17 +15,18 @@   | [$x] -> (1, x)   | [$x, $y] ->     if compare x y = Greater then (-1, y ++ x) else (1, x ++ y)-  | _ -> io $-    do let t := return (colToTensor xs)-       let n := return (length xs)-       let sgn := sort' 1 2 n t 1-       let xs' := return (map (\i -> io $ readIORef t_i) [1..n])-       return (sgn, concat xs')+  | _ ->+    io (do let t := return (colToTensor xs)+           let n := return (length xs)+           let sgn := sort' 1 2 n t 1+           let xs' := return (map (\i -> io $ readIORef t_i) [1..n])+           return (sgn, concat xs'))  where   colToTensor xs :=-    generateTensor (\n -> io $ do let t := newIORef ()-                                  writeIORef t (nth n xs)-                                  return t) [length xs]+    generateTensor (\[n] -> io $+      do let t := newIORef ()+         writeIORef t (nth n xs)+         return t) [length xs]    sort' i j n ts sgn :=     if i = n
lib/math/algebra/equations.egi view
@@ -23,7 +23,7 @@  def qF f x :=   match coefficients f x as list mathExpr with-    | $a_0 :: $a_1 :: $a_2 :: [] -> qF' a_2 a_1 a_0+    | [$a_0, $a_1, $a_2] -> qF' a_2 a_1 a_0  def qF' a b c :=   ( ((- b) + sqrt (b ^ 2 - 4 * a * c)) / 2 * a@@ -41,7 +41,7 @@ def cF' a b c d :=   match (a, b, c, d) as (mathExpr, mathExpr, mathExpr, mathExpr) with     | (#1, #0, $p, $q) ->-      let (s1, s2) := (\(x, y) -> (rt 3 x, rt 3 y)) (qF' 1 (27 * q) ((-27) * p ^ 3))+      let (s1, s2) := (2)#(rt 3 %1, rt 3 %2) (qF' 1 (27 * q) ((-27) * p ^ 3))        in ( (s1 + s2) / 3               -- r1           , (w ^ 2 * s1 + w * s2) / 3   -- r2           , (w * s1 + w ^ 2 * s2) / 3)  -- r3
lib/math/algebra/inverse.egi view
@@ -17,18 +17,18 @@         | _ -> inverse' t f x  -- TODO: define inverse'     | ?isTerm ->       match f as termExpr with-        | term #1 (ncons $n #x []) -> rt n t-        | term _ (ncons $n #x _) ->+        | term #1 ($n ^ #x :: []) -> rt n t+        | term _ ($n ^ #x :: _) ->           let a := f / x ^ n            in inverse (t / a) (f / a) x-        | _ -> `inverse t f x+        | _ -> 'inverse t f x     | ?isPolynomial ->       match coefficients x f as list mathExpr with         | $c :: (loop $i (1, $n)                    (#0 :: ...)                    ($a :: [])) -> inverse ((t - c) / a) (x ^ (n + 1)) x-        | _ -> `inverse t f x+        | _ -> 'inverse t f x     | _ ->       match f as mathExpr with         | $p1 / $p2 -> inverse (p2 * t) p1 x-    | _ -> `inverse t f x+    | _ -> 'inverse t f x
lib/math/algebra/matrix.egi view
@@ -13,9 +13,10 @@ def M.inverse %m :=   let d := M.det m    in generateTensor-        2#(match m as matrix with-          | cons #%2 #%1 _ $A $B $C $D ->-            if isEven (%1 + %2)+        (\[i, j] ->+          match m as matrix with+          | cons #j #i _ $A $B $C $D ->+            if isEven (i + j)               then M.det (M.join A B C D) / d               else - (M.det (M.join A B C D) / d))         (tensorShape m)@@ -63,11 +64,11 @@       n1 := max c1 d1       n2 := max b2 d2    in generateTensor-        2#(match (%1, %2) as (integer, integer) with-          | (?(<= a1), ?(<= a2)) -> A_%1_%2-          | (?(<= m1), _) -> B_%1_(%2 - a2)-          | (_, ?(<= m2)) -> C_(%1 - a1)_%2-          | (_, _) -> D_(%1 - m1)_(%2 - m2))+        (\match as list integer with+          | [$i & ?(<= a1), $j & ?(<= a2)] -> A_i_j+          | [$i & ?(<= m1), $j]            -> B_i_(j - a2)+          | [$i,            $j & ?(<= m2)] -> C_(i - a1)_j+          | [$i,            $j]            -> D_(i - m1)_(j - m2))         [m1 + n1, m2 + n2]  --@@ -140,15 +141,15 @@   match tensorShape x as list integer with     | [#2, #2] ->       let L := generateTensor-                 2#(match compare %1 %2 as ordering with+                 (\[i, j] -> match compare i j as ordering with                    | less -> 0                    | equal -> 1-                   | greater -> b_%1_%2)+                   | greater -> b_i_j)                  [2, 2]           U := generateTensor-                 2#(match compare %1 %2 as ordering with+                 (\[i, j] -> match compare i j as ordering with                    | greater -> 0-                   | _ -> c_%1_%2)+                   | _ -> c_i_j)                  [2, 2]           m := M.* L U           ret := solve@@ -159,15 +160,15 @@        in (substitute ret L, substitute ret U)     | [#3, #3] ->       let L := generateTensor-                 2#(match compare %1 %2 as ordering with+                 (\[i, j] -> match compare i j as ordering with                    | less -> 0                    | equal -> 1-                   | greater -> b_%1_%2)+                   | greater -> b_i_j)                  [3, 3]           U := generateTensor-                 2#(match compare %1 %2 as ordering with+                 (\[i, j] -> match compare i j as ordering with                    | greater -> 0-                   | _ -> c_%1_%2)+                   | _ -> c_i_j)                  [3, 3]           m := M.* L U           ret := solve@@ -188,5 +189,5 @@ -- def generateMatrixFromQuadraticExpr f xs :=   generateTensor-    2#(coefficient2 f (nth %1 xs) (nth %2 xs))+    (\[i, j] -> coefficient2 f (nth i xs) (nth j xs))     [length xs, length xs]
lib/math/algebra/root.egi view
@@ -44,7 +44,7 @@       let f xs :=             match xs as assocMultiset mathExpr with               | [] -> (1, 1)-              | ncons $p $k $rs ->+              | $p ^ $k :: $rs ->                 let (a, b) := f rs                  in (p ^' quotient k n *' a, p ^' (k % n) *' b)           g n x :=@@ -60,8 +60,8 @@  def rt'' n x :=   match (n, x) as (integer, integer) with-    | (#2, _) -> `sqrt x-    | (_, _) -> `rt n x+    | (#2, _) -> 'sqrt x+    | (_, _) -> 'rt n x  def sqrt x :=   if isScalar x@@ -79,5 +79,5 @@       | #2 -> -1       | #3 -> w       | #4 -> i-      | _ -> `rtu n-    else `rtu n+      | _ -> 'rtu n+    else 'rtu n
lib/math/algebra/tensor.egi view
@@ -13,8 +13,8 @@  def scalarToTensor x ns := x * unitTensor ns -def zeroTensor ns := generateTensor (\xs -> 0) ns+def zeroTensor ns := generateTensor (\_ -> 0) ns -def (.') %t1 %t2 := sum' (contract (t1 *' t2))+def (.') %t1 %t2 := foldr (+') 0 (contract (t1 *' t2)) -def (.) %t1 %t2 := sum (contract (t1 * t2))+def (.) %t1 %t2 := foldr (+) 0 (contract (t1 * t2))
lib/math/analysis/derivative.egi view
@@ -10,25 +10,25 @@     | #x -> 1     | ?isSymbol -> 0     -- function expression-    | func _ $argnames $args _ ->+    | func _ $argnames $args ->       sum (map2 (\s r -> (userRefs f [s]) * ∂/∂ r x) argnames args)     -- function application-    | #`exp $g -> exp g * ∂/∂ g x-    | #`log $g -> 1 / g * ∂/∂ g x-    | #`sqrt $g -> 1 / (2 * sqrt g) * ∂/∂ g x-    | #`(^) $g $h -> f * ∂/∂ (log g * h) x-    | #`cos $g -> (- sin g) * ∂/∂ g x-    | #`sin $g -> cos g * ∂/∂ g x-    | #`arccos $g -> 1 / sqrt (1 - g ^ 2) * ∂/∂ g x+    | #'exp $g -> exp g * ∂/∂ g x+    | #'log $g -> 1 / g * ∂/∂ g x+    | #'sqrt $g -> 1 / (2 * sqrt g) * ∂/∂ g x+    | #'(^) $g $h -> f * ∂/∂ (log g * h) x+    | #'cos $g -> (- sin g) * ∂/∂ g x+    | #'sin $g -> cos g * ∂/∂ g x+    | #'arccos $g -> 1 / sqrt (1 - g ^ 2) * ∂/∂ g x     | apply $g $args ->-      sum (map2 2#((capply `(userRefs g [%1]) args) * ∂/∂ %2 x) nats args)+      sum (map2 (\nat arg -> (capply '(userRefs g [nat]) args) * ∂/∂ arg x) nats args)     -- quote     | quote $g ->       let g' := ∂/∂ g x        in if isMonomial g'             then g'             else let d := capply gcd (fromPoly g')-                  in d *' '(mapPoly (/' d) g')+                  in d *' `(mapPoly (/' d) g')     -- term (constant)     | #0 -> 0     | _ * #1 -> 0@@ -55,11 +55,11 @@  def taylorExpansion $f $x $a := multivariateTaylorExpansion f [|x|] [|a|] -def maclaurinExpansion := 2#(taylorExpansion %1 %2 0)+def maclaurinExpansion f x := taylorExpansion f x 0  def multivariateTaylorExpansion $f %xs %ys :=   withSymbols [h]-    let hs := generateTensor 1#h_%1 (tensorShape xs)+    let hs := generateTensor (\[x] -> h_x) (tensorShape xs)      in map2           (*)           (map 1#(1 / fact %1) nats0)
lib/math/analysis/integral.egi view
@@ -17,20 +17,20 @@     | #(^) $a #x -> a ^ x / log a     | #(^) $a $y ->       withSymbols [t] substitute [(t, y)] (Sd t (a ^ t * d/d (inverse t y x) t))-    | #Sd $y $g -> `Sd x (`Sd y g)+    | #Sd $y $g -> 'Sd x ('Sd y g)     | $f $y ->       withSymbols [t] substitute [(t, y)] (Sd t (f t * d/d (inverse t y x) t))     -- term (constant)     | #0 -> 0     | term $c [] -> c * x     -- term (multiplication)-    | mult $a (ncons $n #x $r) ->-      if containSymbol x r then `Sd x f else a / (n + 1) * x ^ (n + 1) * r+    | mult $a ($n ^ #x :: $r) ->+      if containSymbol x r then 'Sd x f else a / (n + 1) * x ^ (n + 1) * r     -- polynomial     | poly $ts -> sum (map 1#(Sd x %1) ts)     -- quotient     | plus $ts / $p2 -> sum (map 1#(Sd x (%1 / p2)) ts)-    | $p1 / $p2 -> if containSymbol x p2 then `Sd x f else Sd x p1 / p2+    | $p1 / $p2 -> if containSymbol x p2 then 'Sd x f else Sd x p1 / p2  def multSd x f g :=   let F := Sd x f
lib/math/common/arithmetic.egi view
@@ -65,25 +65,25 @@     then exp n     else if isRational n       then if n >= 0-        then if isInteger n then power x n else `(^) x n+        then if isInteger n then power x n else '(^) x n         else 1 / x ^ neg n-      else `(^) x n+      else '(^) x n  def (^') $x $n :=   if x = e     then exp n     else if isRational n       then if n >= 0-        then if isInteger n then power' x n else `(^) x n+        then if isInteger n then power' x n else '(^) x n         else 1 /' x ^' neg n-      else `(^) x n+      else '(^) x n  def gcd $x $y :=   match (x, y) as (termExpr, termExpr) with     | (_, #0) -> x     | (#0, _) -> y     | (term $a $xs, term $b $ys) ->-      gcd' (abs a) (abs b) *' foldl (*') 1 (map (^') (AC.intersect xs ys))+      gcd' (abs a) (abs b) *' foldl (*') 1 (map (\(s, n) -> s ^' n) (AC.intersect xs ys))  def gcd' $x $y :=   match (x, y) as (integer, integer) with@@ -96,5 +96,5 @@   let xs := reverse (coefficients fx x)       ys := reverse (coefficients gx x)       (zs, rs) := L./ xs ys-   in ( sum' (map2 2#(%1 *' x ^' %2) (reverse zs) nats0)-      , sum' (map2 2#(%1 *' x ^' %2) (reverse rs) nats0) )+   in ( sum' (map2 (\c n -> c *' x ^' n) (reverse zs) nats0)+      , sum' (map2 (\c n -> c *' x ^' n) (reverse rs) nats0) )
lib/math/common/functions.egi view
@@ -14,8 +14,8 @@         | #0 -> 1         | #1 -> e         | mult $a #(i * π) -> (-1) ^ a-        | _ -> `exp x-      else `exp x+        | _ -> 'exp x+      else 'exp x  def log $x :=   if isFloat x@@ -23,7 +23,7 @@     else match x as mathExpr with       | #1 -> 0       | #e -> 1-      | _ -> `log x+      | _ -> 'log x  def cos $x :=   if isFloat x@@ -32,7 +32,7 @@       | #0 -> 1       | term $n [#π] -> (-1) ^ abs n       | (mult _ #π) / #2 -> 0-      | _ -> `cos x+      | _ -> 'cos x  def sin $x :=   if isFloat x@@ -41,14 +41,14 @@       | #0 -> 0       | mult _ #π -> 0       | (mult $n #π) / #2 -> (-1) ^ ((abs n - 1) / 2)-      | _ -> `sin x+      | _ -> 'sin x  def tan $x :=   if isFloat x     then b.tan x     else match x as mathExpr with       | #0 -> 0-      | _ -> `tan x+      | _ -> 'tan x  def acos := b.acos def asin := b.asin@@ -59,21 +59,21 @@     then b.cosh x     else match x as mathExpr with       | #0 -> 1-      | _ -> `cosh x+      | _ -> 'cosh x  def sinh $x :=   if isFloat x     then b.sinh x     else match x as mathExpr with       | #0 -> 0-      | _ -> `sinh x+      | _ -> 'sinh x  def tanh $x :=   if isFloat x     then b.tanh x     else match x as mathExpr with       | #0 -> 0-      | _ -> `tanh x+      | _ -> 'tanh x  def acosh := b.acosh def asinh := b.asinh@@ -88,7 +88,7 @@  def sigmoid $z := 1 / (1 + exp (- z)) -def kroneckerDelta := cambda js -> if all (= head js) (tail js) then 1 else 0+def kroneckerDelta js := if all (= head js) (tail js) then 1 else 0  def eulerTotientFunction $n := n * product (map (\p -> 1 - 1 / p) (unique (pF n))) @@ -96,17 +96,15 @@   memoizedLambda n ->     let (es, os) := evenAndOddPermutations' n      in generateTensor-          (cambda is ->-            if member is es then 1 else if member is os then -1 else 0)+          (\is -> if member is es then 1 else if member is os then -1 else 0)           (take n (repeat1 n))  def ε' :=   memoizedLambda n k ->     let (es, os) := evenAndOddPermutations' n      in generateTensor-          (cambda is ->+          (\is ->             match drop k is as list integer with               | _ ++ $x :: _ ++ ?(< x) :: _ -> 0-              | _ ->-                if member is es then 1 else if member is os then -1 else 0)+              | _ -> if member is es then 1 else if member is os then -1 else 0)           (take n (repeat1 n))
lib/math/expression.egi view
@@ -18,6 +18,9 @@  def mathExpr' :=   matcher+    | div $ $ as (mathExpr, mathExpr) with+      | Div $p1 $p2 -> [(toMathExpr' p1, toMathExpr' p2)]+      | _ -> []     | $ / $ as (mathExpr, mathExpr) with       | Div $p1 $p2 -> [(toMathExpr' p1, toMathExpr' p2)]       | _ -> []@@ -57,10 +60,10 @@       | Div (Plus [Term 1 [(Quote $mexpr, 1)]]) (Plus [Term 1 []]) ->         [toMathExpr' mexpr]       | _ -> []-    | func $ $ $ $ as-        (mathExpr, list mathExpr, list mathExpr, list indexExpr) with+    | func $ $ $ as+        (mathExpr, list mathExpr, list mathExpr) with       | Div-          (Plus [Term 1 [(Function $name $argnames $args $js, 1)]])+          (Plus [Term 1 [(Function $name $argnames $args, 1)]])           (Plus [Term 1 []]) ->         [(name, argnames, args, js)]       | _ -> []@@ -89,15 +92,15 @@     | $ ^ #$k * $ as (mathExpr, multExpr) with       | $tgt ->         matchAll tgt as mathExpr with-          | term _ (ncons $x #k $xs) -> (x, product' (map (uncurry (^')) xs))+          | term _ ($x ^ #k :: $xs) -> (x, product' (map (uncurry (^')) xs))     | $ ^ $ * $ as (mathExpr, integer, multExpr) with       | $tgt ->         matchAll tgt as mathExpr with-          | term _ (ncons $x $n $xs) -> (x, n, product' (map (uncurry (^')) xs))+          | term _ ($x ^ $n :: $xs) -> (x, n, product' (map (uncurry (^')) xs))     | $ ^ $ as (mathExpr, integer) with       | $tgt ->         match tgt as mathExpr with-          | term _ (ncons $x $n []) -> [(x, n)]+          | term _ ($x ^ $n :: []) -> [(x, n)]           | _ -> []     | $ * $ as (mathExpr, multExpr) with       | $tgt ->@@ -260,7 +263,7 @@ def coefficients $f $x :=   let m := maximum              (0 :: (matchAll f as mathExpr with-               | poly (term $a (ncons #x $k $ts) :: _) / _ -> k))+               | poly (term $a (#x ^ $k :: $ts) :: _) / _ -> k))    in map (coefficient f x) (between 0 m)  def coefficient $f $x $m :=@@ -274,7 +277,7 @@ def coefficient' $f $x $m :=   sum     (matchAll f as mathExpr with-      | poly (term $a (ncons #x #m (!(#x :: _) & $ts)) :: _) / _ ->+      | poly (term $a (#x ^ #m :: (!(#x :: _) & $ts)) :: _) / _ ->         foldl (*') a (map (uncurry (^')) ts)) / denominator f  def coefficient2 $f $x $y :=
lib/math/geometry/3d-euclidean-space.egi view
@@ -2,7 +2,7 @@  def metric :=   generateTensor-    (\match as (integer, integer) with-      | ($n, #n) -> 1-      | (_, _) -> 0)+    (\match as list integer with+      | [$n, #n] -> 1+      | _        -> 0)     [3, 3]
lib/math/geometry/4d-euclidean-space.egi view
@@ -2,7 +2,7 @@  def metric :=   generateTensor-    (\match as (integer, integer) with-      | ($n, #n) -> 1-      | (_, _) -> 0)+    (\match as list integer with+      | [$n, #n] -> 1+      | _        -> 0)     [4, 4]
lib/math/geometry/differential-form.egi view
@@ -10,6 +10,10 @@  def wedge %X %Y := X !. Y +infixl expression 7 ∧++def (∧) := wedge+ def Lie.wedge %X %Y := X !. Y - Y !. X  def ι %X %Y := withSymbols [i] dfOrder Y * (X...~i . dfNormalize Y..._i)
lib/math/geometry/minkowski-space.egi view
@@ -2,8 +2,8 @@  def metric :=   generateTensor-    (\match as (integer, integer) with-      | (#1, #1) -> -1-      | ($n, #n) -> 1-      | (_, _) -> 0)+    (\match as list integer with+      | [#1, #1] -> -1+      | [$n, #n] -> 1+      | _        -> 0)     [4, 4]
lib/math/normalize.egi view
@@ -7,7 +7,7 @@ def mathNormalize $x :=   if isInteger x     then x-    else if containFunction `rtu x+    else if containFunction 'rtu x           then rewriteRuleForRtu (symbolNormalize x)           else symbolNormalize x
sample/math/geometry/riemann-curvature-tensor-of-S2.egi view
@@ -9,7 +9,7 @@ def e_i_j := ∂/∂ X_j x~i  -- Metric tensors-def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2]+def g_i_j := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [2, 2] def g~i~j := M.inverse g_#_#  assertEqual "Metric tensor"
sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi view
@@ -12,7 +12,7 @@ def e_i_j := ∂/∂ X_j x~i  -- Metric tensors-def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [5, 5]+def g_i_j := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [5, 5] def g~i~j := M.inverse g_#_#  -- Christoffel symbols
sample/math/geometry/riemann-curvature-tensor-of-S5.egi view
@@ -12,7 +12,7 @@ def e_i_j := ∂/∂ X_j x~i  -- Metric tensors-def g{_i_j} := generateTensor (\x y -> V.* e_x_# e_y_#) [5, 5]+def g{_i_j} := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [5, 5] def g{~i~j} := M.inverse g_#_#  -- Christoffel symbols
sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi view
@@ -1,43 +1,43 @@ -- Parameters def x := [| θ, φ |] -def X := [| '(a * cos θ + b) * cos φ -- x-          , '(a * cos θ + b) * sin φ -- y+def X := [| `(a * cos θ + b) * cos φ -- x+          , `(a * cos θ + b) * sin φ -- y           , a * sin θ                -- z           |]  def e_i_j := ∂/∂ X_j x~i  -- Metric tensors-def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2]+def g_i_j := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [2, 2] def g~i~j := M.inverse g_#_#  assertEqual "Metric tensor"   g_#_#-  [| [| a^2, 0 |], [| 0, '(a * cos θ + b)^2 |] |]_#_#+  [| [| a^2, 0 |], [| 0, `(a * cos θ + b)^2 |] |]_#_# assertEqual "Metric tensor"   g~#~#-  [| [| 1 / a^2, 0 |], [| 0, 1 / '(a * cos θ + b)^2 |] |]~#~#+  [| [| 1 / a^2, 0 |], [| 0, 1 / `(a * cos θ + b)^2 |] |]~#~#  -- Christoffel symbols def Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i)  assertEqual "Christoffel symbols of the first kind"   Γ_1_#_#-  [| [| 0, 0 |], [| 0, '(a * cos θ + b) * a * sin θ |] |]_#_#+  [| [| 0, 0 |], [| 0, `(a * cos θ + b) * a * sin θ |] |]_#_# assertEqual "Christoffel symbols of the first kind"   Γ_2_#_#-  [| [| 0, -1 * '(a * cos θ + b) * a * sin θ |], [| -1 * '(a * cos θ + b) * a * sin θ, 0 |] |]_#_#+  [| [| 0, -1 * `(a * cos θ + b) * a * sin θ |], [| -1 * `(a * cos θ + b) * a * sin θ, 0 |] |]_#_#  def Γ~i_j_k := withSymbols [m]   g~i~m . Γ_m_j_k  assertEqual "Christoffel symbols of the second kind"   Γ~1_#_#-  [| [| 0, 0 |], [| 0, '(a * cos θ + b) * sin θ / a |] |]_#_#+  [| [| 0, 0 |], [| 0, `(a * cos θ + b) * sin θ / a |] |]_#_# assertEqual "Christoffel symbols of the second kind"   Γ~2_#_#-  [| [| 0, -1 * a * sin θ / '(a * cos θ + b) |], [| -1 * a * sin θ / '(a * cos θ + b), 0 |] |]_#_#+  [| [| 0, -1 * a * sin θ / `(a * cos θ + b) |], [| -1 * a * sin θ / `(a * cos θ + b), 0 |] |]_#_#  -- Riemann curvature def R~i_j_k_l := withSymbols [m]@@ -48,10 +48,10 @@   [| [| 0, 0 |], [| 0, 0 |] |]~#_# assertEqual "riemann curvature"   R~#_#_1_2-  [| [| 0, '(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / '(a * cos θ + b), 0 |] |]~#_#+  [| [| 0, `(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature"   R~#_#_2_1-  [| [| 0, -1 * '(a * cos θ + b) * cos θ / a |], [| a * cos θ / '(a * cos θ + b), 0 |] |]~#_#+  [| [| 0, -1 * `(a * cos θ + b) * cos θ / a |], [| a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature"   R~#_#_2_2   [| [| 0, 0 |], [| 0, 0 |] |]~#_#@@ -64,10 +64,10 @@   [| [| 0, 0 |], [| 0, 0 |] |]_#_# assertEqual "riemann curvature"   R_#_#_1_2-  [| [| 0, a * '(a * cos θ + b) * cos θ |], [| - '(a * cos θ + b) * a * cos θ, 0 |] |]_#_#+  [| [| 0, a * `(a * cos θ + b) * cos θ |], [| - `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature"   R_#_#_2_1-  [| [| 0, - a * '(a * cos θ + b) * cos θ |], [| '(a * cos θ + b) * a * cos θ, 0 |] |]_#_#+  [| [| 0, - a * `(a * cos θ + b) * cos θ |], [| `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature"   R_#_#_2_2   [| [| 0, 0 |], [| 0, 0 |] |]_#_#@@ -82,4 +82,4 @@  assertEqual "scalar curvature"   scalarCurvature-  (2 * cos θ / (a * '(a * cos θ + b)))+  (2 * cos θ / (a * `(a * cos θ + b)))
sample/math/geometry/riemann-curvature-tensor-of-T2.egi view
@@ -1,43 +1,43 @@ -- Parameters def x := [| θ, φ |] -def X := [| '(a * cos θ + b) * cos φ -- x-          , '(a * cos θ + b) * sin φ -- y+def X := [| `(a * cos θ + b) * cos φ -- x+          , `(a * cos θ + b) * sin φ -- y           , a * sin θ                -- z           |]  def e_i_j := ∂/∂ X_j x~i  -- Metric tensors-def g{_i_j} := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2]+def g{_i_j} := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [2, 2] def g{~i~j} := M.inverse g_#_#  assertEqual "Metric tensor"   g_#_#-  [| [| a^2, 0 |], [| 0, '(a * cos θ + b)^2 |] |]_#_#+  [| [| a^2, 0 |], [| 0, `(a * cos θ + b)^2 |] |]_#_# assertEqual "Metric tensor"   g~#~#-  [| [| 1 / a^2, 0 |], [| 0, 1 / '(a * cos θ + b)^2 |] |]~#~#+  [| [| 1 / a^2, 0 |], [| 0, 1 / `(a * cos θ + b)^2 |] |]~#~#  -- Christoffel symbols def Γ_i{_j_k} := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i)  assertEqual "Christoffel symbols of the first kind"   Γ_1_#_#-  [| [| 0, 0 |], [| 0, '(a * cos θ + b) * a * sin θ |] |]_#_#+  [| [| 0, 0 |], [| 0, `(a * cos θ + b) * a * sin θ |] |]_#_# assertEqual "Christoffel symbols of the first kind"   Γ_2_#_#-  [| [| 0, -1 * '(a * cos θ + b) * a * sin θ |], [| -1 * '(a * cos θ + b) * a * sin θ, 0 |] |]_#_#+  [| [| 0, -1 * `(a * cos θ + b) * a * sin θ |], [| -1 * `(a * cos θ + b) * a * sin θ, 0 |] |]_#_#  def Γ~i{_j_k} := withSymbols [m]   g~i~m . Γ_m_j_k  assertEqual "Christoffel symbols of the second kind"   Γ~1_#_#-  [| [| 0, 0 |], [| 0, '(a * cos θ + b) * sin θ / a |] |]_#_#+  [| [| 0, 0 |], [| 0, `(a * cos θ + b) * sin θ / a |] |]_#_# assertEqual "Christoffel symbols of the second kind"   Γ~2_#_#-  [| [| 0, -1 * a * sin θ / '(a * cos θ + b) |], [| -1 * a * sin θ / '(a * cos θ + b), 0 |] |]_#_#+  [| [| 0, -1 * a * sin θ / `(a * cos θ + b) |], [| -1 * a * sin θ / `(a * cos θ + b), 0 |] |]_#_#  -- Riemann curvature def R~i_j_k_l := withSymbols [m]@@ -48,10 +48,10 @@   [| [| 0, 0 |], [| 0, 0 |] |]~#_# assertEqual "riemann curvature"   R~#_#_1_2-  [| [| 0, '(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / '(a * cos θ + b), 0 |] |]~#_#+  [| [| 0, `(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature"   R~#_#_2_1-  [| [| 0, -1 * '(a * cos θ + b) * cos θ / a |], [| a * cos θ / '(a * cos θ + b), 0 |] |]~#_#+  [| [| 0, -1 * `(a * cos θ + b) * cos θ / a |], [| a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature"   R~#_#_2_2   [| [| 0, 0 |], [| 0, 0 |] |]~#_#@@ -64,10 +64,10 @@   [| [| 0, 0 |], [| 0, 0 |] |]_#_# assertEqual "riemann curvature"   R_#_#_1_2-  [| [| 0, a * '(a * cos θ + b) * cos θ |], [| - '(a * cos θ + b) * a * cos θ, 0 |] |]_#_#+  [| [| 0, a * `(a * cos θ + b) * cos θ |], [| - `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature"   R_#_#_2_1-  [| [| 0, - a * '(a * cos θ + b) * cos θ |], [| '(a * cos θ + b) * a * cos θ, 0 |] |]_#_#+  [| [| 0, - a * `(a * cos θ + b) * cos θ |], [| `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature"   R_#_#_2_2   [| [| 0, 0 |], [| 0, 0 |] |]_#_#@@ -82,4 +82,4 @@  assertEqual "scalar curvature"   scalarCurvature-  (2 * cos θ / (a * '(a * cos θ + b)))+  (2 * cos θ / (a * `(a * cos θ + b)))
sample/math/geometry/thurston-non-sym.egi view
@@ -8,15 +8,15 @@   [|[| 1, 0, 0, 0 |],     [| 0, 1, 0, 0 |],     [| 0, 0, κ / (sqrt β), (-1 * θ₂ * κ) / (sqrt β)  |],-    [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), ('(1 + θ₂) * κ) / (sqrt β) |]|]+    [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), (`(1 + θ₂) * κ) / (sqrt β) |]|]  def g~i~j :=   [|[| 1, 0, 0, 0 |],     [| 0, 1, 0, 0 |],-    [| 0, 0, '(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |],+    [| 0, 0, `(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |],     [| 0, 0, θ₂ / ((sqrt β) * κ), 1 / ((sqrt β) * κ) |]|] -def β := '(1 + θ₂ - θ₂^2)+def β := `(1 + θ₂ - θ₂^2)  def Γ~c_a_b := withSymbols [e]   (1 / 2) * g~c~e . (∂/∂ g_b_e x~a + ∂/∂ g_a_e x~b - ∂/∂ g_a_b x~e)@@ -52,25 +52,25 @@  def δ :=   generateTensor-    (\x y -> match (x, y) as (integer, integer) with-       | ($n, #n) -> 1-       | (_, _) -> 0)+    (\match as list integer with+       | [$n, #n] -> 1+       | _        -> 0)     [5, 5]  def R'_i_j_k~l :=   generateTensor-    (\x y z w -> match (x, y, z, w) as (integer, integer, integer, integer) with-       | (#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)-       | (#1, $b, $c, #1) ->      p^2 * g_(b - 1)_(c - 1)-       | ($a, #1, $c, #1) -> -1 * p^2 * g_(a - 1)_(c - 1)-       | (#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)-       | ($a, $b, #1, $d) -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1)-       | ($a, $b, $c, #1) ->      p * ∇J_(c - 1)_(a - 1)_(b - 1)-       | ($a, $b, $c, $d) -> R_(a - 1)_(b - 1)_(c - 1)~(d - 1)+    (\match as list integer with+       | [#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)+       | [#1, $b, $c, #1] ->      p^2 * g_(b - 1)_(c - 1)+       | [$a, #1, $c, #1] -> -1 * p^2 * g_(a - 1)_(c - 1)+       | [#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)+       | [$a, $b, #1, $d] -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1)+       | [$a, $b, $c, #1] ->      p * ∇J_(c - 1)_(a - 1)_(b - 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))
sample/math/geometry/thurston.egi view
@@ -8,15 +8,15 @@   [|[| 1, 0, 0, 0 |],     [| 0, 1, 0, 0 |],     [| 0, 0, κ / (sqrt β), (-1 * θ₂ * κ) / (sqrt β)  |],-    [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), ('(1 + θ₂) * κ) / (sqrt β) |]|]+    [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), (`(1 + θ₂) * κ) / (sqrt β) |]|]  def g~i~j :=   [|[| 1, 0, 0, 0 |],     [| 0, 1, 0, 0 |],-    [| 0, 0, '(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |],+    [| 0, 0, `(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |],     [| 0, 0, θ₂ / ((sqrt β) * κ), 1 / ((sqrt β) * κ) |]|] -def β := '(1 + θ₂ - θ₂^2)+def β := `(1 + θ₂ - θ₂^2)  def Γ~c_a_b := withSymbols [e]   (1 / 2) * g~c~e . (∂/∂ g_b_e x~a + ∂/∂ g_a_e x~b - ∂/∂ g_a_b x~e)@@ -34,9 +34,13 @@  def J_a~c := J_a_b . g~b~c +def ∇_c T~(a_1)...~(a_r)_(b_1)..._(b_k) :=+  ∂/∂ T~(a_1)...~(a_r)_(b_1)..._(b_k) x~c+  + sum (map (\i -> Γ~(a_i)_d_c . T~(a_1)...~(a_(i-1))~d~(a_(i+1))...~(a_r)_(b_1)..._(b_k)) [1..r])+  - sum (map (\i -> Γ~d_(b_i)_c . T~(a_1)...~(a_r)_(b_1)..._(b_(i-1))_d_(b_(i+1))..._(b_k)) [1..k])+ def ∇J_m_a_b :=-  withSymbols [n]-    ∂/∂ J_a_b x~m + Γ~n_m_a . J_n_b + Γ~n_m_b . J_a_n+    ∇_m J_a_b -- ∂/∂ J_a_b x~m - Γ~n_m_a . J_n_b - Γ~n_m_b . J_a_n  def ∇J~m_a_b :=   withSymbols [t]@@ -52,25 +56,25 @@  def δ :=   generateTensor-    (\x y -> match (x, y) as (integer, integer) with-       | ($n, #n) -> 1-       | (_, _) -> 0)+    (\match as list integer with+       | [$n, #n] -> 1+       | [_, _] -> 0)     [5, 5]  def R'[_i_j]_k~l :=   generateTensor-    (\x y z w -> match (x, y, z, w) as (integer, integer, integer, integer) with-       | (#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)-       | (#1, $b, $c, #1) ->      p^2 * g_(b - 1)_(c - 1)-       | ($a, #1, $c, #1) -> -1 * p^2 * g_(a - 1)_(c - 1)-       | (#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)-       | ($a, $b, #1, $d) -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1)-       | ($a, $b, $c, #1) ->      p * ∇J_(c - 1)_(a - 1)_(b - 1)-       | ($a, $b, $c, $d) -> R_(a - 1)_(b - 1)_(c - 1)~(d - 1)+    (\match as list integer with+       | [#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)+       | [#1, $b, $c, #1] ->      p^2 * g_(b - 1)_(c - 1)+       | [$a, #1, $c, #1] -> -1 * p^2 * g_(a - 1)_(c - 1)+       | [#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)+       | [$a, $b, #1, $d] -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1)+       | [$a, $b, $c, #1] ->      p * ∇J_(c - 1)_(a - 1)_(b - 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))
+ sample/math/number/5th-root-of-unity.egi view
@@ -0,0 +1,53 @@+--+-- This file has been auto-generated by egison-translator.+--++def z := rtu 5++def a11 := z ^ 1 + z ^ 4++def a12 := z ^ 2 + z ^ 3++def b10 := a11 + a12++def b11 := a11 - a12++def b12 := a12 - a11++assertEqual "b10" b10 (-1)++def b10' := b10++def b11' := sqrt (b11 ^ 2)++def a11' := (b10' + b11') / 2++def a12' := (b10' - b11') / 2++def a21 := z ^ 1 - z ^ 4++def a22 := z ^ 2 - z ^ 3++def b20 := a21 + a22++def b21 := a21 - a22++def b22 := a22 - a21++def b20' := sqrt ((-3) + 4 * a12')++def b21' := sqrt ((-3) + 4 * a11')++def a21' := (b20' + b21') / 2++def a22' := (b20' - b21') / 2++def z1' := (a11' + a21') / 2++assertEqual+  "5th-root-of-unity"+   z1'+  ((-1 + sqrt 5 + sqrt (-5 - 2 * sqrt 5) + sqrt (-5 + 2 * sqrt 5)) / 4)+++z1'^5
+ sample/math/number/7th-root-of-unity.egi view
@@ -0,0 +1,51 @@+--+-- This file has been auto-generated by egison-translator.+--++def z := rtu 7++def a11 := z ^ 1 + z ^ 6++def a12 := z ^ 2 + z ^ 5++def a13 := z ^ 3 + z ^ 4++def b10 := a11 + a12 + a13++def b10' := b10++b10'++def b11 := a11 + w * a12 + w ^ 2 * a13++def b12 := a13 + w * a11 + w ^ 2 * a12++def b13 := a12 + w * a13 + w ^ 2 * a11++def b11' := rt 3 (b11 * b12 * b13)++b11'++def b14 := a11 + w * a13 + w ^ 2 * a12++def b15 := a12 + w * a11 + w ^ 2 * a13++def b16 := a13 + w * a12 + w ^ 2 * a11++def b14' := rt 3 (b14 * b15 * b16)++b14'++def a11' := (b10' + b11' + b14') / 3++a11'++def z1' := fst (qF' 1 (- a11') 1)++z1'++--((-1) + rt 3 (14 + 21 * w) + rt 3 ((-7) + (-21) * w) ++--sqrt+--  ((-35) + (-2) * rt 3 (14 + 21 * w) + (-2) * rt 3 ((-7) + (-21) * w) ++--  rt 3 (14 + 21 * w) ^ 2 + rt 3 ((-7) + (-21) * w) ^ 2 ++--  2 * rt 3 (14 + 21 * w) * rt 3 ((-7) + (-21) * w))) / 6
sample/math/number/tribonacci.egi view
@@ -2,10 +2,10 @@  def A :=   generateTensor-    (\x y -> match (x, y) as (integer, integer) with-      | (#1, _) -> 1-      | ($x, #(x - 1)) -> 1-      | (_, _) -> 0)+    (\match as list integer with+      | [#1, _] -> 1+      | [$x, #(x - 1)] -> 1+      | _ -> 0)     [m, m]  A@@ -13,7 +13,7 @@  def B :=   generateTensor-    (\x -> if x = 1 then 1 else 0)+    (\[x] -> if x = 1 then 1 else 0)     [m]  B
sample/sat/dp.egi view
@@ -1,7 +1,3 @@------ This file has been auto-generated by egison-translator.---- def deleteLiteral l cnf :=   map     (\c -> matchAll c as multiset integer with@@ -22,7 +18,9 @@  def dp vars cnf :=   match (vars, cnf) as (multiset integer, multiset (multiset integer)) with+  -- satisfiable   | (_, []) -> True+  -- unsatisfiable   | (_, [] :: _) -> False   -- 1-literal rule   | (_, [$l] :: _) -> dp (delete (abs l) vars) (assignTrue l cnf)@@ -35,11 +33,12 @@     dp vs        ((resolveOn v cnf) ++ (deleteClausesWith v (deleteClausesWith (neg v) cnf))) -dp [1] [[1]]-dp [1] [[1], [-1]]-dp [1, 2, 3] [[1, 2], [-1, 3], [1, -3]]-dp [1, 2] [[1, 2], [-1, -2], [1, -2]]-dp [1, 2] [[1, 2], [-1, -2], [1, -2], [-1, 2]]-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]]-dp [1, 2] [[-1, -2], [1]]+assert "dp" (dp [1] [[1]])+assert "dp" (not (dp [1] [[1], [-1]]))+assert "dp" (dp [1, 2, 3] [[1, 2], [-1, 3], [1, -3]])+assert "dp" (dp [1, 2] [[1, 2], [-1, -2], [1, -2]])+assert "dp" (not (dp [1, 2] [[1, 2], [-1, -2], [1, -2], [-1, 2]]))+assert "dp" (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]])+assert "dp" (dp [1, 2] [[-1, -2], [1]])
+ test/CLITest.hs view
@@ -0,0 +1,88 @@+module Main (main) where++import           Data.Version                   (showVersion)+import           System.Process                 (readProcess)++import           Test.Framework                 (defaultMain)+import           Test.Framework.Providers.HUnit (hUnitTestToTests)+import           Test.HUnit++import           Language.Egison                (version)++main :: IO ()+main = defaultMain . hUnitTestToTests . test $ TestList+    [ TestLabel "load-file option" . TestCase $ assertEgisonCmd+        (interpreter "1\n")+        ["--load-file", "test/fixture/a.egi"]+        "x"+    , TestLabel "test option" . TestCase $ assertEgisonCmd+        "3\n\"This is the third line\"\n"+        ["--test", "test/fixture/b.egi"]+        ""+    , TestLabel "eval option" . TestCase $ assertEgisonCmd+        "[[], [1], [1, 2], [1, 2, 3]]\n"+        ["--eval", "matchAll [1,2,3] as list something with $x ++ _ -> x"]+        ""+    , TestLabel "command option" . TestCase $ assertEgisonCmd+        "1\n"+        ["--command", "print (show 1)"]+        ""+    , TestLabel "TSV option" . TestCase $ assertEgisonCmd+        "2\n3\n5\n7\n11\n13\n17\n19\n23\n29\n"+        ["-T", "-e", "take 10 primes"]+        ""+    , TestLabel "TSV option with tab" . TestCase $ assertEgisonCmd+        "1\t2\t3\n4\t5\n"+        ["-T", "-e", "[[1, 2, 3], [4, 5]]"]+        ""+    , TestLabel "substitute option" . TestCase $ assertEgisonCmd+        "10\n11\n12\n13\n14\n15\n"+        ["--substitute", "\\matchAll as list integer with _ ++ $x :: _ ++ #(x + 5) :: _ -> x"]+        "10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20"+    , TestLabel "map option" . TestCase $ assertEgisonCmd+        "3\n4\n5\n6\n7\n"+        ["--map", "\\x -> x + 2"]+        "1\n2\n3\n4\n5"+    , TestLabel "filter option" . TestCase $ assertEgisonCmd+        "2\n3\n5\n7\n"+        ["--filter", "isPrime"]+        "1\n2\n3\n4\n5\n6\n7\n8\n9\n10"+    , TestLabel "field option" . TestCase $ assertEgisonCmd+        "(10, [2, 5])\n(11, [11])\n(12, [2, 2, 3])\n(13, [13])\n(14, [2, 7])\n(15, [3, 5])\n"+        ["--field", "2c", "-m", "\\x -> x"]+        "10\t2\t5\n11\t11\n12\t2\t2\t3\n13\t13\n14\t2\t7\n15\t3\t5"+    , TestLabel "math option" . TestCase $ assertEgisonCmd+        (interpreter "#latex|\\frac{x}{y}|#\n")+        ["--math", "latex"]+        "x / y"+    , TestLabel "sexpr option" . TestCase $ assertEgisonCmd+        (interpreter "3\n")+        ["--sexpr-syntax"]+        "(+ 1 2)"+    , TestLabel "execute main function" . TestCase $ assertEgisonCmd+        "[\"a\", \"b\", \"c\"]\n"+        ["test/fixture/c.egi", "a", "b", "c"]+        ""+    , TestLabel "io function" . TestCase $ assertEgisonCmd+        "display write print\n3\n1 + 2 = 3\n"+        ["test/lib/core/io.egi"]+        ""+    ]++assertEgisonCmd+  :: String   -- The expected value+  -> [String] -- any arguments for egison command+  -> String   -- standard input for egison command+  -> Assertion+assertEgisonCmd expected args input = do+  actual <- readProcess "stack" ("exec" : "--" : "egison" : args) input+  assertEqual "" expected actual++interpreter :: String -> String+interpreter output = concat+  [ "Egison Version ", showVersion version, "\n"+  , "https://www.egison.org\n"+  , "Welcome to Egison Interpreter!\n"+  , "> ", output+  , "> Leaving Egison Interpreter.\n"+  ]
− test/OptionsTest.hs 
@@ -1,84 +0,0 @@-module Main (main) where--import           Data.Version                   (showVersion)-import           System.Process                 (readProcess)--import           Test.Framework                 (defaultMain)-import           Test.Framework.Providers.HUnit (hUnitTestToTests)-import           Test.HUnit--import           Language.Egison                (version)--main :: IO ()-main = defaultMain . hUnitTestToTests . test $ TestList-    [ TestLabel "load-file option" . TestCase $ assertEgisonCmd-        (interpreter "1\n")-        ["--load-file", "test/fixture/a.egi"]-        "x"-    , TestLabel "test option" . TestCase $ assertEgisonCmd-        "3\n\"This is the third line\"\n"-        ["--test", "test/fixture/b.egi"]-        ""-    , TestLabel "eval option" . TestCase $ assertEgisonCmd-        "[[], [1], [1, 2], [1, 2, 3]]\n"-        ["--eval", "matchAll [1,2,3] as list something with $x ++ _ -> x"]-        ""-    , TestLabel "command option" . TestCase $ assertEgisonCmd-        "1\n"-        ["--command", "print (show 1)"]-        ""-    , TestLabel "TSV option" . TestCase $ assertEgisonCmd-        "2\n3\n5\n7\n11\n13\n17\n19\n23\n29\n"-        ["-T", "-e", "take 10 primes"]-        ""-    , TestLabel "TSV option with tab" . TestCase $ assertEgisonCmd-        "1\t2\t3\n4\t5\n"-        ["-T", "-e", "[[1, 2, 3], [4, 5]]"]-        ""-    , TestLabel "substitute option" . TestCase $ assertEgisonCmd-        "10\n11\n12\n13\n14\n15\n"-        ["--substitute", "\\matchAll as list integer with _ ++ $x :: _ ++ #(x + 5) :: _ -> x"]-        "10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20"-    , TestLabel "map option" . TestCase $ assertEgisonCmd-        "3\n4\n5\n6\n7\n"-        ["--map", "\\x -> x + 2"]-        "1\n2\n3\n4\n5"-    , TestLabel "filter option" . TestCase $ assertEgisonCmd-        "2\n3\n5\n7\n"-        ["--filter", "isPrime"]-        "1\n2\n3\n4\n5\n6\n7\n8\n9\n10"-    , TestLabel "field option" . TestCase $ assertEgisonCmd-        "(10, [2, 5])\n(11, [11])\n(12, [2, 2, 3])\n(13, [13])\n(14, [2, 7])\n(15, [3, 5])\n"-        ["--field", "2c", "-m", "\\x -> x"]-        "10\t2\t5\n11\t11\n12\t2\t2\t3\n13\t13\n14\t2\t7\n15\t3\t5"-    , TestLabel "math option" . TestCase $ assertEgisonCmd-        (interpreter "#latex|\\frac{x}{y}|#\n")-        ["--math", "latex"]-        "x / y"-    , TestLabel "sexpr option" . TestCase $ assertEgisonCmd-        (interpreter "3\n")-        ["--sexpr-syntax"]-        "(+ 1 2)"-    , TestLabel "execute main function" . TestCase $ assertEgisonCmd-        "[\"a\", \"b\", \"c\"]\n"-        ["test/fixture/c.egi", "a", "b", "c"]-        ""-    ]--assertEgisonCmd-  :: String   -- The expected value-  -> [String] -- any arguments for egison command-  -> String   -- standard input for egison command-  -> Assertion-assertEgisonCmd expected args input = do-  actual <- readProcess "stack" ("exec" : "--" : "egison" : args) input-  assertEqual "" expected actual--interpreter :: String -> String-interpreter output = concat-  [ "Egison Version ", showVersion version, "\n"-  , "https://www.egison.org\n"-  , "Welcome to Egison Interpreter!\n"-  , "> ", output-  , "> Leaving Egison Interpreter.\n"-  ]
test/Test.hs view
@@ -26,6 +26,9 @@   , "test/lib/core/maybe.egi"   , "test/lib/core/number.egi"   , "test/lib/core/order.egi"+  , "test/lib/core/random.egi"+  , "test/lib/core/shell.egi"+  , "test/lib/core/sort.egi"   , "test/lib/core/string.egi"   , "test/lib/math/algebra.egi"   , "test/lib/math/analysis.egi"
test/lib/core/assoc.egi view
@@ -10,31 +10,6 @@   (fromAssoc [(x, 2), (y, 1)])   [x, x, y] -assertEqual "assocList"-  (matchAll [(x, 2), (y, 1)] as assocList something with-    | $a :: _ -> a)-  [x]--assertEqual "assocList"-  (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with-    | ncons $a #2 $r -> (a, r))-  [(x, [(x, 1), (y, 2), (z, 1)])]--assertEqual "assocList"-  (matchAll [(x, 1), (y, 2), (z, 3)] as assocList something with-    | ncons $a #2 $r -> (a, r))-  []--assertEqual "assocList"-  (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with-    | ncons $a $n $r -> (a, n, r))-  [(x, 3, [(y, 2), (z, 1)])]--assertEqual "assocList"-  (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with-    | ncons $a $n $r -> (a, n, r))-  [(x, 3, [(y, 2), (z, 1)])]- assertEqual "assocMultiset"   (matchAll [(x, 2), (y, 1)] as assocMultiset something with     | $a :: _ -> a)@@ -42,22 +17,22 @@  assertEqual "assocMultiset"   (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with-    | ncons #z $n $r -> (n, r))+    | #z ^ $n :: $r -> (n, r))   [(1, [(x, 3), (y, 2)])]  assertEqual "assocMultiset"   (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with-    | ncons $a #2 $r -> (a, r))+    | $a ^ #2 :: $r -> (a, r))   [(x, [(x, 1), (y, 2), (z, 1)]), (y, [(x, 3), (z, 1)])]  assertEqual "assocMultiset"   (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with-    | ncons #y #1 $r -> r)+    | #y ^ #1 :: $r -> r)   [[(x, 3), (y, 1), (z, 1)]]  assertEqual "assocMultiset"   (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with-    | ncons $a $n $r -> (a, n, r))+    | $a ^ $n :: $r -> (a, n, r))   [(x, 3, [(y, 2), (z, 1)]), (y, 2, [(x, 3), (z, 1)]), (z, 1, [(x, 3), (y, 2)])]  assertEqual "AC.intersect"
+ test/lib/core/io.egi view
@@ -0,0 +1,51 @@+def main args := do+  display "display"+  write " write"+  print " print"+  testPrintToPort+  testEach+  testEachLineFromPort+  let _ := return $ debug (1 + 2)+  let _ := return $ debug2 "1 + 2 = " (1 + 2)+  return ()++def testPrintToPort := do+  let op := openOutputFile "out.txt"+  displayToPort op "displayToPort"+  writeToPort op " writeToPort"+  printToPort op " printToPort"+  closeOutputPort op+  let out := readProcess "cat" ["out.txt"] ""+  let _ := return $+    assertEqual "testPrintToPort" (S.split "\n" out)+      ["displayToPort writeToPort printToPort", ""]+  let _ := readProcess "rm" ["out.txt"] ""+  return ()++def testEach := do+  let op := openOutputFile "out.txt"+  each (printToPort op) ["foo", "bar"]+  closeOutputPort op+  let out := readProcess "cat" ["out.txt"] ""+  let _ := return $+    assertEqual "testEach" (S.split "\n" out) ["foo", "bar", ""]+  let _ := readProcess "rm" ["out.txt"] ""+  return ()++def testEachLineFromPort := do+  let ip := openInputFile "test/fixture/lorem-ipsum.txt"+  let op := openOutputFile "out.txt"+  eachLineFromPort ip (\x -> printToPort op (S.map upperCase x))+  closeInputPort ip+  closeOutputPort op+  let out := readProcess "cat" ["out.txt"] ""+  let _ := return $+    assertEqual "testEachLineFromPort" (S.split "\n" out)+      [ "LOREM IPSUM DOLOR SIT AMET, CONSECTETUR ADIPISCING ELIT, SED DO EIUSMOD TEMPOR INCIDIDUNT UT LABORE ET DOLORE MAGNA ALIQUA."+      , "UT ENIM AD MINIM VENIAM, QUIS NOSTRUD EXERCITATION ULLAMCO LABORIS NISI UT ALIQUIP EX EA COMMODO CONSEQUAT."+      , "DUIS AUTE IRURE DOLOR IN REPREHENDERIT IN VOLUPTATE VELIT ESSE CILLUM DOLORE EU FUGIAT NULLA PARIATUR."+      , "EXCEPTEUR SINT OCCAECAT CUPIDATAT NON PROIDENT, SUNT IN CULPA QUI OFFICIA DESERUNT MOLLIT ANIM ID EST LABORUM."+      , ""+      ]+  let _ := readProcess "rm" ["out.txt"] ""+  return ()
test/lib/core/number.egi view
@@ -70,7 +70,7 @@ assertEqual "nAdic" (nAdic 2 10) [1, 0, 1, 0]  assertEqual "rtod"-  ((\(x, y) -> (x, take 10 y)) (rtod (6 / 35)))+  ((2)#(%1, take 10 %2) (rtod (6 / 35)))   (0, [1, 7, 1, 4, 2, 8, 5, 7, 1, 4])  assertEqual "rtod'" (rtod' (6 / 35)) (0, [1], [7, 1, 4, 2, 8, 5])@@ -106,7 +106,7 @@  assertEqual   "regularContinuedFractionOfSqrt case 1"-  ((\(x, y) -> (x, take 10 y)) (regularContinuedFractionOfSqrt 2))+  ((2)#(%1, take 10 %2) (regularContinuedFractionOfSqrt 2))   (1, [2, 2, 2, 2, 2, 2, 2, 2, 2, 2])  assertEqual
test/lib/core/order.egi view
@@ -1,43 +1,50 @@-assertEqual "compare"-  (compare 10 10)-  Equal--assertEqual "compare"-  (compare 11 10)-  Greater--assertEqual "compare"-  (compare 10 11)-  Less+assertEqual "compare" (compare 10 10) Equal+assertEqual "compare" (compare 11 10) Greater+assertEqual "compare" (compare 10 11) Less -assertEqual "min"-  (min 20 5)-  5+assertEqual "compareC" (compareC [1, 2] [1]) Greater+assertEqual "compareC" (compareC [1] [1, 2]) Less+assertEqual "compareC" (compareC [1, 2] [1, 3]) Less+assertEqual "compareC" (compareC [1, 3] [1, 3]) Equal -assertEqual "minimum"-  (minimum [20, 5, 12])-  5+assertEqual "min" (min 20 5) 5+assertEqual "max" (max 5 30) 30 -assertEqual "min/fn"-  (min/fn compare [10, 20, 5, 20, 30])-  5+assertEqual "min/fn" (min/fn compare [10, 20, 5, 20, 30]) 5+assertEqual "max/fn" (max/fn compare [10, 20, 5, 20, 30]) 30 -assertEqual "max"-  (max 5 30)-  30+assertEqual "minimum" (minimum [20, 5, 12]) 5+assertEqual "maximum" (maximum [5, 30, 23]) 30 -assertEqual "maximum"-  (maximum [5, 30, 23])-  30+assertEqual "splitByOrdering"+  (splitByOrdering 2 [1, 2, 3, 2, 3, 4, 5])+  ([1], [2, 2], [3, 3, 4, 5]) -assertEqual "max/fn"-  (max/fn compare [10, 20, 5, 20, 30])-  30+assertEqual "splitByOrdering/fn"+  (splitByOrdering/fn (\_ _ -> Equal) 2 [1, 2, 3, 4, 5])+  ([], [1, 2, 3, 4, 5], [])  assertEqual "sort"   (sort [10, 20, 5, 20, 30])   [5, 10, 20, 20, 30]  assertEqual "sort/fn"-  (sort/fn compare [10, 20, 5, 20, 30])-  [5, 10, 20, 20, 30]+  (sort/fn+    (\x y -> match compare x y as ordering with+             | greater -> Less+             | less -> Greater+             | equal -> Equal)+    [10, 20, 5, 20, 30])+  [30, 20, 20, 10, 5]++assertEqual "sortStrings"+  (sortStrings ["banana", "apple", "chocolate"])+  ["apple", "banana", "chocolate"]++assertEqual "minimize"+  (minimize S.length ["banana", "apple", "chocolate"])+  "apple"++assertEqual "maximize"+  (maximize S.length ["banana", "apple", "chocolate"])+  "chocolate"
+ test/lib/core/random.egi view
@@ -0,0 +1,50 @@+assert "rands"+  (all (`member` [1..10]) (take 5 (rands 1 10)))++assert "pureRand"+  (member (pureRand 1 10) [1..10])++assertEqual "randomize" (randomize []) []+assert "randomize" (eqAs (multiset integer) (randomize [1, 2, 3]) [1, 2, 3])++assert "R.between"+  (eqAs (multiset integer) (R.between 1 10) [1..10])++assert "R.multiset"+  (member+    (matchAll [1, 2] as R.multiset integer with $n :: $ns -> (n, ns))+    [[(1, [2]), (2, [1])], [(2, [1]), (1, [2])]])++assertEqual "R.multiset"+  (matchAll [1, 2] as R.multiset integer with #1 :: $ns -> ns)+  [[2]]++assert "R.set"+  (member+    (matchAll [1, 2] as R.set integer with $n :: $ns -> (n, ns))+    [[(1, [1, 2]), (2, [1, 2])], [(2, [1, 2]), (1, [1, 2])]])++assertEqual "R.set"+  (matchAll [1, 2] as R.set integer with #1 :: $ns -> ns)+  [[1, 2]]++assert "R.uncons"+  (member (R.uncons [1, 2]) [(1, [2]), (2, [1])])++assert "R.head"+  (member (R.head [1..10]) [1..10])++assert "R.tail"+  (member+    (R.tail [1..5])+    [[   2, 3, 4, 5],+     [1,    3, 4, 5],+     [1, 2,    4, 5],+     [1, 2, 3,    5],+     [1, 2, 3, 4   ]])++assert "f.rands"+  (all (\x -> x >= 1.0 && x <= 2.0) (take 10 (f.rands 1.0 2.0)))++assert "f.pureRand"+  (let x := f.pureRand 1.0 2.0 in x >= 1.0 && x <= 2.0)
+ test/lib/core/shell.egi view
@@ -0,0 +1,14 @@+load "lib/core/shell.egi"++assertEqual "TSV.parseLine" (TSV.parseLine [[2]] []   "1\t2\t3") (1, "2", "3")+assertEqual "TSV.parseLine" (TSV.parseLine [[2,2]] [] "1\t2\t3") (1, "2", 3)+assertEqual "TSV.parseLine" (TSV.parseLine [[2,1]] [] "1\t2\t3") (1, "2", "3")++assertEqual "TSV.parseLine" (TSV.parseLine [] [[2]] "1\t2\t3") (1, [2, 3])+assertEqual "TSV.parseLine" (TSV.parseLine [] [[2,2]] "1\t2\t3") (1, [2], 3)+assertEqual "TSV.parseLine" (TSV.parseLine [] [[2,1]] "1\t2\t3") (1, [2, 3])++-- TODO: Is this intended behavior?+assertEqual "TSV.parseLine"+  (TSV.parseLine [[3,4], [6,9]] [[2,3], [5,7]] "1\t2\t3\t4\t5\t6\t7\t8\t9\t10")+  (1, [2, "3"], "4", 5, ["6", "7", "8"], "9", 10)
+ test/lib/core/sort.egi view
@@ -0,0 +1,11 @@+assertEqual "sortWithSign" (sortWithSign []) (1, [])++assertEqual "sortWithSign" (sortWithSign [[1]]) (1, [1])++assertEqual "sortWithSign" (sortWithSign [[2], [1]]) (-1, [1, 2])+assertEqual "sortWithSign" (sortWithSign [[1], [2]]) (1, [1, 2])+assertEqual "sortWithSign" (sortWithSign [[2, 3], [2, 1]]) (-1, [2, 1, 2, 3])++assertEqual "sortWithSign" (sortWithSign [[1], [3], [2]]) (-1, [1, 2, 3])+assertEqual "sortWithSign" (sortWithSign [[3], [1], [2]]) (1, [1, 2, 3])+assertEqual "sortWithSign" (sortWithSign [[3, 6], [1, 2], [2, 4]]) (1, [1, 2, 2, 4, 3, 6])
test/lib/math/tensor.egi view
@@ -51,7 +51,7 @@  assertEqual   "append indices with ..."-  (let A := generateTensor 2#1 [2, 2]+  (let A := generateTensor (\_ -> 1) [2, 2]        f %B := B..._j     in f A_i)   [|[|1, 1|], [|1, 1|]|]_i_j@@ -59,15 +59,9 @@ assertEqual   "generate_tensor by using function expr"   (let g_i_j := (generateTensor-                  (\n m -> if n = m then function (x, y, z) else 0)+                  (\match as list integer with+                    | [$n, #n] -> function (x, y, z)+                    | _        -> 0)                   [3, 3])_i_j     in show (withSymbols [i, j] d/d g_i_j x))   "[| [| g_1_1|x, 0, 0 |], [| 0, g_2_2|x, 0 |], [| 0, 0, g_3_3|x |] |]"--assertEqual-  "define tensor having value of function expr"-  (let h_i_j := [|[|function (x, y, z), 0, 0|]-                , [|0, function (x, y, z), 0|]-                , [|0, 0, function (x, y, z)|]|]_i_j-    in show (withSymbols [i, j] d/d h_i_j x))-  "[| [| h_1_1|x, 0, 0 |], [| 0, h_2_2|x, 0 |], [| 0, 0, h_3_3|x |] |]"