egison 3.9.3 → 3.9.4

raw patch · 37 files changed

+3388/−2072 lines, 37 filesdep +prettyprinterdep ~basenew-component:exe:egison-translatePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: prettyprinter

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• egison.cabal +16/−2
• hs-src/Interpreter/egison.hs +1/−4
• hs-src/Language/Egison.hs +12/−17
• hs-src/Language/Egison/Core.hs +3/−6
• hs-src/Language/Egison/Desugar.hs +33/−67
• hs-src/Language/Egison/MathOutput.hs +50/−73
• hs-src/Language/Egison/Parser.hs +18/−34
• hs-src/Language/Egison/ParserNonS.hs +805/−953
• hs-src/Language/Egison/ParserNonS2.hs +0/−783
• hs-src/Language/Egison/Pretty.hs +80/−0
• hs-src/Language/Egison/Primitives.hs +41/−79
• hs-src/Language/Egison/Types.hs +32/−47
• hs-src/Language/Egison/Util.hs +1/−2
• hs-src/Tool/translator.hs +124/−0
• nons-test/test/lib/core/base.egi +55/−0
• nons-test/test/lib/core/order.egi +35/−0
• nons-test/test/primitive.egi +175/−0
• nons-test/test/syntax.egi +467/−0
• sample/unify.egi +0/−2
• test/Test.hs +3/−3
• test/answer/sample/mahjong.egi +2/−0
• test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi +23/−0
• test/answer/sample/math/number/17th-root-of-unity.egi +2/−0
• test/answer/sample/poker-hands-with-joker.egi +4/−0
• test/answer/sample/poker-hands.egi +4/−0
• test/answer/sample/primes.egi +2/−0
• test/lib/core/base.egi +68/−0
• test/lib/core/collection.egi +417/−0
• test/lib/core/number.egi +143/−0
• test/lib/core/order.egi +35/−0
• test/lib/core/string.egi +99/−0
• test/lib/math/algebra.egi +15/−0
• test/lib/math/analysis.egi +41/−0
• test/lib/math/arithmetic.egi +31/−0
• test/lib/math/tensor.egi +85/−0
• test/primitive.egi +15/−0
• test/syntax.egi +451/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.9.3+Version:             3.9.4 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.@@ -61,8 +61,12 @@  Data-files:          lib/core/*.egi lib/math/*.egi lib/math/common/*.egi lib/math/algebra/*.egi lib/math/analysis/*.egi lib/math/geometry/*.egi                      sample/*.egi sample/io/*.egi sample/math/algebra/*.egi sample/math/analysis/*.egi sample/math/geometry/*.egi sample/math/number/*.egi sample/math/others/*.egi+                     test/*.egi test/lib/core/*.egi test/lib/math/*.egi+                     nons-test/test/*.egi nons-test/test/lib/core/*.egi+                     test/answer/sample/*.egi test/answer/sample/math/geometry/*.egi test/answer/sample/math/number/*.egi                      elisp/egison-mode.el + source-repository head   type: git   location: https://github.com/egison/egison.git@@ -89,6 +93,7 @@     , vector     , split     , hashable+    , prettyprinter   if !impl(ghc > 8.0)     Build-Depends: fail   Hs-Source-Dirs:  hs-src@@ -99,7 +104,7 @@                    Language.Egison.Types                    Language.Egison.Parser                    Language.Egison.ParserNonS-                   Language.Egison.ParserNonS2+                   Language.Egison.Pretty                    Language.Egison.Primitives                    Language.Egison.Util                    Language.Egison.MathOutput@@ -160,3 +165,12 @@   Hs-Source-Dirs:      hs-src/Interpreter   Other-modules:       Paths_egison   ghc-options:  -O3 -threaded -eventlog -rtsopts++Executable egison-translate+  Main-is:          translator.hs+  Build-depends:+      egison+    , base >= 4.0 && < 5+    , prettyprinter+    , split+  Hs-Source-Dirs:   hs-src/Tool

@@ -111,10 +111,7 @@             <*> flag True False                   (short 'N'                   <> long "new-syntax"-                  <> help "Use non-S-expressoin syntax")-            <*> flag False True-                  (long "N2"-                  <> help "[experimental] Use new lexer and parser")+                  <> help "[experimental] Use non-S expression syntax")  readFieldOption :: String -> (String, String) readFieldOption str =

@@ -37,7 +37,6 @@ import           Language.Egison.MathOutput  (changeOutputInLang) import           Language.Egison.Parser      as Parser import           Language.Egison.ParserNonS  as ParserNonS-import           Language.Egison.ParserNonS2 as ParserNonS2 import           Language.Egison.Primitives import           Language.Egison.Types @@ -80,30 +79,26 @@ -- |eval an Egison expression. Input is a Haskell string. runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue) runEgisonExpr opts env input-  | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readExpr input >>= evalExprDeep env-  | optSExpr opts    = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env-  | otherwise        = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env+  | optSExpr opts = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env+  | otherwise     = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env  -- |eval an Egison top expression. Input is a Haskell string. runEgisonTopExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env) runEgisonTopExpr opts env input-  | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr opts env-  | optSExpr opts    = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr opts env-  | otherwise        = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr opts env+  | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr opts env+  | otherwise     = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr opts env  -- |eval an Egison top expression. Input is a Haskell string. runEgisonTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env)) runEgisonTopExpr' opts st input-  | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr' opts st-  | optSExpr opts    = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' opts st-  | otherwise        = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' opts st+  | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' opts st+  | otherwise     = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' opts st  -- |eval Egison top expressions. Input is a Haskell string. runEgisonTopExprs :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env) runEgisonTopExprs opts env input-  | optUseNonS2 opts = fromEgisonM $ ParserNonS2.readTopExprs input >>= evalTopExprs opts env-  | optSExpr opts    = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs opts env-  | otherwise        = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs opts env+  | optSExpr opts = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs opts env+  | otherwise     = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs opts env  -- |load an Egison file loadEgisonFile :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env)@@ -116,10 +111,10 @@ -- |Environment that contains core libraries initialEnv :: EgisonOpts -> IO Env initialEnv opts = do-  env <- if optNoIO opts then if optUseNonS2 opts then primitiveEnvNoIO'-                                                  else primitiveEnvNoIO-                         else if optUseNonS2 opts then primitiveEnv'-                                                  else primitiveEnv+  env <- if optNoIO opts then if optSExpr opts then primitiveEnvNoIO+                                               else primitiveEnvNoIO'+                         else if optSExpr opts then primitiveEnv+                                               else primitiveEnv'   ret <- evalEgisonTopExprs defaultOption env $ map Load coreLibraries   case ret of     Left err -> do

@@ -66,7 +66,6 @@  import           Language.Egison.Parser      as Parser import           Language.Egison.ParserNonS  as ParserNonS-import           Language.Egison.ParserNonS2 as ParserNonS2 import           Language.Egison.Types  --@@ -84,7 +83,6 @@       if optNoIO opts          then throwError $ Default "No IO support"          else do exprs' <- if-                   | optUseNonS2 opts -> ParserNonS2.loadFile file                    | optSExpr opts    -> Parser.loadFile file                    | otherwise        -> ParserNonS.loadFile file                  collectDefs opts (exprs' ++ exprs) bindings rest@@ -92,7 +90,6 @@       if optNoIO opts          then throwError $ Default "No IO support"          else do exprs' <- if-                   | optUseNonS2 opts -> ParserNonS2.loadLibraryFile file                    | optSExpr opts    -> Parser.loadLibraryFile file                    | otherwise        -> ParserNonS.loadLibraryFile file                  collectDefs opts (exprs' ++ exprs) bindings rest@@ -126,7 +123,7 @@ evalExpr _ (StringExpr s) = return $ Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b evalExpr _ (IntegerExpr x) = return . Value $ toEgison x-evalExpr _ (FloatExpr x y) = return . Value $ Float x y+evalExpr _ (FloatExpr x) = return . Value $ Float x  evalExpr env (QuoteExpr expr) = do   whnf <- evalExpr env expr@@ -1553,7 +1550,7 @@ extractPrimitiveValue (Value val@(Char _)) = return val extractPrimitiveValue (Value val@(Bool _)) = return val extractPrimitiveValue (Value val@(ScalarData _)) = return val-extractPrimitiveValue (Value val@(Float _ _)) = return val+extractPrimitiveValue (Value val@(Float _)) = return val extractPrimitiveValue whnf =   -- we don't need to extract call stack since detailed error information is not used   throwError $ TypeMismatch "primitive value" whnf@@ -1562,5 +1559,5 @@ isPrimitiveValue (Value (Char _))       = True isPrimitiveValue (Value (Bool _))       = True isPrimitiveValue (Value (ScalarData _)) = True-isPrimitiveValue (Value (Float _ _))    = True+isPrimitiveValue (Value (Float _))      = True isPrimitiveValue _                      = False

@@ -13,62 +13,35 @@  module Language.Egison.Desugar     (-      DesugarM-    , runDesugarM-    , desugarTopExpr+      desugarTopExpr     , desugarExpr-    , desugar     ) where -import           Control.Applicative   (Applicative, pure, (<$>), (<*>))-import           Control.Monad.Except-import           Control.Monad.Fail-import           Control.Monad.Reader import           Data.Char             (toUpper)-import           Data.List             (find, span)-import           Data.Maybe            (fromJust, fromMaybe)+import           Data.List             (span) import           Data.Set              (Set) import qualified Data.Set              as S  import           Language.Egison.Types -type Subst = [(String, EgisonExpr)]--newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ExceptT EgisonError Fresh) a }-  deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst)--instance MonadFail DesugarM where-    fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack--runDesugarM :: DesugarM a -> Fresh (Either EgisonError a)-runDesugarM = runExceptT . flip runReaderT [] . unDesugarM- desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr-desugarTopExpr (Define name expr) = do-  expr' <- liftEgisonM $ runDesugarM $ desugar expr-  return (Define name expr')-desugarTopExpr (Redefine name expr) = do-  expr' <- liftEgisonM $ runDesugarM $ desugar expr-  return (Redefine name expr')-desugarTopExpr (Test expr) = do-  expr' <- liftEgisonM $ runDesugarM $ desugar expr-  return (Test expr')-desugarTopExpr (Execute expr) = do-  expr' <- liftEgisonM $ runDesugarM $ desugar expr-  return (Execute expr')-desugarTopExpr expr = return expr+desugarTopExpr (Define name expr)   = Define name <$> desugar expr+desugarTopExpr (Redefine name expr) = Redefine name <$> desugar expr+desugarTopExpr (Test expr)          = Test <$> desugar expr+desugarTopExpr (Execute expr)       = Execute <$> desugar expr+desugarTopExpr expr                 = return expr  desugarExpr :: EgisonExpr -> EgisonM EgisonExpr-desugarExpr expr = liftEgisonM $ runDesugarM $ desugar expr+desugarExpr = desugar -desugar :: EgisonExpr -> DesugarM EgisonExpr+desugar :: EgisonExpr -> EgisonM EgisonExpr desugar (AlgebraicDataMatcherExpr patterns) = do   matcherName <- freshV   let matcherRef = VarExpr matcherName   matcher <- genMatcherClauses patterns matcherRef   return $ LetRecExpr [([matcherName], matcher)] matcherRef     where-      genMatcherClauses :: [(String, [EgisonExpr])] ->  EgisonExpr -> DesugarM EgisonExpr+      genMatcherClauses :: [(String, [EgisonExpr])] ->  EgisonExpr -> EgisonM EgisonExpr       genMatcherClauses patterns matcher = do         main <- genMainClause patterns matcher         body <- mapM genMatcherClause patterns@@ -76,7 +49,7 @@         let clauses = [main] ++ body ++ [footer]         return $ MatcherExpr clauses -      genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMainClause patterns matcher = do         clauses <- genClauses patterns         return (PPValuePat "val", TupleExpr []@@ -84,34 +57,34 @@                                             (TupleExpr [matcher, matcher])                                              clauses)])         where-          genClauses :: [(String, [EgisonExpr])] -> DesugarM [MatchClause]+          genClauses :: [(String, [EgisonExpr])] -> EgisonM [MatchClause]           genClauses patterns = (++) <$> mapM genClause patterns                                      <*> pure [(TuplePat [WildCard, WildCard], matchingFailure)] -          genClause :: (String, [EgisonExpr]) -> DesugarM MatchClause+          genClause :: (String, [EgisonExpr]) -> EgisonM MatchClause           genClause pattern = do             (pat0, pat1) <- genMatchingPattern pattern             return (TuplePat [pat0, pat1], matchingSuccess) -          genMatchingPattern :: (String, [EgisonExpr]) -> DesugarM (EgisonPattern, EgisonPattern)+          genMatchingPattern :: (String, [EgisonExpr]) -> EgisonM (EgisonPattern, EgisonPattern)           genMatchingPattern (name, patterns) = do             names <- mapM (const freshV) patterns             return (InductivePat name (map PatVar names),                     InductivePat name (map (ValuePat . VarExpr) names)) -      genMatcherClause :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genMatcherClause :: (String, [EgisonExpr]) -> EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genMatcherClause pattern = do         (ppat, matchers) <- genPrimitivePatPat pattern         (dpat, body)     <- genPrimitiveDataPat pattern         return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)])          where-          genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr])+          genPrimitivePatPat :: (String, [EgisonExpr]) -> EgisonM (PrimitivePatPattern, [EgisonExpr])           genPrimitivePatPat (name, matchers) = do             patterns' <- mapM (const $ return PPPatVar) matchers             return (PPInductivePat name patterns', matchers) -          genPrimitiveDataPat :: (String, [EgisonExpr]) -> DesugarM (PrimitiveDataPattern, [EgisonExpr])+          genPrimitiveDataPat :: (String, [EgisonExpr]) -> EgisonM (PrimitiveDataPattern, [EgisonExpr])           genPrimitiveDataPat (name, patterns) = do             patterns' <- mapM (const freshV) patterns             return (PDInductivePat (capitalize name) $ map (PDPatVar . show) patterns', map VarExpr patterns')@@ -120,7 +93,7 @@           capitalize (x:xs) = toUpper x : xs  -      genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+      genSomethingClause :: EgisonM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])       genSomethingClause =         return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (stringToVarExpr "tgt")])]) @@ -186,10 +159,8 @@ desugar (UserrefsExpr bool expr1 expr2) =   UserrefsExpr bool <$> desugar expr1 <*> desugar expr2 -desugar (PowerExpr expr1 expr2) = do-  expr1' <- desugar expr1-  expr2' <- desugar expr2-  return $ ApplyExpr (stringToVarExpr "**") (TupleExpr [expr1', expr2'])+desugar (PowerExpr expr1 expr2) =+  (\x y -> makeApply "**" [x, y]) <$> desugar expr1 <*> desugar expr2  desugar (ArrayBoundsExpr expr) =   ArrayBoundsExpr <$> desugar expr@@ -359,15 +330,12 @@ desugar (CApplyExpr expr0 expr1) =   CApplyExpr <$> desugar expr0 <*> desugar expr1 -desugar (VarExpr name) =-  asks $ fromMaybe (VarExpr name) . lookup (show name)- desugar FreshVarExpr = do   id <- fresh   return $ stringToVarExpr (":::" ++ id) -desugar (MatcherExpr matcherInfo) =-  MatcherExpr <$> desugarMatcherInfo matcherInfo+desugar (MatcherExpr patternDefs) =+  MatcherExpr <$> mapM desugarPatternDef patternDefs  desugar (PartialVarExpr n) = return $ PartialVarExpr n @@ -381,18 +349,18 @@ desugar (QuoteSymbolExpr expr) =   QuoteSymbolExpr <$> desugar expr -desugar (WedgeExpr (ApplyExpr expr0 expr1)) =+desugar (WedgeApplyExpr expr0 expr1) =   WedgeApplyExpr <$> desugar expr0 <*> desugar expr1  desugar expr = return expr -desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr)+desugarIndex :: Index EgisonExpr -> EgisonM (Index EgisonExpr) desugarIndex (Superscript expr)  = Superscript  <$> desugar expr desugarIndex (Subscript expr)    = Subscript    <$> desugar expr desugarIndex (SupSubscript expr) = SupSubscript <$> desugar expr desugarIndex (Userscript expr)   = Userscript   <$> desugar expr -desugarPattern :: EgisonPattern -> DesugarM EgisonPattern+desugarPattern :: EgisonPattern -> EgisonM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern  where    collectNames :: [EgisonPattern] -> Set String@@ -419,7 +387,7 @@    makeBinding :: String -> BindingExpr    makeBinding name = ([stringToVar name], HashExpr []) -desugarPattern' :: EgisonPattern -> DesugarM EgisonPattern+desugarPattern' :: EgisonPattern -> EgisonM EgisonPattern desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern@@ -467,25 +435,23 @@ desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' pattern = return pattern -desugarLoopRange :: LoopRange -> DesugarM LoopRange+desugarLoopRange :: LoopRange -> EgisonM LoopRange desugarLoopRange (LoopRange sExpr eExpr pattern) =   LoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pattern -desugarBindings :: [BindingExpr] -> DesugarM [BindingExpr]+desugarBindings :: [BindingExpr] -> EgisonM [BindingExpr] desugarBindings = mapM f   where f (name, expr) = (name,) <$> desugar expr -desugarMatchClauses :: [MatchClause] -> DesugarM [MatchClause]+desugarMatchClauses :: [MatchClause] -> EgisonM [MatchClause] desugarMatchClauses = mapM f   where f (pattern, expr) = (,) <$> desugarPattern pattern <*> desugar expr -desugarMatcherInfo :: MatcherInfo -> DesugarM MatcherInfo-desugarMatcherInfo = mapM f-  where-    f (pp, matcher, pds) =-      (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds+desugarPatternDef :: PatternDef -> EgisonM PatternDef+desugarPatternDef (pp, matcher, pds) =+  (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds -desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> DesugarM [(PrimitiveDataPattern, EgisonExpr)]+desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> EgisonM [(PrimitiveDataPattern, EgisonExpr)] desugarPrimitiveDataMatchClauses = mapM f   where f (pd, expr) = (pd,) <$> desugar expr 

@@ -3,71 +3,58 @@ Copyright   : Satoshi Egi Licence     : MIT -This module provides utility functions.+This module provides translation from mathematical Egison expression into+other languages / format of other computer algebra systems. -} -module Language.Egison.MathOutput ( changeOutputInLang ) where+module Language.Egison.MathOutput+  ( changeOutputInLang+  ) where +import           Data.List                     (intercalate)+ import           Text.ParserCombinators.Parsec hiding (spaces)  changeOutputInLang :: String -> String -> String-changeOutputInLang "haskell" input     = mathExprToHaskell input-changeOutputInLang "asciimath" input   = mathExprToAsciiMath input-changeOutputInLang "latex" input       = mathExprToLatex input-changeOutputInLang "mathematica" input = mathExprToMathematica input-changeOutputInLang "maxima" input      = mathExprToMaxima input-changeOutputInLang _ input             = input--mathExprToHaskell :: String -> String-mathExprToHaskell input = case parse parseExpr "math-expr" input of-                            Left err  -> input-                            Right val -> "#haskell|" ++ show val ++ "|#"--mathExprToAsciiMath :: String -> String-mathExprToAsciiMath input = case parse parseExpr "math-expr" input of-                              Left err -> input-                              Right val -> case showMathExprAsciiMath val of-                                             "undefined" -> "undefined"-                                             output -> "#asciimath|" ++ output ++ "|#"--mathExprToLatex :: String -> String-mathExprToLatex input = case parse parseExpr "math-expr" input of-                          Left err -> input-                          Right val -> case showMathExprLatex val of-                                         "undefined" -> "undefined"-                                         output -> "#latex|" ++ output ++ "|#"+changeOutputInLang lang input =+  -- 'lang' is either "asciimath", "latex", "mathematica" or "maxima"+  -- Other invalid options are rejected in Interpreter/egison.hs+  case parse parseExpr "math-expr" input of+    Left err  -> input+    Right val -> case showMathExpr lang val of+                   "undefined" -> "undefined"+                   output      -> "#" ++ lang ++ "|" ++ output ++ "|#" -mathExprToMathematica :: String -> String-mathExprToMathematica input = case parse parseExpr "math-expr" input of-                                Left err -> input-                                Right val -> case showMathExprMathematica val of-                                               "undefined" -> "undefined"-                                               output -> "#mathematica|" ++ output ++ "|#"+showMathExpr :: String -> MathExpr -> String+showMathExpr "asciimath"   = showMathExprAsciiMath+showMathExpr "latex"       = showMathExprLatex+showMathExpr "mathematica" = showMathExprMathematica+showMathExpr "maxima"      = showMathExprMaxima+showMathExpr "haskell"     = show -mathExprToMaxima :: String -> String-mathExprToMaxima input = case parse parseExpr "math-expr" input of-                          Left err -> input-                          Right val -> case showMathExprMaxima val of-                                         "undefined" -> "undefined"-                                         output -> "#maxima|" ++ output ++ "|#"+data MathExpr+  = Atom String [MathIndex]+  | NegativeAtom String+  | Plus [MathExpr]+  | Multiply [MathExpr]+  | Power MathExpr MathExpr+  | Func MathExpr [MathExpr]+  | Tensor [MathExpr] [MathIndex]+  | Tuple [MathExpr]+  | Collection [MathExpr]+  | Exp MathExpr+  | Quote MathExpr+  | Partial MathExpr [MathExpr]+  deriving (Eq, Show) -data MathExpr = Atom String [MathIndex]-              | NegativeAtom String-              | Plus [MathExpr]-              | Multiply [MathExpr]-              | Power MathExpr MathExpr-              | Func MathExpr [MathExpr]-              | Tensor [MathExpr] [MathIndex]-              | Tuple [MathExpr]-              | Collection [MathExpr]-              | Exp MathExpr-              | Quote MathExpr-              | Partial MathExpr [MathExpr]-              deriving (Eq, Show)+data MathIndex+  = Super MathExpr+  | Sub MathExpr+  deriving (Eq, Show) -data MathIndex = Super MathExpr-              | Sub MathExpr-              deriving (Eq, Show)+isSub :: MathIndex -> Bool+isSub (Sub _) = True+isSub _       = False  -- -- Show (AsciiMath)@@ -103,22 +90,16 @@ showMathExprAsciiMath (Collection lvs) = "{" ++ showMathExprAsciiMathArg lvs ++ "}" showMathExprAsciiMath (Exp x) = "e^(" ++ showMathExprAsciiMath x ++ ")" -isSub :: MathIndex -> Bool-isSub (Sub _) = True-isSub _       = False- showMathExprAsciiMath' :: MathExpr -> String showMathExprAsciiMath' (Plus lvs) = "(" ++ showMathExprAsciiMath (Plus lvs) ++ ")" showMathExprAsciiMath' val = showMathExprAsciiMath val  showMathExprAsciiMathArg :: [MathExpr] -> String-showMathExprAsciiMathArg [] = ""-showMathExprAsciiMathArg [a] = showMathExprAsciiMath a-showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ showMathExprAsciiMathArg (tail lvs)+showMathExprAsciiMathArg exprs = intercalate ", " $ map showMathExprAsciiMath exprs  showMathExprAsciiMathIndices :: [MathIndex] -> String-showMathExprAsciiMathIndices [a] = showMathIndexAsciiMath a-showMathExprAsciiMathIndices lvs = showMathIndexAsciiMath (head lvs) ++ showMathExprAsciiMathIndices (tail lvs)+showMathExprAsciiMathIndices []  = error "unreachable"+showMathExprAsciiMathIndices lvs = concatMap showMathIndexAsciiMath lvs  showMathIndexAsciiMath :: MathIndex -> String showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a@@ -174,9 +155,7 @@ showMathExprLatex' x         = showMathExprLatex x  showMathExprLatexArg :: [MathExpr] -> String -> String-showMathExprLatexArg [] _ = ""-showMathExprLatexArg [a] _ = showMathExprLatex a-showMathExprLatexArg lvs s = showMathExprLatex (head lvs) ++ s ++ showMathExprLatexArg  (tail lvs) s+showMathExprLatexArg exprs sep = intercalate sep $ map showMathExprLatex exprs  showMathExprLatexSuper :: MathIndex -> String showMathExprLatexSuper (Super (Atom "#" [])) = "\\#"@@ -242,16 +221,14 @@ showMathExprMathematica' x = showMathExprMathematica x  showMathExprsMathematica :: String -> [MathExpr] -> String-showMathExprsMathematica _ [] = ""-showMathExprsMathematica _ [a] = showMathExprMathematica a-showMathExprsMathematica s lvs = showMathExprMathematica (head lvs) ++ s ++ showMathExprsMathematica s (tail lvs)+showMathExprsMathematica sep exprs = intercalate sep $ map showMathExprMathematica exprs  showMathExprMathematicaArg :: [MathExpr] -> String-showMathExprMathematicaArg xs = showMathExprsMathematica ", " xs+showMathExprMathematicaArg = showMathExprsMathematica ", "  showMathExprMathematicaIndices :: [MathIndex] -> String-showMathExprMathematicaIndices [a] = showMathIndexMathematica a-showMathExprMathematicaIndices lvs = showMathIndexMathematica (head lvs) ++ showMathExprMathematicaIndices (tail lvs)+showMathExprMathematicaIndices []  = error "unreachable"+showMathExprMathematicaIndices lvs = concatMap showMathIndexMathematica lvs  showMathIndexMathematica :: MathIndex -> String showMathIndexMathematica (Super a) = showMathExprMathematica a

@@ -57,10 +57,10 @@ readTopExpr = either throwError desugarTopExpr . parseTopExpr  readExprs :: String -> EgisonM [EgisonExpr]-readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs+readExprs = either throwError (mapM desugarExpr) . parseExprs  readExpr :: String -> EgisonM EgisonExpr-readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr+readExpr = either throwError desugarExpr . parseExpr  parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] parseTopExprs = doParse $ do@@ -167,29 +167,21 @@ loadExpr = keywordLoad >> Load <$> stringLiteral  expr :: Parser EgisonExpr-expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr'+expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr                           expr1 <- option expr0 $ try (string "..." >> IndexedExpr False expr0 <$> parseindex)                                                   <|> IndexedExpr True expr0 <$> parseindex                           option expr1 $ PowerExpr expr1 <$> try (char '^' >> expr'))                             where parseindex :: Parser [Index EgisonExpr]-                                  parseindex = many1 (try (do-                                                           char '_'-                                                           e1 <- expr'-                                                           string "..._"-                                                           MultiSubscript e1 <$> expr')-                                                 <|> try (do-                                                           char '~'-                                                           e1 <- expr'-                                                           string "...~"-                                                           MultiSuperscript e1 <$> expr')-                                                 <|> try (Subscript <$> (char '_' >> expr'))-                                                 <|> try (Superscript <$> (char '~' >> expr'))-                                                 <|> try (SupSubscript <$> (string "~_" >> expr'))-                                                 <|> try (Userscript <$> (char '|' >> expr')))+                                  parseindex = many1 (try (MultiSubscript   <$> (char '_' >> expr') <*> (string "..._" >> expr'))+                                                  <|> try (MultiSuperscript <$> (char '~' >> expr') <*> (string "...~" >> expr'))+                                                  <|> try (Subscript    <$> (char '_' >> expr'))+                                                  <|> try (Superscript  <$> (char '~' >> expr'))+                                                  <|> try (SupSubscript <$> (string "~_" >> expr'))+                                                  <|> try (Userscript   <$> (char '|' >> expr')))  -quoteExpr' :: Parser EgisonExpr-quoteExpr' = char '\'' >> QuoteExpr <$> expr'+quoteExpr :: Parser EgisonExpr+quoteExpr = char '\'' >> QuoteExpr <$> expr'  expr' :: Parser EgisonExpr expr' = try partialExpr@@ -203,7 +195,6 @@             <|> try tupleExpr             <|> try hashExpr             <|> collectionExpr---            <|> quoteExpr             <|> quoteSymbolExpr             <|> wedgeExpr             <|> parens (ifExpr@@ -287,11 +278,11 @@     pairExpr :: Parser (EgisonExpr, EgisonExpr)     pairExpr = brackets $ (,) <$> expr <*> expr -quoteExpr :: Parser EgisonExpr-quoteExpr = char '\'' >> QuoteExpr <$> expr- wedgeExpr :: Parser EgisonExpr-wedgeExpr = char '!' >> WedgeExpr <$> expr+wedgeExpr = do+  e <- char '!' >> expr+  case e of+    ApplyExpr e1 e2 -> return $ WedgeApplyExpr e1 e2  functionWithArgExpr :: Parser EgisonExpr functionWithArgExpr = keywordFunction >> FunctionExpr <$> between lp rp (sepEndBy expr whiteSpace)@@ -332,10 +323,10 @@ matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses -ppMatchClauses :: Parser MatcherInfo+ppMatchClauses :: Parser [PatternDef] ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace -ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+ppMatchClause :: Parser PatternDef ppMatchClause = brackets $ (,,) <$> ppPattern <*> expr <*> pdMatchClauses  pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]@@ -706,11 +697,7 @@ boolExpr = BoolExpr <$> boolLiteral  floatExpr :: Parser EgisonExpr-floatExpr = do-  (x,y) <- try ((,) <$> floatLiteral <*> (sign' <*> positiveFloatLiteral) <* char 'i')-            <|> try ((0,)  <$> floatLiteral <* char 'i')-            <|> try ((, 0) <$> floatLiteral)-  return $ FloatExpr x y+floatExpr = FloatExpr <$> positiveFloatLiteral  integerExpr :: Parser EgisonExpr integerExpr = IntegerExpr <$> integerLiteral'@@ -729,9 +716,6 @@   let m = read mStr   let l = m % (10 ^ fromIntegral (length mStr))   return (fromRational (fromIntegral n + l) :: Double)--floatLiteral :: Parser Double-floatLiteral = sign <*> positiveFloatLiteral  -- -- Tokens

@@ -1,953 +1,805 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections    #-}--{- |-Module      : Language.Egison.ParserNonS-Copyright   : Satoshi Egi-Licence     : MIT--This module provide Egison parser.--}--module Language.Egison.ParserNonS-       (-       -- * Parse a string-         readTopExprs-       , readTopExpr-       , readExprs-       , readExpr-       , parseTopExprs-       , parseTopExpr-       , parseExprs-       , parseExpr-       -- * Parse a file-       , loadLibraryFile-       , loadFile-       ) where--import           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>))-import           Control.Monad.Except    (liftIO, throwError)-import           Control.Monad.Identity  (Identity, unless)-import           Prelude                 hiding (mapM)--import           System.Directory        (doesFileExist, getHomeDirectory)--import           Data.Char               (isLower, isUpper, toLower)-import           Data.Either-import           Data.Functor            (($>))-import           Data.List               (intercalate)-import           Data.List.Split         (split, splitOn, startsWithOneOf)-import           Data.Ratio-import           Data.Traversable        (mapM)--import           Text.Parsec-import           Text.Parsec.Expr-import           Text.Parsec.String-import qualified Text.Parsec.Token       as P--import qualified Data.Text               as T--import           Language.Egison.Desugar-import           Language.Egison.Types-import           Paths_egison            (getDataFileName)--readTopExprs :: String -> EgisonM [EgisonTopExpr]-readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs--readTopExpr :: String -> EgisonM EgisonTopExpr-readTopExpr = either throwError desugarTopExpr . parseTopExpr--readExprs :: String -> EgisonM [EgisonExpr]-readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs--readExpr :: String -> EgisonM EgisonExpr-readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr--parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]-parseTopExprs = doParse $ do-  ret <- whiteSpace >> endBy topExpr whiteSpace-  eof-  return ret--parseTopExpr :: String -> Either EgisonError EgisonTopExpr-parseTopExpr = doParse $ do-  ret <- whiteSpace >> topExpr-  whiteSpace >> eof-  return ret--parseExprs :: String -> Either EgisonError [EgisonExpr]-parseExprs = doParse $ do-  ret <- whiteSpace >> endBy expr whiteSpace-  eof-  return ret--parseExpr :: String -> Either EgisonError EgisonExpr-parseExpr = doParse $ do-  ret <- whiteSpace >> expr-  whiteSpace >> eof-  return ret---- |Load a libary file-loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]-loadLibraryFile file = do-  homeDir <- liftIO getHomeDirectory-  doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file-  if doesExist-    then loadFile $ homeDir ++ "/.egison/" ++ file-    else liftIO (getDataFileName file) >>= loadFile---- |Load a file-loadFile :: FilePath -> EgisonM [EgisonTopExpr]-loadFile file = do-  doesExist <- liftIO $ doesFileExist file-  unless doesExist $ throwError $ Default ("file does not exist: " ++ file)-  input <- liftIO $ readUTF8File file-  exprs <- readTopExprs $ shebang input-  concat <$> mapM  recursiveLoad exprs- where-  recursiveLoad (Load file)     = loadLibraryFile file-  recursiveLoad (LoadFile file) = loadFile file-  recursiveLoad expr            = return [expr]-  shebang :: String -> String-  shebang ('#':'!':cs) = ';':'#':'!':cs-  shebang cs           = cs------- Parser-----doParse :: Parser a -> String -> Either EgisonError a-doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input-  where-    fromParsecError :: ParseError -> EgisonError-    fromParsecError = Parser . show--doParse' :: Parser a -> String -> a-doParse' p input = case doParse p input of-                     Right x -> x------- Expressions-----topExpr :: Parser EgisonTopExpr-topExpr = try defineExpr-          <|> try (Test <$> expr)-          <|> testExpr-          <|> loadFileExpr-          <|> loadExpr-          <?> "top-level expression"--defineExpr :: Parser EgisonTopExpr-defineExpr = try (Define <$ keywordDefine <*> identVar <*> (LambdaExpr <$> parens argNames' <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr))-             <|> try (Define <$> identVar <* inSpaces (reservedOp "=") <* notFollowedBy (string "=") <*> expr)-             <|> try (do (VarWithIndices name is) <- identVarWithIndices-                         inSpaces $ reservedOp "=" >> notFollowedBy (string "=")-                         Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr)- where-  argNames' :: Parser [Arg]-  argNames' = sepEndBy argName' comma-  argName' :: Parser Arg-  argName' = try (ScalarArg <$> ident)-        <|> try (InvertedScalarArg <$> (char '*' >> ident))-        <|> try (TensorArg <$> (char '%' >> ident))-  f (Superscript _)  = Superscript ()-  f (Subscript _)    = Subscript ()-  f (SupSubscript _) = SupSubscript ()-  g (Superscript i)  = i-  g (Subscript i)    = i-  g (SupSubscript i) = i--testExpr :: Parser EgisonTopExpr-testExpr = keywordTest >> Test <$> parens expr--loadFileExpr :: Parser EgisonTopExpr-loadFileExpr = keywordLoadFile >> LoadFile <$> parens stringLiteral--loadExpr :: Parser EgisonTopExpr-loadExpr = keywordLoad >> Load <$> parens stringLiteral--expr :: Parser EgisonExpr-expr = (try applyInfixExpr-        <|> try exprWithSymbol-        <|> try (buildExpressionParser table arg)-        <|> try ifExpr-        <|> try term)-        <?> "expression"- where-  arg = (char '$' *> notFollowedBy varExpr *> (LambdaArgExpr <$> option "" index))-        <|> term-  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit-  table = [ [unary "not" AssocRight]-          , [binary "^" "**" AssocLeft]-          , [unary "-" AssocLeft]-          , [binary "*" "*" AssocLeft, binary "/" "/" AssocLeft, binary "." "." AssocLeft]-          , [binary "+" "+" AssocLeft, binary "-" "-" AssocLeft, binary "%" "remainder" AssocLeft]-          , [binary "==" "eq?" AssocLeft, binary "<=" "lte?" AssocLeft, binary "<" "lt?" AssocLeft, binary ">=" "gte?" AssocLeft, binary ">" "gt?" AssocLeft]-          , [binary ":" "cons" AssocLeft, binary ".." "between" AssocLeft]-          , [binary "&&" "and" AssocLeft, binary "||" "or" AssocLeft]-          , [binary "++" "join" AssocRight]-          ]-  unary "-" assoc = Prefix (try $ inSpaces (string "-") >> return (\x -> makeApply (stringToVarExpr "*") [IntegerExpr (-1), x]))-  unary op assoc = Prefix (try $ inSpaces (string op) >> return (\x -> makeApply (stringToVarExpr op) [x]))-  binary op name assoc-    | op == "/" = Infix (try $ (try (inSpaces1 $ string op) <|> (inSpaces (string op) >> notFollowedBy (string "m" <|> string "fn"))) >> return (\x y -> makeApply (stringToVarExpr name) [x, y])) assoc-    | op == "." || op == "%" = Infix (try $ inSpaces1 (string op) >> return (\x y -> makeApply (stringToVarExpr name) [x, y])) assoc-    | otherwise = Infix (try $ inSpaces (string op) >> return (\x y -> makeApply (stringToVarExpr name) [x, y])) assoc--inSpaces :: Parser a -> Parser ()-inSpaces p = skipMany (space <|> newline) >> p >> skipMany (space <|> newline)--inSpaces1 :: Parser a -> Parser ()-inSpaces1 p = skipMany (space <|> newline) >> p >> skipMany1 (space <|> newline)--exprWithSymbol :: Parser EgisonExpr-exprWithSymbol = (string "d/d" >> applyExpr'' (stringToVarExpr "d/d"))-                 <|> (string "V.*" >> applyExpr'' (stringToVarExpr "V.*"))-                 <|> (string "M.*" >> applyExpr'' (stringToVarExpr "M.*"))-                 <|> (lookAhead (string "let*") >> letStarExpr)--term :: Parser EgisonExpr-term = P.lexeme lexer-        (do term0 <- term'-            option term0 $ try (IndexedExpr False term0 <$ string "..." <*> parseindex-                           <|> IndexedExpr True term0 <$> parseindex))- where-  parseindex :: Parser [Index EgisonExpr]-  parseindex = many1 $ try (MultiSubscript <$ char '_' <*> term' <* string "..._" <*> term')-                       <|> try (MultiSuperscript <$ char '~' <*> term' <* string "...~" <*> term')-                       <|> try (char '_' >> Subscript <$> term')-                       <|> try (char '~' >> Superscript <$> term')-                       <|> try (string "~_" >> SupSubscript <$> term')-                       <|> try (char '|' >> Userscript <$> term')--term' :: Parser EgisonExpr-term' = matchExpr-        <|> matchAllExpr-        <|> matchAllDFSExpr-        <|> matchLambdaExpr-        <|> matchAllLambdaExpr-        <|> matcherExpr-        <|> functionWithArgExpr-        <|> userrefsExpr-        <|> algebraicDataMatcherExpr-        <|> try applyExpr-        <|> cApplyExpr-        <|> try partialExpr-        <|> try partialVarExpr-        <|> try constantExpr-        <|> try freshVarExpr-        <|> try lambdaExpr-        <|> try cambdaExpr-        <|> try withSymbolsExpr-        <|> try varExpr-        <|> try vectorExpr-        <|> try tupleExpr-        <|> try hashExpr-        <|> try collectionExpr-        <|> inductiveDataExpr-        <|> try doExpr-        <|> generateTensorExpr-        <|> tensorExpr-        <|> letExpr-        <|> letRecExpr-        <|> letStarExpr-        <|> patternFunctionExpr-        <|> quoteExpr-        <|> quoteSymbolExpr-        <|> tensorContractExpr-        <|> subrefsExpr-        <|> suprefsExpr-        <|> macroExpr-        <|> ioExpr-        <|> seqExpr-        <|> memoizedLambdaExpr-        <|> procedureExpr-        <|> wedgeExpr-        <|> parens expr-        <?> "simple expression"--varExpr :: Parser EgisonExpr-varExpr = VarExpr <$> identVarWithoutIndex--freshVarExpr :: Parser EgisonExpr-freshVarExpr = char '#' >> return FreshVarExpr--inductiveDataExpr :: Parser EgisonExpr-inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy term whiteSpace--tupleExpr :: Parser EgisonExpr-tupleExpr = parens $ TupleExpr <$> sepEndBy expr comma--collectionExpr :: Parser EgisonExpr-collectionExpr = brackets (CollectionExpr <$> sepEndBy innerExpr comma)-                 <|> braces (CollectionExpr <$> sepEndBy innerExpr comma)- where-  innerExpr :: Parser InnerExpr-  innerExpr = (char '@' >> SubCollectionExpr <$> expr)-               <|> ElementExpr <$> expr--vectorExpr :: Parser EgisonExpr-vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr comma-  where-    lp = P.lexeme lexer (string "[|")-    rp = string "|]"--hashExpr :: Parser EgisonExpr-hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr comma-  where-    lp = P.lexeme lexer (string "{|")-    rp = string "|}"-    pairExpr :: Parser (EgisonExpr, EgisonExpr)-    pairExpr = brackets $ (,) <$> expr <* comma <*> expr--quoteExpr :: Parser EgisonExpr-quoteExpr = char '\'' >> QuoteExpr <$> expr--wedgeExpr :: Parser EgisonExpr-wedgeExpr = char '!' >> WedgeExpr <$> expr--functionWithArgExpr :: Parser EgisonExpr-functionWithArgExpr = keywordFunction >> FunctionExpr <$> parens (sepEndBy expr comma)--quoteSymbolExpr :: Parser EgisonExpr-quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr--matchAllExpr :: Parser EgisonExpr-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses--matchAllDFSExpr :: Parser EgisonExpr-matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <* keywordAs <*> expr <*> matchClauses--matchExpr :: Parser EgisonExpr-matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses--matchLambdaExpr :: Parser EgisonExpr-matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$ keywordAs <*> expr <*> matchClauses--matchAllLambdaExpr :: Parser EgisonExpr-matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$ keywordAs <*> expr <*> matchClauses--matchClauses :: Parser [MatchClause]-matchClauses = many1 matchClause--matchClause :: Parser MatchClause-matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* reservedOp "->" <*> expr--matcherExpr :: Parser EgisonExpr-matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses--ppMatchClauses :: Parser MatcherInfo-ppMatchClauses = many1 ppMatchClause--ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])-ppMatchClause = inSpaces (string "|") >> (,,) <$> ppPattern <* keywordAs <*> expr <* reservedOp "->" <*> pdMatchClauses--pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]-pdMatchClauses = many1 pdMatchClause--pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)-pdMatchClause = try $ inSpaces (string "|") >> (,) <$> pdPattern <* reservedOp "->" <*> expr--ppPattern :: Parser PrimitivePatPattern-ppPattern = P.lexeme lexer (ppWildCard-                        <|> try ppValuePat-                        <|> ppPatVar-                        <|> ppInductivePat-                        <?> "primitive-pattren-pattern")--ppWildCard :: Parser PrimitivePatPattern-ppWildCard = reservedOp "_" $> PPWildCard--ppPatVar :: Parser PrimitivePatPattern-ppPatVar = reservedOp "$" $> PPPatVar--ppValuePat :: Parser PrimitivePatPattern-ppValuePat = reservedOp "$" >> PPValuePat <$> ident--ppInductivePat :: Parser PrimitivePatPattern-ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)--pdPattern :: Parser PrimitiveDataPattern-pdPattern = P.lexeme lexer pdPattern'--pdPattern' :: Parser PrimitiveDataPattern-pdPattern' = reservedOp "_" $> PDWildCard-                    <|> (char '$' >> PDPatVar <$> ident)-                    <|> brackets ((PDConsPat <$> pdPattern <* comma <*> (char '@' *> pdPattern))-                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <* comma <*> pdPattern)-                            <|> pure PDEmptyPat)-                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace)-                    <|> parens (PDTuplePat <$> sepEndBy pdPattern comma)-                    <|> PDConstantPat <$> constantExpr-                    <?> "primitive-data-pattern"--ifExpr :: Parser EgisonExpr-ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr--lambdaExpr :: Parser EgisonExpr-lambdaExpr = LambdaExpr <$> argNames <* reservedOp "->" <*> expr--memoizedLambdaExpr :: Parser EgisonExpr-memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <* reservedOp "->" <*> expr--memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)]-memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace--memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr)-memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr--cambdaExpr :: Parser EgisonExpr-cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <* reservedOp "->" <*> expr--procedureExpr :: Parser EgisonExpr-procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <* reservedOp "->" <*> expr--macroExpr :: Parser EgisonExpr-macroExpr = keywordMacro >> MacroExpr <$> varNames <* reservedOp "->" <*> expr--patternFunctionExpr :: Parser EgisonExpr-patternFunctionExpr = keywordPatternFunction >> parens (PatternFunctionExpr <$> brackets (sepEndBy ident comma) <* comma <*> pattern)--letRecExpr :: Parser EgisonExpr-letRecExpr =  keywordLetRec >> LetRecExpr <$> bindings <* keywordLetIn <*> expr--letExpr :: Parser EgisonExpr-letExpr = keywordLet >> LetExpr <$> bindings <* keywordLetIn <*> expr--letStarExpr :: Parser EgisonExpr-letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <* keywordLetIn <*> expr--withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident comma) <*> expr--doExpr :: Parser EgisonExpr-doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr--statements :: Parser [BindingExpr]-statements = braces $ sepEndBy statement comma--statement :: Parser BindingExpr-statement = try binding-        <|> (([],) <$> expr)--bindings :: Parser [BindingExpr]-bindings = sepEndBy binding comma--binding :: Parser BindingExpr-binding = (,) <$> varNames' <* inSpaces (string "=") <*> expr--varNames :: Parser [String]-varNames = sepEndBy (char '$' >> ident) whiteSpace--varNames' :: Parser [Var]-varNames' = return <$> identVar-            <|> parens (sepEndBy identVar comma)--argNames :: Parser [Arg]-argNames = sepEndBy argName whiteSpace--argName :: Parser Arg-argName = try (ScalarArg <$> (char '$' >> ident))-      <|> try (InvertedScalarArg <$> (string "*$" >> ident))-      <|> try (TensorArg <$> (char '%' >> ident))--ioExpr :: Parser EgisonExpr-ioExpr = keywordIo >> parens (IoExpr <$> expr)--seqExpr :: Parser EgisonExpr-seqExpr = keywordSeq >> parens (SeqExpr <$> expr <* comma <*> expr)--cApplyExpr :: Parser EgisonExpr-cApplyExpr = keywordCApply >> parens (CApplyExpr <$> expr <* comma <*> expr)--applyExpr :: Parser EgisonExpr-applyExpr = (keywordApply >> parens (ApplyExpr <$> expr <* comma <*> expr))-            <|> try applyExpr'--applyExpr' :: Parser EgisonExpr-applyExpr' = do-  func <- try varExpr <|> try partialExpr <|> try partialVarExpr <|> parens expr-  applyExpr'' func--applyExpr'' :: EgisonExpr -> Parser EgisonExpr-applyExpr'' func = do-  argslist <- many1 $ parens args-  return $ foldl makeApply func argslist- where-  args = sepEndBy arg comma-  arg = try expr-        <|> char '$' *> (LambdaArgExpr <$> option "" index)-  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit--applyInfixExpr :: Parser EgisonExpr-applyInfixExpr = do-  arg1 <- arg-  spaces-  func <- char '`' *> varExpr <* char '`'-  spaces-  arg2 <- arg-  return $ makeApply func [arg1, arg2]- where-  arg = try term-        <|> char '$' *> (LambdaArgExpr <$> option "" index)-  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit--makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr-makeApply func xs = do-  let args = map (\x -> case x of-                          LambdaArgExpr s -> Left s-                          _               -> Right x) xs-  let vars = lefts args-  case vars of-    [] -> ApplyExpr func . TupleExpr $ rights args-    _ | all null vars ->-        let args' = rights args-            args'' = zipWith (curry f) args (annonVars 1 (length args))-            args''' = map (VarExpr . stringToVar . either id id) args''-        in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'-      | all (not . null) vars ->-        let n = length vars-            args' = rights args-            args'' = zipWith (curry g) args (annonVars (n + 1) (length args))-            args''' = map (VarExpr . stringToVar . either id id) args''-        in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'- where-  annonVars m n = take n $ map ((':':) . show) [m..]-  f (Left _, var)  = Left var-  f (Right _, var) = Right var-  g (Left arg, _)  = Left (':':arg)-  g (Right _, var) = Right var--partialExpr :: Parser EgisonExpr-partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> (try (parens expr) <|> expr))- where-  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit--partialVarExpr :: Parser EgisonExpr-partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral--algebraicDataMatcherExpr :: Parser EgisonExpr-algebraicDataMatcherExpr = keywordAlgebraicDataMatcher-                                >> AlgebraicDataMatcherExpr <$> parens (sepEndBy1 inductivePat' comma)-  where-    inductivePat' :: Parser (String, [EgisonExpr])-    inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace--generateTensorExpr :: Parser EgisonExpr-generateTensorExpr = keywordGenerateTensor >> parens (GenerateTensorExpr <$> expr <* comma <*> expr)--tensorExpr :: Parser EgisonExpr-tensorExpr = keywordTensor >> parens (TensorExpr <$> expr <* comma <*> expr <*> option (CollectionExpr []) (comma *> expr) <*> option (CollectionExpr []) (comma *> expr))--tensorContractExpr :: Parser EgisonExpr-tensorContractExpr = keywordTensorContract >> parens (TensorContractExpr <$> expr <* comma <*> expr)--subrefsExpr :: Parser EgisonExpr-subrefsExpr = (keywordSubrefs >> parens (SubrefsExpr False <$> expr <* comma <*> expr))-               <|> (keywordSubrefsNew >> parens (SubrefsExpr True <$> expr <* comma <*> expr))--suprefsExpr :: Parser EgisonExpr-suprefsExpr = (keywordSuprefs >> SuprefsExpr False <$> expr <*> expr)-               <|> (keywordSuprefsNew >> SuprefsExpr True <$> expr <*> expr)--userrefsExpr :: Parser EgisonExpr-userrefsExpr = (do keywordUserrefs-                   xs <- parens $ sepEndBy expr comma-                   case xs of-                     [x, y] -> return $ UserrefsExpr False x y-                     _      -> unexpected "number of arguments (expected 2)")-                <|> (do keywordUserrefsNew-                        xs <- parens $ sepEndBy expr comma-                        case xs of-                          [x, y] -> return $ UserrefsExpr True x y-                          _ -> unexpected "number of arguments (expected 2)")---- Patterns--pattern :: Parser EgisonPattern-pattern = P.lexeme lexer-            (try (buildExpressionParser table pattern')-             <|> try pattern'-             <?> "expression")-- where-  table = [ [unary "!" AssocRight, unary "not" AssocRight]-          , [binary'' "^" PowerPat AssocLeft]-          , [binary' "*" MultPat AssocRight, binary'' "/" DivPat AssocRight]-          , [binary' "+" PlusPat AssocRight]-          , [binary "<:>" "cons" AssocRight]-          , [binary' "and" AndPat AssocLeft, binary' "or" OrPat AssocLeft]-          , [binary "<++>" "join" AssocRight]-          ]-  unary op assoc = Prefix (try $ inSpaces (string op) >> return NotPat)-  binary op name = Infix (try $ inSpaces (string op) >> return (\x y -> InductivePat name [x, y]))-  binary' op epr = Infix (try $ inSpaces (string op) >> return (\x y -> epr [x, y]))-  binary'' op epr = Infix (try $ inSpaces (string op) >> return epr)--pattern' :: Parser EgisonPattern-pattern' = wildCard-           <|> contPat-           <|> try indexedPat-           <|> patVar-           <|> try loopPat-           <|> try pApplyPat-           <|> try dApplyPat-           <|> try varPat-           <|> valuePat-           <|> predPat-           <|> try tuplePat-           <|> inductivePat-           <|> letPat-           <|> parens pattern--pattern'' :: Parser EgisonPattern-pattern'' = wildCard-            <|> patVar-            <|> valuePat--wildCard :: Parser EgisonPattern-wildCard = reservedOp "_" >> pure WildCard--indexedPat :: Parser EgisonPattern-indexedPat = IndexedPat <$> (patVar <|> varPat) <*> many1 (try $ char '_' >> term')--patVar :: Parser EgisonPattern-patVar = char '$' >> PatVar <$> identVarWithoutIndex--varPat :: Parser EgisonPattern-varPat = char '\'' >> VarPat <$> ident--valuePat :: Parser EgisonPattern-valuePat = ValuePat <$> expr--predPat :: Parser EgisonPattern-predPat = char '?' >> PredPat <$> expr--letPat :: Parser EgisonPattern-letPat = keywordLet >> LetPat <$> bindings <* keywordLetIn <*> pattern--tuplePat :: Parser EgisonPattern-tuplePat = TuplePat <$> parens ((:) <$> pattern <* comma <*> sepEndBy1 pattern comma)--inductivePat :: Parser EgisonPattern-inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace--contPat :: Parser EgisonPattern-contPat = keywordCont >> pure ContPat--pApplyPat :: Parser EgisonPattern-pApplyPat = PApplyPat <$> expr <*> brackets (sepEndBy pattern comma)--dApplyPat :: Parser EgisonPattern-dApplyPat = DApplyPat <$> pattern'' <*> parens (sepEndBy pattern comma)--loopPat :: Parser EgisonPattern-loopPat = keywordLoop >> parens (char '$' >> LoopPat <$> identVarWithoutIndex <*> (comma >> loopRange) <*> (comma >> pattern) <*> (comma >> option (NotPat WildCard) pattern))--loopRange :: Parser LoopRange-loopRange = parens (try (LoopRange <$> expr <* comma <*> expr <*> option WildCard (comma >> pattern))-                 <|> (do s <- expr-                         comma-                         ep <- option WildCard pattern-                         return (LoopRange s (ApplyExpr (stringToVarExpr "from") (ApplyExpr (stringToVarExpr "-'") (TupleExpr [s, IntegerExpr 1]))) ep)))---- Constants--constantExpr :: Parser EgisonExpr-constantExpr = stringExpr-                 <|> boolExpr-                 <|> try charExpr-                 <|> try floatExpr-                 <|> try integerExpr-                 <|> (keywordSomething $> SomethingExpr)-                 <|> (keywordUndefined $> UndefinedExpr)-                 <?> "constant"--charExpr :: Parser EgisonExpr-charExpr = CharExpr <$> oneChar--stringExpr :: Parser EgisonExpr-stringExpr = StringExpr . T.pack <$> stringLiteral--boolExpr :: Parser EgisonExpr-boolExpr = BoolExpr <$> boolLiteral--floatExpr :: Parser EgisonExpr-floatExpr = do-  (x,y) <- try ((,) <$> floatLiteral <*> (sign' <*> positiveFloatLiteral) <* char 'i')-            <|> try ((,) 0 <$> floatLiteral <* char 'i')-            <|> try ((, 0) <$> floatLiteral)-  return $ FloatExpr x y--integerExpr :: Parser EgisonExpr-integerExpr = IntegerExpr <$> integerLiteral'--integerLiteral' :: Parser Integer-integerLiteral' = sign <*> positiveIntegerLiteral--positiveIntegerLiteral :: Parser Integer-positiveIntegerLiteral = read <$> many1 digit--positiveFloatLiteral :: Parser Double-positiveFloatLiteral = do-  n <- positiveIntegerLiteral-  char '.'-  mStr <- many1 digit-  let m = read mStr-  let l = m % (10 ^ fromIntegral (length mStr))-  return (fromRational (fromIntegral n + l) :: Double)--floatLiteral :: Parser Double-floatLiteral = sign <*> positiveFloatLiteral------- Tokens-----egisonDef :: P.GenLanguageDef String () Identity-egisonDef =-  P.LanguageDef { P.commentStart       = "#|"-                , P.commentEnd         = "|#"-                , P.commentLine        = ";"-                , P.identStart         = letter <|> symbol1-                , P.identLetter        = letter <|> digit <|> symbol0 <|> symbol2-                , P.opStart            = symbol1-                , P.opLetter           = symbol0 <|> symbol1-                , P.reservedNames      = reservedKeywords-                , P.reservedOpNames    = reservedOperators-                , P.nestedComments     = True-                , P.caseSensitive      = True }--symbol0 = oneOf "/."-symbol1' = oneOf "∂∇"-symbol1 = symbol1' <|> oneOf "+-"-symbol2 = symbol1' <|> oneOf "'!?"--lexer :: P.GenTokenParser String () Identity-lexer = P.makeTokenParser egisonDef--reservedKeywords :: [String]-reservedKeywords =-  [ "define"-  , "set!"-  , "test"-  , "loadFile"-  , "load"-  , "if"-  , "then"-  , "else"-  , "as"-  , "seq"-  , "apply"-  , "capply"-  , "lambda"-  , "memoizedLambda"-  , "cambda"-  , "procedure"-  , "macro"-  , "patternFunction"-  , "letrec"-  , "let"-  , "let*"-  , "in"-  , "withSymbols"-  , "loop"-  , "matchAll"-  , "matchAllDFS"-  , "matchAllLambda"-  , "match"-  , "matchLambda"-  , "matcher"-  , "do"-  , "io"-  , "something"-  , "undefined"-  , "algebraicDataMatcher"-  , "generateTensor"-  , "tensor"-  , "contract"-  , "subrefs"-  , "subrefs!"-  , "suprefs"-  , "suprefs!"-  , "userRefs"-  , "userRefs!"-  , "function"]--reservedOperators :: [String]-reservedOperators =-  [ "$"-  , "_"-  , "^"-  , "&"-  , "|*"-  , "("-  , ")"-  , "->"-  , "`"-  , "=="-  , "="---  , "'"---  , "~"---  , "!"---  , ","---  , "@"-  , "..."]--reserved :: String -> Parser ()-reserved = P.reserved lexer--reservedOp :: String -> Parser ()-reservedOp = P.reservedOp lexer--keywordDefine               = reserved "def"-keywordSet                  = reserved "set!"-keywordTest                 = reserved "test"-keywordLoadFile             = reserved "loadFile"-keywordLoad                 = reserved "load"-keywordIf                   = reserved "if"-keywordThen                 = reserved "then"-keywordElse                 = reserved "else"-keywordAs                   = reserved "as"-keywordSeq                  = reserved "seq"-keywordApply                = reserved "apply"-keywordCApply               = reserved "capply"-keywordLambda               = reserved "lambda"-keywordMemoizedLambda       = reserved "memoizedLambda"-keywordCambda               = reserved "cambda"-keywordProcedure            = reserved "procedure"-keywordMacro                = reserved "macro"-keywordPatternFunction      = reserved "patternFunction"-keywordLetRec               = reserved "letrec"-keywordLet                  = reserved "let"-keywordLetStar              = reserved "let*"-keywordLetIn                = reserved "in"-keywordWithSymbols          = reserved "withSymbols"-keywordLoop                 = reserved "loop"-keywordCont                 = reserved "..."-keywordMatchAll             = reserved "matchAll"-keywordMatchAllDFS          = reserved "matchAllDFS"-keywordMatchAllLambda       = reserved "matchAllLambda"-keywordMatch                = reserved "match"-keywordMatchLambda          = reserved "matchLambda"-keywordMatcher              = reserved "matcher"-keywordDo                   = reserved "do"-keywordIo                   = reserved "io"-keywordSomething            = reserved "something"-keywordUndefined            = reserved "undefined"-keywordAlgebraicDataMatcher = reserved "algebraicDataMatcher"-keywordGenerateTensor       = reserved "generateTensor"-keywordTensor               = reserved "tensor"-keywordTensorContract       = reserved "contract"-keywordSubrefs              = reserved "subrefs"-keywordSubrefsNew           = reserved "subrefs!"-keywordSuprefs              = reserved "suprefs"-keywordSuprefsNew           = reserved "suprefs!"-keywordUserrefs             = reserved "userRefs"-keywordUserrefsNew          = reserved "userRefs!"-keywordFunction             = reserved "function"--sign :: Num a => Parser (a -> a)-sign = (char '-' >> return negate)-   <|> (char '+' >> return id)-   <|> return id--sign' :: Num a => Parser (a -> a)-sign' = (char '-' >> return negate)-    <|> (char '+' >> return id)--integerLiteral :: Parser Integer-integerLiteral = sign <*> P.natural lexer--stringLiteral :: Parser String-stringLiteral = P.stringLiteral lexer--charLiteral :: Parser Char-charLiteral = P.charLiteral lexer--oneChar :: Parser Char-oneChar = do-  string "c#"-  x <- (char '\\' >> anyChar >>= (\x -> return ['\\', x])) <|> (anyChar >>= (\x -> return [x]))-  return $ doParse' charLiteral $ "'" ++ x ++ "'"--boolLiteral :: Parser Bool-boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False)--whiteSpace :: Parser ()-whiteSpace = P.whiteSpace lexer--parens :: Parser a -> Parser a-parens = P.parens lexer--brackets :: Parser a -> Parser a-brackets = P.brackets lexer--braces :: Parser a -> Parser a-braces = P.braces lexer--angles :: Parser a -> Parser a-angles = P.angles lexer--colon :: Parser String-colon = P.colon lexer--comma :: Parser String-comma = P.comma lexer--dot :: Parser String-dot = P.dot lexer--ident :: Parser String-ident = do-  idt <- P.identifier lexer-  let (f, s) = splitLast idt '.'-  case s of-    [] -> return f-    x:xs | isLower x -> return $ f ++ map toLower (intercalate "-" $ split (startsWithOneOf ['A'..'Z']) s)-         | otherwise -> return $ f ++ [x] ++ map toLower (intercalate "-" $ split (startsWithOneOf ['A'..'Z']) xs)- where-  splitLast list elem = let (f, s) = span (/= elem) $ reverse list-                          in (reverse s, reverse f)--identVar :: Parser Var-identVar = P.lexeme lexer (do-  name <- ident-  is <- many indexType-  return $ Var (splitOn "." name) is)--identVarWithoutIndex :: Parser Var-identVarWithoutIndex = stringToVar <$> ident--identVarWithIndices :: Parser VarWithIndices-identVarWithIndices = P.lexeme lexer (do-  name <- ident-  is <- many indexForVar-  return $ VarWithIndices (splitOn "." name) is)--indexForVar :: Parser (Index String)-indexForVar = try (char '~' >> Superscript <$> ident)-        <|> try (char '_' >> Subscript <$> ident)--indexType :: Parser (Index ())-indexType = try (char '~' >> return (Superscript ()))-        <|> try (char '_' >> return (Subscript ()))--upperName :: Parser String-upperName = P.lexeme lexer upperName'--upperName' :: Parser String-upperName' = (:) <$> upper <*> option "" ident- where-  upper :: Parser Char-  upper = satisfy isUpper--lowerName :: Parser String-lowerName = P.lexeme lexer lowerName'--lowerName' :: Parser String-lowerName' = (:) <$> lower <*> option "" ident- where-  lower :: Parser Char-  lower = satisfy isLower+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE MultiWayIf       #-}++{- |+Module      : Language.Egison.ParserNonS+Copyright   : Satoshi Egi+Licence     : MIT++This module provides the new parser of Egison.+-}++module Language.Egison.ParserNonS+       (+       -- * Parse a string+         readTopExprs+       , readTopExpr+       , readExprs+       , readExpr+       , parseTopExprs+       , parseTopExpr+       , parseExprs+       , parseExpr+       -- * Parse a file+       , loadLibraryFile+       , loadFile+       ) where++import           Control.Applicative            (pure, (*>), (<$>), (<$), (<*), (<*>))+import           Control.Monad.Except           (liftIO, throwError)+import           Control.Monad.State            (unless)+import           Prelude                        hiding (mapM)++import           System.Directory               (doesFileExist, getHomeDirectory)++import           Data.Functor                   (($>))+import           Data.List                      (find)+import           Data.Maybe                     (fromJust, isJust)+import           Data.Traversable               (mapM)++import           Control.Monad.Combinators.Expr+import           Text.Megaparsec+import           Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer     as L+import           Text.Megaparsec.Debug          (dbg)+import           Text.Megaparsec.Pos            (Pos)++import           Data.Text                      (pack)++import           Language.Egison.Desugar+import           Language.Egison.Types+import           Paths_egison                   (getDataFileName)++readTopExprs :: String -> EgisonM [EgisonTopExpr]+readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs++readTopExpr :: String -> EgisonM EgisonTopExpr+readTopExpr = either throwError desugarTopExpr . parseTopExpr++readExprs :: String -> EgisonM [EgisonExpr]+readExprs = either throwError (mapM desugarExpr) . parseExprs++readExpr :: String -> EgisonM EgisonExpr+readExpr = either throwError desugarExpr . parseExpr++parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = doParse $ sc >> topExpr++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = doParse $ many (L.nonIndented sc expr) <* eof++parseExpr :: String -> Either EgisonError EgisonExpr+parseExpr = doParse $ sc >> expr++-- |Load a libary file+loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile file = do+  homeDir <- liftIO getHomeDirectory+  doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file+  if doesExist+    then loadFile $ homeDir ++ "/.egison/" ++ file+    else liftIO (getDataFileName file) >>= loadFile++-- |Load a file+loadFile :: FilePath -> EgisonM [EgisonTopExpr]+loadFile file = do+  doesExist <- liftIO $ doesFileExist file+  unless doesExist $ throwError $ Default ("file does not exist: " ++ file)+  input <- liftIO $ readUTF8File file+  exprs <- readTopExprs $ shebang input+  concat <$> mapM  recursiveLoad exprs+ where+  recursiveLoad (Load file)     = loadLibraryFile file+  recursiveLoad (LoadFile file) = loadFile file+  recursiveLoad expr            = return [expr]+  shebang :: String -> String+  shebang ('#':'!':cs) = ';':'#':'!':cs+  shebang cs           = cs++--+-- Parser+--++type Parser = Parsec CustomError String++data CustomError+  = IllFormedPointFreeExpr EgisonBinOp EgisonBinOp+  | IllFormedDefine+  deriving (Eq, Ord)++instance ShowErrorComponent CustomError where+  showErrorComponent (IllFormedPointFreeExpr op op') =+    "The operator " ++ info op ++ " must have lower precedence than " ++ info op'+    where+      info op =+         "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"+  showErrorComponent IllFormedDefine =+    "Ill-formed definition syntax."+++doParse :: Parser a -> String -> Either EgisonError a+doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input+  where+    fromParsecError :: ParseErrorBundle String CustomError -> EgisonError+    fromParsecError = Parser . errorBundlePretty++--+-- Expressions+--++topExpr :: Parser EgisonTopExpr+topExpr = Load     <$> (keywordLoad >> stringLiteral)+      <|> LoadFile <$> (keywordLoadFile >> stringLiteral)+      <|> defineOrTestExpr+      <?> "toplevel expression"++defineOrTestExpr :: Parser EgisonTopExpr+defineOrTestExpr = do+  e <- expr+  (do symbol "="+      body <- expr+      return $ convertToDefine e body)+      <|> return (Test e)+  where+    -- TODO: Throw IllFormedDefine in pattern match failure.+    -- first 2 cases are the most common ones+    convertToDefine :: EgisonExpr -> EgisonExpr -> EgisonTopExpr+    convertToDefine (VarExpr var) body = Define var body+    convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) body =+      Define var (LambdaExpr (map exprToArg args) body)+    convertToDefine e@(BinaryOpExpr op _ _) body+      | repr op == "*" || repr op == "%" =+        case exprToArgs e of+          ScalarArg var : args -> Define (Var [var] []) (LambdaExpr args body)++    exprToArg :: EgisonExpr -> Arg+    exprToArg (VarExpr (Var [x] [])) = ScalarArg x++    exprToArgs :: EgisonExpr -> [Arg]+    exprToArgs (VarExpr (Var [x] [])) = [ScalarArg x]+    exprToArgs (ApplyExpr func (TupleExpr args)) =+      exprToArgs func ++ map exprToArg args+    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" =+      case exprToArgs rhs of+        ScalarArg x : xs -> exprToArgs lhs ++ InvertedScalarArg x : xs+    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" =+      case exprToArgs rhs of+        ScalarArg x : xs -> exprToArgs lhs ++ TensorArg x : xs++expr :: Parser EgisonExpr+expr = ifExpr+   <|> patternMatchExpr+   <|> lambdaExpr+   <|> letExpr+   <|> withSymbolsExpr+   <|> doExpr+   <|> matcherExpr+   <|> algebraicDataMatcherExpr+   <|> memoizedLambdaExpr+   <|> procedureExpr+   <|> macroExpr+   <|> generateTensorExpr+   <|> tensorExpr+   <|> functionExpr+   <|> opExpr+   <?> "expression"++-- Also parses atomExpr+opExpr :: Parser EgisonExpr+opExpr = do+  pos <- L.indentLevel+  makeExprParser atomOrApplyExpr (makeTable pos)+  where+    makeTable :: Pos -> [[Operator Parser EgisonExpr]]+    makeTable pos =+      let unary  sym = UnaryOpExpr  <$> operator sym+          binary sym = do+            op <- try (L.indentGuard sc GT pos >> binOpLiteral sym <* notFollowedBy (symbol ")"))+            return $ BinaryOpExpr op+       in+          [ [ Prefix (unary  "-" )+            , Prefix (unary  "!" ) ]+          -- 8+          , [ InfixL (binary "^" ) ]+          -- 7+          , [ InfixL (binary "*" )+            , InfixL (binary "/" )+            , InfixL (binary "%" ) ]+          -- 6+          , [ InfixL (binary "+" )+            , InfixL (binary "-" ) ]+          -- 5+          , [ InfixR (binary ":" )+            , InfixR (binary "++") ]+          -- 4+          , [ InfixL (binary "==")+            , InfixL (binary "<=")+            , InfixL (binary "<" )+            , InfixL (binary ">=")+            , InfixL (binary ">" ) ]+          -- 3+          , [ InfixR (binary "&&") ]+          -- 2+          , [ InfixR (binary "||") ]+          ]++ifExpr :: Parser EgisonExpr+ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr++patternMatchExpr :: Parser EgisonExpr+patternMatchExpr = makeMatchExpr keywordMatch       MatchExpr+               <|> makeMatchExpr keywordMatchDFS    MatchDFSExpr+               <|> makeMatchExpr keywordMatchAll    MatchAllExpr+               <|> makeMatchExpr keywordMatchAllDFS MatchAllDFSExpr+               <?> "pattern match expression"+  where+    makeMatchExpr keyword ctor = ctor <$> (keyword >> expr)+                                      <*> (keywordAs >> expr)+                                      <*> (keywordWith >> matchClauses1)++-- Parse more than 1 match clauses.+matchClauses1 :: Parser [MatchClause]+matchClauses1 = do+  pos <- L.indentLevel+  -- If the first bar '|' is missing, then it is expected to have only one match clause.+  (lookAhead (symbol "|") >> some (matchClause pos)) <|> (:[]) <$> matchClauseWithoutBar+  where+    matchClauseWithoutBar :: Parser MatchClause+    matchClauseWithoutBar = (,) <$> pattern <*> (symbol "->" >> expr)++    matchClause :: Pos -> Parser MatchClause+    matchClause pos = (,) <$> (L.indentGuard sc EQ pos >> symbol "|" >> pattern) <*> (symbol "->" >> expr)++lambdaExpr :: Parser EgisonExpr+lambdaExpr = symbol "\\" >> (+      makeMatchLambdaExpr keywordMatch    MatchLambdaExpr+  <|> makeMatchLambdaExpr keywordMatchAll MatchAllLambdaExpr+  <|> try (LambdaExpr <$> some arg <*> (symbol "->" >> expr))+  <|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern))+  <?> "lambda or pattern function expression"+  where+    makeMatchLambdaExpr keyword ctor = do+      matcher <- keyword >> keywordAs >> expr+      clauses <- keywordWith >> matchClauses1+      return $ ctor matcher clauses++arg :: Parser Arg+arg = InvertedScalarArg <$> (symbol "*" >> lowerId)+  <|> TensorArg         <$> (symbol "%" >> lowerId)+  <|> ScalarArg         <$> lowerId+  <?> "argument"++letExpr :: Parser EgisonExpr+letExpr = do+  pos   <- keywordLet >> L.indentLevel+  binds <- some (L.indentGuard sc EQ pos *> binding)+  body  <- keywordIn >> expr+  return $ LetRecExpr binds body++binding :: Parser BindingExpr+binding = do+  (vars, args) <- (,[]) <$> parens (sepBy varLiteral comma)+              <|> do var <- varLiteral+                     args <- many arg+                     return ([var], args)+  body <- symbol "=" >> expr+  return $ case args of+             [] -> (vars, body)+             _  -> (vars, LambdaExpr args body)++withSymbolsExpr :: Parser EgisonExpr+withSymbolsExpr = WithSymbolsExpr <$> (keywordWithSymbols >> brackets (sepBy lowerId comma)) <*> expr++doExpr :: Parser EgisonExpr+doExpr = do+  pos   <- keywordDo >> L.indentLevel+  stmts <- some $ L.indentGuard sc EQ pos >> statement+  ret   <- option (makeApply' "return" []) $ L.indentGuard sc EQ pos >> expr+  return $ DoExpr stmts ret+  where+    statement :: Parser BindingExpr+    statement = (keywordLet >> binding) <|> ([],) <$> expr++matcherExpr :: Parser EgisonExpr+matcherExpr = do+  keywordMatcher+  pos  <- L.indentLevel+  -- In matcher expression, the first '|' (bar) is indispensable+  info <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)+  return $ MatcherExpr info+  where+    patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+    patternDef = do+      pp <- ppPattern+      returnMatcher <- keywordAs >> expr <* keywordWith+      pos <- L.indentLevel+      datapat <- some (L.indentGuard sc EQ pos >> symbol "|" >> dataCases)+      return (pp, returnMatcher, datapat)++    dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)+    dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)++algebraicDataMatcherExpr :: Parser EgisonExpr+algebraicDataMatcherExpr = do+  keywordAlgebraicDataMatcher+  pos  <- L.indentLevel+  defs <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)+  return $ AlgebraicDataMatcherExpr defs+  where+    patternDef :: Parser (String, [EgisonExpr])+    patternDef = do+      pos <- L.indentLevel+      patternCtor <- lowerId+      args <- many (L.indentGuard sc GT pos >> atomExpr)+      return (patternCtor, args)++memoizedLambdaExpr :: Parser EgisonExpr+memoizedLambdaExpr = MemoizedLambdaExpr <$> (keywordMemoizedLambda >> many lowerId) <*> (symbol "->" >> expr)++procedureExpr :: Parser EgisonExpr+procedureExpr = ProcedureExpr <$> (keywordProcedure >> many lowerId) <*> (symbol "->" >> expr)++macroExpr :: Parser EgisonExpr+macroExpr = MacroExpr <$> (keywordMacro >> many lowerId) <*> (symbol "->" >> expr)++generateTensorExpr :: Parser EgisonExpr+generateTensorExpr = GenerateTensorExpr <$> (keywordGenerateTensor >> atomExpr) <*> atomExpr++tensorExpr :: Parser EgisonExpr+tensorExpr = TensorExpr <$> (keywordTensor >> atomExpr) <*> atomExpr+                        <*> option (CollectionExpr []) atomExpr+                        <*> option (CollectionExpr []) atomExpr++functionExpr :: Parser EgisonExpr+functionExpr = FunctionExpr <$> (keywordFunction >> parens (sepBy expr comma))++collectionExpr :: Parser EgisonExpr+collectionExpr = symbol "[" >> (try betweenOrFromExpr <|> elementsExpr)+  where+    betweenOrFromExpr = do+      start <- expr <* symbol ".."+      end   <- optional expr <* symbol "]"+      case end of+        Just end' -> return $ makeApply' "between" [start, end']+        Nothing   -> return $ makeApply' "from" [start]++    elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> expr) comma <* symbol "]")++tupleOrParenExpr :: Parser EgisonExpr+tupleOrParenExpr = do+  elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (pointFreeExpr <* symbol ")")+  case elems of+    [x] -> return x+    _   -> return $ TupleExpr elems+  where+    pointFreeExpr :: Parser [EgisonExpr]+    pointFreeExpr =+          (do op   <- try . choice $ map (binOpLiteral . repr) reservedBinops+              rarg <- optional expr+              -- TODO(momohatt): Take associativity of operands into account+              case rarg of+                Just (BinaryOpExpr op' _ _) | priority op >= priority op' ->+                  customFailure (IllFormedPointFreeExpr op op')+                _ -> return [makeLambda op Nothing rarg])+      <|> (do larg <- opExpr+              op   <- choice $ map (binOpLiteral . repr) reservedBinops+              case larg of+                BinaryOpExpr op' _ _ | priority op >= priority op' ->+                  customFailure (IllFormedPointFreeExpr op op')+                _ -> return [makeLambda op (Just larg) Nothing])++    makeLambda :: EgisonBinOp -> Maybe EgisonExpr -> Maybe EgisonExpr -> EgisonExpr+    makeLambda op Nothing Nothing =+      LambdaExpr [ScalarArg ":x", ScalarArg ":y"]+                 (BinaryOpExpr op (stringToVarExpr ":x") (stringToVarExpr ":y"))+    makeLambda op Nothing (Just rarg) =+      LambdaExpr [ScalarArg ":x"] (BinaryOpExpr op (stringToVarExpr ":x") rarg)+    makeLambda op (Just larg) Nothing =+      LambdaExpr [ScalarArg ":y"] (BinaryOpExpr op larg (stringToVarExpr ":y"))++arrayExpr :: Parser EgisonExpr+arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)++vectorExpr :: Parser EgisonExpr+vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma)++hashExpr :: Parser EgisonExpr+hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)+  where+    hashBraces = between (symbol "{|") (symbol "|}")+    hashElem = brackets $ (,) <$> expr <*> (comma >> expr)++index :: Parser (Index EgisonExpr)+index = SupSubscript <$> (string "~_" >> atomExpr')+    <|> try (char '_' >> subscript)+    <|> try (char '~' >> superscript)+    <|> try (Userscript <$> (char '|' >> atomExpr'))+    <?> "index"+  where+    subscript = do+      e1 <- atomExpr'+      e2 <- optional (string "..._" >> atomExpr')+      case e2 of+        Nothing  -> return $ Subscript e1+        Just e2' -> return $ MultiSubscript e1 e2'+    superscript = do+      e1 <- atomExpr'+      e2 <- optional (string "...~" >> atomExpr')+      case e2 of+        Nothing  -> return $ Superscript e1+        Just e2' -> return $ MultiSuperscript e1 e2'++atomOrApplyExpr :: Parser EgisonExpr+atomOrApplyExpr = do+  pos <- L.indentLevel+  func <- atomExpr+  args <- many (L.indentGuard sc GT pos *> atomExpr)+  return $ case args of+             [] -> func+             _  -> makeApply func args++atomExpr :: Parser EgisonExpr+atomExpr = do+  e <- atomExpr'+  -- TODO(momohatt): "..." (override of index) collides with ContPat+  indices <- many index+  return $ case indices of+             [] -> e+             _  -> IndexedExpr False e indices++-- atom expr without index+atomExpr' :: Parser EgisonExpr+atomExpr' = constantExpr+        <|> VarExpr <$> varLiteral+        <|> (\x -> InductiveDataExpr x []) <$> upperId+        <|> vectorExpr     -- must come before collectionExpr+        <|> arrayExpr      -- must come before tupleOrParenExpr+        <|> collectionExpr+        <|> tupleOrParenExpr+        <|> hashExpr+        <|> QuoteExpr <$> (char '\'' >> atomExpr')+        <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')+        <?> "atomic expression"++constantExpr :: Parser EgisonExpr+constantExpr = numericExpr+           <|> BoolExpr <$> boolLiteral+           <|> CharExpr <$> try charLiteral        -- try for quoteExpr+           <|> StringExpr . pack <$> stringLiteral+           <|> SomethingExpr <$ keywordSomething+           <|> UndefinedExpr <$ keywordUndefined++numericExpr :: Parser EgisonExpr+numericExpr = FloatExpr <$> try positiveFloatLiteral+          <|> IntegerExpr <$> positiveIntegerLiteral+          <?> "numeric expression"+--+-- Pattern+--++pattern :: Parser EgisonPattern+pattern = letPattern+      <|> loopPattern+      <|> opPattern+      <?> "pattern"++letPattern :: Parser EgisonPattern+letPattern = do+  pos   <- keywordLet >> L.indentLevel+  binds <- some (L.indentGuard sc EQ pos *> binding)+  body  <- keywordIn >> pattern+  return $ LetPat binds body++loopPattern :: Parser EgisonPattern+loopPattern = do+  keywordLoop+  iter <- patVarLiteral+  range <- loopRange+  loopBody <- optional (symbol "|") >> pattern+  loopEnd <- symbol "|" >> pattern+  return $ LoopPat iter range loopBody loopEnd+  where+    loopRange :: Parser LoopRange+    loopRange =+      parens $ do start <- expr+                  ends  <- option (defaultEnds start) (try $ comma >> expr)+                  as    <- option WildCard (comma >> pattern)+                  return $ LoopRange start ends as++    defaultEnds s =+      ApplyExpr (stringToVarExpr "from")+                (makeApply (stringToVarExpr "-'") [s, IntegerExpr 1])++seqPattern :: Parser EgisonPattern+seqPattern = do+  pats <- braces $ sepBy pattern comma+  return $ foldr SeqConsPat SeqNilPat pats++opPattern :: Parser EgisonPattern+opPattern = makeExprParser applyOrAtomPattern table+  where+    table :: [[Operator Parser EgisonPattern]]+    table =+      [ [ Prefix (NotPat <$ symbol "!") ]+      -- 5+      , [ InfixR (inductive2 "cons" ":" )+        , InfixR (inductive2 "join" "++") ]+      -- 3+      , [ InfixR (binary AndPat "&&") ]+      -- 2+      , [ InfixR (binary OrPat  "||") ]+      ]+    inductive2 name sym = (\x y -> InductivePat name [x, y]) <$ patOperator sym+    binary name sym     = (\x y -> name [x, y]) <$ patOperator sym++applyOrAtomPattern :: Parser EgisonPattern+applyOrAtomPattern = do+  pos <- L.indentLevel+  func <- atomPattern+  args <- many (L.indentGuard sc GT pos *> atomPattern)+  case (func, args) of+    (_,                 []) -> return func+    (InductivePat x [], _)  -> return $ InductivePat x args++atomPattern :: Parser EgisonPattern+atomPattern = do+  pat     <- atomPattern'+  indices <- many . try $ char '_' >> atomExpr'+  return $ case indices of+             [] -> pat+             _  -> IndexedPat pat indices++-- atomic pattern without index+atomPattern' :: Parser EgisonPattern+atomPattern' = WildCard <$   symbol "_"+           <|> PatVar   <$> patVarLiteral+           <|> ValuePat <$> (char '#' >> atomExpr)+           <|> InductivePat "nil" [] <$ (symbol "[" >> symbol "]")+           <|> InductivePat <$> lowerId <*> pure []+           <|> VarPat   <$> (char '~' >> lowerId)+           <|> PredPat  <$> (symbol "?" >> atomExpr)+           <|> ContPat  <$ symbol "..."+           <|> makeTupleOrParen pattern TuplePat+           <|> seqPattern+           <|> LaterPatVar <$ symbol "@"+           <?> "atomic pattern"++ppPattern :: Parser PrimitivePatPattern+ppPattern = PPInductivePat <$> lowerId <*> many ppAtom+        <|> makeExprParser ppAtom table+        <?> "primitive pattern pattern"+  where+    table :: [[Operator Parser PrimitivePatPattern]]+    table =+      [ [ InfixR (inductive2 "cons" ":" )+        , InfixR (inductive2 "join" "++") ]+      ]+    inductive2 name sym = (\x y -> PPInductivePat name [x, y]) <$ operator sym++    ppAtom :: Parser PrimitivePatPattern+    ppAtom = PPWildCard <$ symbol "_"+         <|> PPPatVar   <$ symbol "$"+         <|> PPValuePat <$> (symbol "#$" >> lowerId)+         <|> PPInductivePat "nil" [] <$ brackets sc+         <|> makeTupleOrParen ppPattern PPTuplePat++pdPattern :: Parser PrimitiveDataPattern+pdPattern = PDInductivePat <$> upperId <*> many pdAtom+        <|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom+        <|> makeExprParser pdAtom table+        <?> "primitive data pattern"+  where+    table :: [[Operator Parser PrimitiveDataPattern]]+    table =+      [ [ InfixR (PDConsPat <$ symbol ":") ]+      ]+    pdAtom :: Parser PrimitiveDataPattern+    pdAtom = PDWildCard    <$ symbol "_"+         <|> PDPatVar      <$> (symbol "$" >> lowerId)+         <|> PDConstantPat <$> constantExpr+         <|> PDEmptyPat    <$ (symbol "[" >> symbol "]")+         <|> makeTupleOrParen pdPattern PDTuplePat++--+-- Tokens+--++-- space comsumer+sc :: Parser ()+sc = L.space space1 lineCmnt blockCmnt+  where+    lineCmnt  = L.skipLineComment "--"+    blockCmnt = L.skipBlockCommentNested "{-" "-}"++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++positiveIntegerLiteral :: Parser Integer+positiveIntegerLiteral = lexeme L.decimal+                     <?> "unsinged integer"++charLiteral :: Parser Char+charLiteral = between (char '\'') (symbol "\'") L.charLiteral+          <?> "character"++stringLiteral :: Parser String+stringLiteral = char '\"' *> manyTill L.charLiteral (symbol "\"")+          <?> "string"++boolLiteral :: Parser Bool+boolLiteral = reserved "True"  $> True+          <|> reserved "False" $> False+          <?> "boolean"++positiveFloatLiteral :: Parser Double+positiveFloatLiteral = lexeme L.float+           <?> "unsigned float"++varLiteral :: Parser Var+varLiteral = stringToVar <$> lowerId++patVarLiteral :: Parser Var+patVarLiteral = stringToVar <$> (char '$' >> lowerId)++binOpLiteral :: String -> Parser EgisonBinOp+binOpLiteral sym = do+  wedge <- optional (char '!')+  opSym <- operator sym+  let opInfo = fromJust $ find ((== opSym) . repr) reservedBinops+  return $ opInfo { isWedge = isJust wedge }++reserved :: String -> Parser ()+reserved w = (lexeme . try) (string w *> notFollowedBy identChar)++symbol :: String -> Parser String+symbol sym = try $ L.symbol sc sym++operator :: String -> Parser String+operator sym = try $ string sym <* notFollowedBy opChar <* sc++patOperator :: String -> Parser String+patOperator sym = try $ string sym <* notFollowedBy patOpChar <* sc++-- Characters that could consist expression operators.+opChar :: Parser Char+opChar = oneOf "%^&*-+\\|:<>.?/'!#@$"++-- Characters that could consist pattern operators.+-- ! # @ $ are omitted because they can appear at the beginning of atomPattern+patOpChar :: Parser Char+patOpChar = oneOf "%^&*-+\\|:<>.?/'"++-- Characters that consist identifiers+identChar :: Parser Char+identChar = alphaNumChar <|> oneOf ['.', '?', '\'']++parens    = between (symbol "(") (symbol ")")+braces    = between (symbol "{") (symbol "}")+brackets  = between (symbol "[") (symbol "]")+comma     = symbol ","++lowerId :: Parser String+lowerId = (lexeme . try) (p >>= check)+  where+    p       = (:) <$> lowerChar <*> many identChar+    check x = if x `elem` lowerReservedWords+                then fail $ "keyword " ++ show x ++ " cannot be an identifier"+                else return x++-- TODO: Deprecate BoolExpr and merge it with InductiveDataExpr+upperId :: Parser String+upperId = (lexeme . try) (p >>= check)+  where+    p       = (:) <$> upperChar <*> many alphaNumChar+    check x = if x `elem` upperReservedWords+                then fail $ "keyword " ++ show x ++ " cannot be an identifier"+                else return x++keywordLoadFile             = reserved "loadFile"+keywordLoad                 = reserved "load"+keywordIf                   = reserved "if"+keywordThen                 = reserved "then"+keywordElse                 = reserved "else"+keywordSeq                  = reserved "seq"+keywordApply                = reserved "apply"+keywordCApply               = reserved "capply"+keywordMemoizedLambda       = reserved "memoizedLambda"+keywordCambda               = reserved "cambda"+keywordProcedure            = reserved "procedure"+keywordMacro                = reserved "macro"+keywordLet                  = reserved "let"+keywordIn                   = reserved "in"+keywordWithSymbols          = reserved "withSymbols"+keywordLoop                 = reserved "loop"+keywordMatch                = reserved "match"+keywordMatchDFS             = reserved "matchDFS"+keywordMatchAll             = reserved "matchAll"+keywordMatchAllDFS          = reserved "matchAllDFS"+keywordAs                   = reserved "as"+keywordWith                 = reserved "with"+keywordMatcher              = reserved "matcher"+keywordDo                   = reserved "do"+keywordIo                   = reserved "io"+keywordSomething            = reserved "something"+keywordUndefined            = reserved "undefined"+keywordAlgebraicDataMatcher = reserved "algebraicDataMatcher"+keywordGenerateTensor       = reserved "generateTensor"+keywordTensor               = reserved "tensor"+keywordTensorContract       = reserved "contract"+keywordSubrefs              = reserved "subrefs"+keywordSubrefsNew           = reserved "subrefs!"+keywordSuprefs              = reserved "suprefs"+keywordSuprefsNew           = reserved "suprefs!"+keywordUserrefs             = reserved "userRefs"+keywordUserrefsNew          = reserved "userRefs!"+keywordFunction             = reserved "function"++upperReservedWords =+  [ "True"+  , "False"+  ]++lowerReservedWords =+  [ "loadFile"+  , "load"+  , "if"+  , "then"+  , "else"+  , "seq"+  , "apply"+  , "capply"+  , "memoizedLambda"+  , "cambda"+  , "procedure"+  , "macro"+  , "let"+  , "in"+  , "withSymbols"+  , "loop"+  , "from"+  , "to"+  , "of"+  , "match"+  , "matchDFS"+  , "matchAll"+  , "matchAllDFS"+  , "as"+  , "with"+  , "matcher"+  , "do"+  , "io"+  , "something"+  , "undefined"+  , "algebraicDataMatcher"+  , "generateTensor"+  , "tensor"+  , "contract"+  , "subrefs"+  , "subrefs!"+  , "suprefs"+  , "suprefs!"+  , "userRefs"+  , "userRefs!"+  , "function"+  ]++--+-- Utils+--++makeTupleOrParen :: Parser a -> ([a] -> a) -> Parser a+makeTupleOrParen parser tupleCtor = do+  elems <- parens $ sepBy parser comma+  case elems of+    [elem] -> return elem+    _      -> return $ tupleCtor elems++makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr+makeApply (InductiveDataExpr x []) xs = InductiveDataExpr x xs+makeApply func xs = ApplyExpr func (TupleExpr xs)++makeApply' :: String -> [EgisonExpr] -> EgisonExpr+makeApply' func xs = ApplyExpr (stringToVarExpr func) (TupleExpr xs)

@@ -1,783 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE MultiWayIf       #-}--{- |-Module      : Language.Egison.ParserNonS2-Copyright   : Satoshi Egi-Licence     : MIT--This module provide Egison parser.--}--module Language.Egison.ParserNonS2-       (-       -- * Parse a string-         readTopExprs-       , readTopExpr-       , readExprs-       , readExpr-       , parseTopExprs-       , parseTopExpr-       , parseExprs-       , parseExpr-       -- * Parse a file-       , loadLibraryFile-       , loadFile-       ) where--import           Control.Applicative            (pure, (*>), (<$>), (<$), (<*), (<*>))-import           Control.Monad.Except           (liftIO, throwError)-import           Control.Monad.State            (unless)-import           Prelude                        hiding (mapM)--import           System.Directory               (doesFileExist, getHomeDirectory)--import           Data.Functor                   (($>))-import           Data.List                      (find)-import           Data.Maybe                     (fromJust, isJust)-import           Data.Traversable               (mapM)--import           Control.Monad.Combinators.Expr-import           Data.Void-import           Text.Megaparsec-import           Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer     as L-import           Text.Megaparsec.Debug          (dbg)-import           Text.Megaparsec.Pos            (Pos)--import           Data.Text                      (pack)--import           Language.Egison.Desugar-import           Language.Egison.Types-import           Paths_egison                   (getDataFileName)--readTopExprs :: String -> EgisonM [EgisonTopExpr]-readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs--readTopExpr :: String -> EgisonM EgisonTopExpr-readTopExpr = either throwError desugarTopExpr . parseTopExpr--readExprs :: String -> EgisonM [EgisonExpr]-readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs--readExpr :: String -> EgisonM EgisonExpr-readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr--parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]-parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof--parseTopExpr :: String -> Either EgisonError EgisonTopExpr-parseTopExpr = doParse $ sc >> topExpr--parseExprs :: String -> Either EgisonError [EgisonExpr]-parseExprs = doParse $ many (L.nonIndented sc expr) <* eof--parseExpr :: String -> Either EgisonError EgisonExpr-parseExpr = doParse $ sc >> expr---- |Load a libary file-loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]-loadLibraryFile file = do-  homeDir <- liftIO getHomeDirectory-  doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file-  if doesExist-    then loadFile $ homeDir ++ "/.egison/" ++ file-    else liftIO (getDataFileName file) >>= loadFile---- |Load a file-loadFile :: FilePath -> EgisonM [EgisonTopExpr]-loadFile file = do-  doesExist <- liftIO $ doesFileExist file-  unless doesExist $ throwError $ Default ("file does not exist: " ++ file)-  input <- liftIO $ readUTF8File file-  exprs <- readTopExprs $ shebang input-  concat <$> mapM  recursiveLoad exprs- where-  recursiveLoad (Load file)     = loadLibraryFile file-  recursiveLoad (LoadFile file) = loadFile file-  recursiveLoad expr            = return [expr]-  shebang :: String -> String-  shebang ('#':'!':cs) = ';':'#':'!':cs-  shebang cs           = cs------- Parser-----type Parser = Parsec CustomError String--data CustomError-  = IllFormedPointFreeExpr EgisonBinOp EgisonBinOp-  deriving (Eq, Ord)--instance ShowErrorComponent CustomError where-  showErrorComponent (IllFormedPointFreeExpr op op') =-    "The operator " ++ info op ++ " must have lower precedence than " ++ info op'-    where-      info op =-         "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"---doParse :: Parser a -> String -> Either EgisonError a-doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input-  where-    fromParsecError :: ParseErrorBundle String CustomError -> EgisonError-    fromParsecError = Parser . errorBundlePretty------- Expressions-----topExpr :: Parser EgisonTopExpr-topExpr = Load     <$> (keywordLoad >> stringLiteral)-      <|> LoadFile <$> (keywordLoadFile >> stringLiteral)-      <|> defineOrTestExpr-      <?> "toplevel expression"--defineOrTestExpr :: Parser EgisonTopExpr-defineOrTestExpr = do-  e <- expr-  (do symbol "="-      body <- expr-      return (convertToDefine e body))-      <|> return (Test e)-  where-    convertToDefine :: EgisonExpr -> EgisonExpr -> EgisonTopExpr-    convertToDefine (VarExpr var) body = Define var body-    convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) body =-      Define var (LambdaExpr (map exprToArg args) body)--    -- TODO(momohatt): Handle other types of arg-    exprToArg :: EgisonExpr -> Arg-    exprToArg (VarExpr (Var [x] [])) = ScalarArg x--expr :: Parser EgisonExpr-expr = ifExpr-   <|> patternMatchExpr-   <|> lambdaExpr-   <|> letExpr-   <|> withSymbolsExpr-   <|> doExpr-   <|> matcherExpr-   <|> algebraicDataMatcherExpr-   <|> memoizedLambdaExpr-   <|> procedureExpr-   <|> macroExpr-   <|> generateTensorExpr-   <|> tensorExpr-   <|> functionExpr-   <|> opExpr-   <?> "expression"---- Also parses atomExpr-opExpr :: Parser EgisonExpr-opExpr = do-  pos <- L.indentLevel-  makeExprParser atomOrApplyExpr (makeTable pos)-  where-    makeTable :: Pos -> [[Operator Parser EgisonExpr]]-    makeTable pos =-      let unary  sym = UnaryOpExpr  <$> operator sym-          binary sym = do-            op <- try (L.indentGuard sc GT pos >> binOpLiteral sym <* notFollowedBy (symbol ")"))-            return $ BinaryOpExpr op-       in-          [ [ Prefix (unary  "-" )-            , Prefix (unary  "!" ) ]-          -- 8-          , [ InfixL (binary "^" ) ]-          -- 7-          , [ InfixL (binary "*" )-            , InfixL (binary "/" )-            , InfixL (binary "%" ) ]-          -- 6-          , [ InfixL (binary "+" )-            , InfixL (binary "-" ) ]-          -- 5-          , [ InfixR (binary ":" )-            , InfixR (binary "++") ]-          -- 4-          , [ InfixL (binary "==")-            , InfixL (binary "<=")-            , InfixL (binary "<" )-            , InfixL (binary ">=")-            , InfixL (binary ">" ) ]-          -- 3-          , [ InfixR (binary "&&") ]-          -- 2-          , [ InfixR (binary "||") ]-          ]--ifExpr :: Parser EgisonExpr-ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr--patternMatchExpr :: Parser EgisonExpr-patternMatchExpr = makeMatchExpr keywordMatch       MatchExpr-               <|> makeMatchExpr keywordMatchDFS    MatchDFSExpr-               <|> makeMatchExpr keywordMatchAll    MatchAllExpr-               <|> makeMatchExpr keywordMatchAllDFS MatchAllDFSExpr-               <?> "pattern match expression"-  where-    makeMatchExpr keyword ctor = do-      tgt     <- keyword >> expr-      matcher <- keywordAs >> expr <* keywordWith-      clauses <- matchClauses1-      return $ ctor tgt matcher clauses---- Parse more than 1 match clauses.--- TODO(momohatt): Require first bar '|' when there are multiple match clauses-matchClauses1 :: Parser [MatchClause]-matchClauses1 = do-  pos <- optional (symbol "|") >> L.indentLevel-  (:) <$> matchClause pos <*> matchClauses pos-  where-    matchClauses :: Pos -> Parser [MatchClause]-    matchClauses pos = try ((:) <$> (symbol "|" >> matchClause pos) <*> matchClauses pos)-                   <|> return []-    matchClause :: Pos -> Parser MatchClause-    matchClause pos = (,) <$> (L.indentGuard sc EQ pos *> pattern) <*> (symbol "->" >> expr)--lambdaExpr :: Parser EgisonExpr-lambdaExpr = symbol "\\" >> (-      makeMatchLambdaExpr keywordMatch    MatchLambdaExpr-  <|> makeMatchLambdaExpr keywordMatchAll MatchAllLambdaExpr-  <|> try (LambdaExpr <$> some arg <*> (symbol "->" >> expr))-  <|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern))-  <?> "lambda or pattern function expression"-  where-    makeMatchLambdaExpr keyword ctor = do-      matcher <- keyword >> keywordAs >> expr-      clauses <- keywordWith >> matchClauses1-      return $ ctor matcher clauses--arg :: Parser Arg-arg = InvertedScalarArg <$> (symbol "*$" >> lowerId)-  <|> TensorArg         <$> (symbol "%"  >> lowerId)-  <|> ScalarArg         <$> lowerId-  <?> "argument"--letExpr :: Parser EgisonExpr-letExpr = do-  pos   <- keywordLet >> L.indentLevel-  binds <- some (L.indentGuard sc EQ pos *> binding)-  body  <- keywordIn >> expr-  return $ LetRecExpr binds body--binding :: Parser BindingExpr-binding = do-  (vars, args) <- (,[]) <$> parens (sepBy varLiteral comma)-              <|> do var <- varLiteral-                     args <- many arg-                     return ([var], args)-  body <- symbol "=" >> expr-  return $ case args of-             [] -> (vars, body)-             _  -> (vars, LambdaExpr args body)--withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = WithSymbolsExpr <$> (keywordWithSymbols >> brackets (sepBy lowerId comma)) <*> expr--doExpr :: Parser EgisonExpr-doExpr = do-  pos   <- keywordDo >> L.indentLevel-  stmts <- some $ L.indentGuard sc EQ pos >> statement-  ret   <- option (makeApply' "return" []) $ L.indentGuard sc EQ pos >> expr-  return $ DoExpr stmts ret-  where-    statement :: Parser BindingExpr-    statement = (keywordLet >> binding) <|> ([],) <$> expr--matcherExpr :: Parser EgisonExpr-matcherExpr = do-  keywordMatcher-  pos  <- L.indentLevel-  -- In matcher expression, the first '|' (bar) is indispensable-  info <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)-  return $ MatcherExpr info-  where-    patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])-    patternDef = do-      pp <- ppPattern-      returnMatcher <- keywordAs >> expr <* keywordWith-      pos <- L.indentLevel-      datapat <- some (L.indentGuard sc EQ pos >> symbol "|" >> dataCases)-      return (pp, returnMatcher, datapat)--    dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)-    dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)--algebraicDataMatcherExpr :: Parser EgisonExpr-algebraicDataMatcherExpr = do-  keywordAlgebraicDataMatcher-  pos  <- L.indentLevel-  defs <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)-  return $ AlgebraicDataMatcherExpr defs-  where-    patternDef :: Parser (String, [EgisonExpr])-    patternDef = do-      pos <- L.indentLevel-      patternCtor <- lowerId-      args <- many (L.indentGuard sc GT pos >> atomExpr)-      return (patternCtor, args)--memoizedLambdaExpr :: Parser EgisonExpr-memoizedLambdaExpr = MemoizedLambdaExpr <$> (keywordMemoizedLambda >> many lowerId) <*> (symbol "->" >> expr)--procedureExpr :: Parser EgisonExpr-procedureExpr = ProcedureExpr <$> (keywordProcedure >> many lowerId) <*> (symbol "->" >> expr)--macroExpr :: Parser EgisonExpr-macroExpr = MacroExpr <$> (keywordMacro >> many lowerId) <*> (symbol "->" >> expr)--generateTensorExpr :: Parser EgisonExpr-generateTensorExpr = GenerateTensorExpr <$> (keywordGenerateTensor >> atomExpr) <*> atomExpr--tensorExpr :: Parser EgisonExpr-tensorExpr = TensorExpr <$> (keywordTensor >> atomExpr) <*> atomExpr-                        <*> option (CollectionExpr []) atomExpr-                        <*> option (CollectionExpr []) atomExpr--functionExpr :: Parser EgisonExpr-functionExpr = FunctionExpr <$> (keywordFunction >> parens (sepBy expr comma))--collectionExpr :: Parser EgisonExpr-collectionExpr = symbol "[" >> (try betweenOrFromExpr <|> elementsExpr)-  where-    betweenOrFromExpr = do-      start <- expr <* symbol ".."-      end   <- optional expr <* symbol "]"-      case end of-        Just end' -> return $ makeApply' "between" [start, end']-        Nothing   -> return $ makeApply' "from" [start]--    elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> expr) comma <* symbol "]")--tupleOrParenExpr :: Parser EgisonExpr-tupleOrParenExpr = do-  elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (pointFreeExpr <* symbol ")")-  case elems of-    [x] -> return x-    _   -> return $ TupleExpr elems-  where-    pointFreeExpr :: Parser [EgisonExpr]-    pointFreeExpr =-          (do op   <- try . choice $ map (binOpLiteral . repr) reservedBinops-              rarg <- optional expr-              case rarg of-                Just (BinaryOpExpr op' _ _) | priority op >= priority op' ->-                  customFailure (IllFormedPointFreeExpr op op')-                _ -> return [makeLambda op Nothing rarg])-      <|> (do larg <- opExpr-              op   <- choice $ map (binOpLiteral . repr) reservedBinops-              case larg of-                BinaryOpExpr op' _ _ | priority op >= priority op' ->-                  customFailure (IllFormedPointFreeExpr op op')-                _ -> return [makeLambda op (Just larg) Nothing])--    makeLambda :: EgisonBinOp -> Maybe EgisonExpr -> Maybe EgisonExpr -> EgisonExpr-    makeLambda op Nothing Nothing =-      LambdaExpr [ScalarArg ":x", ScalarArg ":y"]-                 (BinaryOpExpr op (stringToVarExpr ":x") (stringToVarExpr ":y"))-    makeLambda op Nothing (Just rarg) =-      LambdaExpr [ScalarArg ":x"] (BinaryOpExpr op (stringToVarExpr ":x") rarg)-    makeLambda op (Just larg) Nothing =-      LambdaExpr [ScalarArg ":y"] (BinaryOpExpr op larg (stringToVarExpr ":y"))--arrayExpr :: Parser EgisonExpr-arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)--vectorExpr :: Parser EgisonExpr-vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma)--hashExpr :: Parser EgisonExpr-hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)-  where-    hashBraces = between (symbol "{|") (symbol "|}")-    hashElem = brackets $ (,) <$> expr <*> (comma >> expr)--index :: Parser (Index EgisonExpr)-index = SupSubscript <$> (string "~_" >> atomExpr')-    <|> try (char '_' >> subscript)-    <|> try (char '~' >> superscript)-    <|> try (Userscript <$> (char '|' >> atomExpr'))-    <?> "index"-  where-    subscript = do-      e1 <- atomExpr'-      e2 <- optional (string "..._" >> atomExpr')-      case e2 of-        Nothing  -> return $ Subscript e1-        Just e2' -> return $ MultiSubscript e1 e2'-    superscript = do-      e1 <- atomExpr'-      e2 <- optional (string "...~" >> atomExpr')-      case e2 of-        Nothing  -> return $ Superscript e1-        Just e2' -> return $ MultiSuperscript e1 e2'--atomOrApplyExpr :: Parser EgisonExpr-atomOrApplyExpr = do-  pos <- L.indentLevel-  func <- atomExpr-  args <- many (L.indentGuard sc GT pos *> atomExpr)-  return $ case args of-             [] -> func-             _  -> makeApply func args--atomExpr :: Parser EgisonExpr-atomExpr = do-  e <- atomExpr'-  -- TODO(momohatt): "..." (override of index) collides with ContPat-  indices <- many index-  return $ case indices of-             [] -> e-             _  -> IndexedExpr False e indices---- atom expr without index-atomExpr' :: Parser EgisonExpr-atomExpr' = constantExpr-        <|> VarExpr <$> varLiteral-        <|> (\x -> InductiveDataExpr x []) <$> upperId-        <|> vectorExpr     -- must come before collectionExpr-        <|> arrayExpr      -- must come before tupleOrParenExpr-        <|> collectionExpr-        <|> tupleOrParenExpr-        <|> hashExpr-        <|> QuoteExpr <$> (char '\'' >> atomExpr')-        <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')-        <?> "atomic expression"--constantExpr :: Parser EgisonExpr-constantExpr = numericExpr-           <|> BoolExpr <$> boolLiteral-           <|> CharExpr <$> try charLiteral        -- try for quoteExpr-           <|> StringExpr . pack <$> stringLiteral-           <|> SomethingExpr <$ keywordSomething-           <|> UndefinedExpr <$ keywordUndefined--numericExpr :: Parser EgisonExpr-numericExpr = try (uncurry FloatExpr <$> floatLiteral)-          <|> IntegerExpr <$> positiveIntegerLiteral-          <?> "numeric expression"------ Pattern-----pattern :: Parser EgisonPattern-pattern = letPattern-      <|> loopPattern-      <|> opPattern-      <?> "pattern"--letPattern :: Parser EgisonPattern-letPattern = do-  pos   <- keywordLet >> L.indentLevel-  binds <- some (L.indentGuard sc EQ pos *> binding)-  body  <- keywordIn >> pattern-  return $ LetPat binds body--loopPattern :: Parser EgisonPattern-loopPattern = do-  keywordLoop-  iter <- patVarLiteral-  range <- loopRange-  loopBody <- optional (symbol "|") >> pattern-  loopEnd <- symbol "|" >> pattern-  return $ LoopPat iter range loopBody loopEnd-  where-    loopRange :: Parser LoopRange-    loopRange =-      parens $ do start <- expr-                  ends  <- option (defaultEnds start) (try $ comma >> expr)-                  as    <- option WildCard (comma >> pattern)-                  return $ LoopRange start ends as--    defaultEnds s =-      ApplyExpr (stringToVarExpr "from")-                (makeApply (stringToVarExpr "-'") [s, IntegerExpr 1])--seqPattern :: Parser EgisonPattern-seqPattern = do-  pats <- braces $ sepBy pattern comma-  return $ foldr SeqConsPat SeqNilPat pats--opPattern :: Parser EgisonPattern-opPattern = makeExprParser applyOrAtomPattern table-  where-    table :: [[Operator Parser EgisonPattern]]-    table =-      [ [ Prefix (NotPat <$ symbol "!") ]-      -- 5-      , [ InfixR (inductive2 "cons" ":" )-        , InfixR (inductive2 "join" "++") ]-      -- 3-      , [ InfixR (binary AndPat "&&") ]-      -- 2-      , [ InfixR (binary OrPat  "||") ]-      ]-    inductive2 name sym = (\x y -> InductivePat name [x, y]) <$ patOperator sym-    binary name sym     = (\x y -> name [x, y]) <$ patOperator sym--applyOrAtomPattern :: Parser EgisonPattern-applyOrAtomPattern = do-  pos <- L.indentLevel-  func <- atomPattern-  args <- many (L.indentGuard sc GT pos *> atomPattern)-  case (func, args) of-    (_,                 []) -> return func-    (InductivePat x [], _)  -> return $ InductivePat x args--atomPattern :: Parser EgisonPattern-atomPattern = do-  pat     <- atomPattern'-  indices <- many . try $ char '_' >> atomExpr'-  return $ case indices of-             [] -> pat-             _  -> IndexedPat pat indices---- atomic pattern without index-atomPattern' :: Parser EgisonPattern-atomPattern' = WildCard <$   symbol "_"-           <|> PatVar   <$> patVarLiteral-           <|> ValuePat <$> (char '#' >> atomExpr)-           <|> InductivePat "nil" [] <$ (symbol "[" >> symbol "]")-           <|> InductivePat <$> lowerId <*> pure []-           <|> VarPat   <$> (char '~' >> lowerId)-           <|> PredPat  <$> (symbol "?" >> atomExpr)-           <|> ContPat  <$ symbol "..."-           <|> makeTupleOrParen pattern TuplePat-           <|> seqPattern-           <|> LaterPatVar <$ symbol "@"-           <?> "atomic pattern"--ppPattern :: Parser PrimitivePatPattern-ppPattern = PPInductivePat <$> lowerId <*> many ppAtom-        <|> makeExprParser ppAtom table-        <?> "primitive pattern pattern"-  where-    table :: [[Operator Parser PrimitivePatPattern]]-    table =-      [ [ InfixR (inductive2 "cons" ":" )-        , InfixR (inductive2 "join" "++") ]-      ]-    inductive2 name sym = (\x y -> PPInductivePat name [x, y]) <$ operator sym--    ppAtom :: Parser PrimitivePatPattern-    ppAtom = PPWildCard <$ symbol "_"-         <|> PPPatVar   <$ symbol "$"-         <|> PPValuePat <$> (symbol "#$" >> lowerId)-         <|> PPInductivePat "nil" [] <$ brackets sc-         <|> makeTupleOrParen ppPattern PPTuplePat---- TODO(momohatt): cons pat, snoc pat, empty pat-pdPattern :: Parser PrimitiveDataPattern-pdPattern = PDInductivePat <$> upperId <*> many pdAtom-        <|> pdAtom-        <?> "primitive data pattern"-  where-    pdAtom :: Parser PrimitiveDataPattern-    pdAtom = PDWildCard    <$ symbol "_"-         <|> PDPatVar      <$> (symbol "$" >> lowerId)-         <|> PDConstantPat <$> constantExpr-         <|> makeTupleOrParen pdPattern PDTuplePat------- Tokens------- space comsumer-sc :: Parser ()-sc = L.space space1 lineCmnt blockCmnt-  where-    lineCmnt  = L.skipLineComment "--"-    blockCmnt = L.skipBlockCommentNested "{-" "-}"--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--positiveIntegerLiteral :: Parser Integer-positiveIntegerLiteral = lexeme L.decimal-                     <?> "unsinged integer"--charLiteral :: Parser Char-charLiteral = between (char '\'') (symbol "\'") L.charLiteral-          <?> "character"--stringLiteral :: Parser String-stringLiteral = char '\"' *> manyTill L.charLiteral (symbol "\"")-          <?> "string"--boolLiteral :: Parser Bool-boolLiteral = reserved "True"  $> True-          <|> reserved "False" $> False-          <?> "boolean"--floatLiteral :: Parser (Double, Double)-floatLiteral = try ((,0) <$> (lexeme L.float <* notFollowedBy (symbol "i")))-                <|> (0,) <$> (lexeme L.float <* symbol "i")-                <?> "float"--varLiteral :: Parser Var-varLiteral = stringToVar <$> lowerId--patVarLiteral :: Parser Var-patVarLiteral = stringToVar <$> (char '$' >> lowerId)--binOpLiteral :: String -> Parser EgisonBinOp-binOpLiteral sym = do-  wedge <- optional (char '!')-  opSym <- operator sym-  let opInfo = fromJust $ find ((== opSym) . repr) reservedBinops-  return $ opInfo { isWedge = isJust wedge }--reserved :: String -> Parser ()-reserved w = (lexeme . try) (string w *> notFollowedBy alphaNumChar)--symbol :: String -> Parser String-symbol sym = try $ L.symbol sc sym--operator :: String -> Parser String-operator sym = try $ string sym <* notFollowedBy opChar <* sc--patOperator :: String -> Parser String-patOperator sym = try $ string sym <* notFollowedBy patOpChar <* sc---- Characters that could consist expression operators.-opChar :: Parser Char-opChar = oneOf "%^&*-+\\|:<>.?/'!#@$"---- Characters that could consist pattern operators.--- ! # @ $ are omitted because they can appear at the beginning of atomPattern-patOpChar :: Parser Char-patOpChar = oneOf "%^&*-+\\|:<>.?/'"--parens    = between (symbol "(") (symbol ")")-braces    = between (symbol "{") (symbol "}")-brackets  = between (symbol "[") (symbol "]")-comma     = symbol ","--lowerId :: Parser String-lowerId = (lexeme . try) (p >>= check)-  where-    p       = (:) <$> lowerChar <*> many (alphaNumChar <|> oneOf ['.', '?', '\''])-    check x = if x `elem` lowerReservedWords-                then fail $ "keyword " ++ show x ++ " cannot be an identifier"-                else return x---- TODO: Deprecate BoolExpr and merge it with InductiveDataExpr-upperId :: Parser String-upperId = (lexeme . try) (p >>= check)-  where-    p       = (:) <$> upperChar <*> many alphaNumChar-    check x = if x `elem` upperReservedWords-                then fail $ "keyword " ++ show x ++ " cannot be an identifier"-                else return x--keywordLoadFile             = reserved "loadFile"-keywordLoad                 = reserved "load"-keywordIf                   = reserved "if"-keywordThen                 = reserved "then"-keywordElse                 = reserved "else"-keywordSeq                  = reserved "seq"-keywordApply                = reserved "apply"-keywordCApply               = reserved "capply"-keywordMemoizedLambda       = reserved "memoizedLambda"-keywordCambda               = reserved "cambda"-keywordProcedure            = reserved "procedure"-keywordMacro                = reserved "macro"-keywordLetRec               = reserved "letrec"-keywordLet                  = reserved "let"-keywordIn                   = reserved "in"-keywordWithSymbols          = reserved "withSymbols"-keywordLoop                 = reserved "loop"-keywordMatch                = reserved "match"-keywordMatchDFS             = reserved "matchDFS"-keywordMatchAll             = reserved "matchAll"-keywordMatchAllDFS          = reserved "matchAllDFS"-keywordAs                   = reserved "as"-keywordWith                 = reserved "with"-keywordMatcher              = reserved "matcher"-keywordDo                   = reserved "do"-keywordIo                   = reserved "io"-keywordSomething            = reserved "something"-keywordUndefined            = reserved "undefined"-keywordAlgebraicDataMatcher = reserved "algebraicDataMatcher"-keywordGenerateTensor       = reserved "generateTensor"-keywordTensor               = reserved "tensor"-keywordTensorContract       = reserved "contract"-keywordSubrefs              = reserved "subrefs"-keywordSubrefsNew           = reserved "subrefs!"-keywordSuprefs              = reserved "suprefs"-keywordSuprefsNew           = reserved "suprefs!"-keywordUserrefs             = reserved "userRefs"-keywordUserrefsNew          = reserved "userRefs!"-keywordFunction             = reserved "function"--upperReservedWords =-  [ "True"-  , "False"-  ]--lowerReservedWords =-  [ "loadFile"-  , "load"-  , "if"-  , "then"-  , "else"-  , "seq"-  , "apply"-  , "capply"-  , "memoizedLambda"-  , "cambda"-  , "procedure"-  , "macro"-  , "letrec"-  , "let"-  , "in"-  , "withSymbols"-  , "loop"-  , "from"-  , "to"-  , "of"-  , "match"-  , "matchDFS"-  , "matchAll"-  , "matchAllDFS"-  , "as"-  , "with"-  , "matcher"-  , "do"-  , "io"-  , "something"-  , "undefined"-  , "algebraicDataMatcher"-  , "generateTensor"-  , "tensor"-  , "contract"-  , "subrefs"-  , "subrefs!"-  , "suprefs"-  , "suprefs!"-  , "userRefs"-  , "userRefs!"-  , "function"-  ]------- Utils-----makeTupleOrParen :: Parser a -> ([a] -> a) -> Parser a-makeTupleOrParen parser tupleCtor = do-  elems <- parens $ sepBy parser comma-  case elems of-    [elem] -> return elem-    _      -> return $ tupleCtor elems--makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr-makeApply (InductiveDataExpr x []) xs = InductiveDataExpr x xs-makeApply func xs = ApplyExpr func (TupleExpr xs)--makeApply' :: String -> [EgisonExpr] -> EgisonExpr-makeApply' func xs = ApplyExpr (stringToVarExpr func) (TupleExpr xs)

@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleInstances #-}++{- |+Module      : Language.Egison.PrettyPrint+Copyright   : Satoshi Egi+Licence     : MIT++This module contains pretty printing for Egison syntax+-}++module Language.Egison.Pretty+    ( prettyTopExprs+    ) where++import           Data.Text.Prettyprint.Doc++import           Language.Egison.Types++--+-- Pretty printing for Non-S syntax+--++prettyTopExprs :: [EgisonTopExpr] -> Doc [EgisonTopExpr]+prettyTopExprs exprs = vsep $ punctuate line (map pretty exprs)++instance Pretty EgisonTopExpr where+  pretty (Define x (LambdaExpr args body)) =+    pretty x <+> hsep (map pretty args) <+> equals <> softline <> pretty body+  pretty (Define x expr) = pretty x <+> equals <> nest 2 (softline <> pretty expr)+  pretty (Test expr) = pretty expr++instance Pretty EgisonExpr where+  pretty (CharExpr x)    = squote <> pretty x <> squote+  pretty (StringExpr x)  = dquote <> pretty x <> dquote+  pretty (BoolExpr x)    = pretty x+  pretty (IntegerExpr x) = pretty x+  pretty (FloatExpr x)   = pretty x+  pretty (VarExpr x)     = pretty x++  pretty (InductiveDataExpr c xs) = nest 2 (pretty c <+> fillSep (map pretty xs))++  pretty (TupleExpr xs) = tupled (map pretty xs)+  pretty (CollectionExpr xs) = list (map pretty xs)+  pretty (ArrayExpr xs)  = listoid "(|" "|)" (map pretty xs)+  pretty (HashExpr xs)   = listoid "{|" "|}" (map (\(x, y) -> list [pretty x, pretty y]) xs)+  pretty (VectorExpr xs) = listoid "[|" "|]" (map pretty xs)++  pretty (LambdaExpr xs y)          = pretty "\\" <> hsep (map pretty xs) <+> pretty "->" <> nest 2 (softline <> pretty y)+  pretty (PatternFunctionExpr xs y) = pretty "\\" <> hsep (map pretty xs) <+> pretty "=>" <> softline <> pretty y++  pretty (UnaryOpExpr op x) = pretty op <> pretty x+  pretty (BinaryOpExpr op x@(BinaryOpExpr op' _ _) y)+    | priority op > priority op' = parens (pretty x) <+> pretty (repr op) <+> pretty' y+    | otherwise                  = pretty x <+> pretty (repr op) <+> pretty' y+  pretty (BinaryOpExpr op x y) = pretty x <+> pretty (repr op) <+> pretty' y++  pretty (ApplyExpr x (TupleExpr ys)) = nest 2 (pretty x <+> fillSep (map pretty ys))++instance Pretty Arg where+  pretty (ScalarArg x)         = pretty x+  pretty (InvertedScalarArg x) = pretty "*$" <> pretty x+  pretty (TensorArg x)         = pretty '%' <> pretty x++instance Pretty Var where+  -- TODO: indices+  pretty (Var xs is) = concatWith (surround dot) (map pretty xs)++instance Pretty InnerExpr where+  pretty (ElementExpr x) = pretty x+  pretty (SubCollectionExpr _) = error "Not supported"++instance Pretty EgisonPattern where+  pretty x = undefined++pretty' :: EgisonExpr -> Doc ann+pretty' x@(UnaryOpExpr _ _) = parens $ pretty x+pretty' x                   = pretty x++listoid :: String -> String -> [Doc ann] -> Doc ann+listoid lp rp elems = encloseSep (pretty lp) (pretty rp) (comma <> space) elems

@@ -25,7 +25,7 @@ import           Data.Foldable             (toList) import           Data.IORef import           Data.Ratio-import           Text.Regex.TDFA           ((=~))+import           Text.Regex.TDFA           ((=~~))  import           System.IO import           System.Process            (readProcess)@@ -140,8 +140,8 @@  constants :: [(String, EgisonValue)] constants = [-              ("f.pi", Float 3.141592653589793 0)-             ,("f.e" , Float 2.718281828459045 0)+              ("f.pi", Float 3.141592653589793)+             ,("f.e" , Float 2.718281828459045)               ]  --@@ -157,10 +157,10 @@              , ("b.-'", minus)              , ("b.*'", multiply)              , ("b./'", divide)-             , ("f.+", floatPlus)-             , ("f.-", floatMinus)-             , ("f.*", floatMult)-             , ("f./", floatDivide)+             , ("f.+", floatBinaryOp (+))+             , ("f.-", floatBinaryOp (-))+             , ("f.*", floatBinaryOp (*))+             , ("f./", floatBinaryOp (/))              , ("numerator", numerator')              , ("denominator", denominator')              , ("from-math-expr", fromScalarData)@@ -168,7 +168,7 @@              , ("to-math-expr'", toScalarData)               , ("modulo",    integerBinaryOp mod)-             , ("quotient",   integerBinaryOp quot)+             , ("quotient",  integerBinaryOp quot)              , ("remainder", integerBinaryOp rem)              , ("b.abs", rationalUnaryOp abs)              , ("b.neg", rationalUnaryOp negate)@@ -183,8 +183,6 @@              , ("floor",    floatToIntegerOp floor)              , ("ceiling",  floatToIntegerOp ceiling)              , ("truncate", truncate')-             , ("real-part", realPart)-             , ("imaginary-part", imaginaryPart)               , ("b.sqrt", floatUnaryOp sqrt)              , ("b.sqrt'", floatUnaryOp sqrt)@@ -263,10 +261,10 @@              , ("b.-'", minus)              , ("b.*'", multiply)              , ("b./'", divide)-             , ("f.+", floatPlus)-             , ("f.-", floatMinus)-             , ("f.*", floatMult)-             , ("f./", floatDivide)+             , ("f.+", floatBinaryOp (+))+             , ("f.-", floatBinaryOp (-))+             , ("f.*", floatBinaryOp (*))+             , ("f./", floatBinaryOp (/))              , ("numerator", numerator')              , ("denominator", denominator')              , ("fromMathExpr", fromScalarData)@@ -289,8 +287,6 @@              , ("floor",    floatToIntegerOp floor)              , ("ceiling",  floatToIntegerOp ceiling)              , ("truncate", truncate')-             , ("realPart", realPart)-             , ("imaginaryPart", imaginaryPart)               , ("b.sqrt", floatUnaryOp sqrt)              , ("b.sqrt'", floatUnaryOp sqrt)@@ -392,12 +388,12 @@  floatUnaryOp :: (Double -> Double) -> PrimitiveFunc floatUnaryOp op = oneArg $ \val -> case val of-                                     (Float f 0) -> return $ Float (op f) 0+                                     (Float f) -> return $ Float (op f)                                      _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack  floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc floatBinaryOp op = twoArgs $ \val val' -> case (val, val') of-                                            (Float f 0, Float f' 0) -> return $ Float (op f f') 0+                                            (Float f, Float f') -> return $ Float (op f f')                                             _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack  floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc@@ -406,27 +402,7 @@   f' <- fromEgison val'   return $ Bool $ pred f f' -floatPlus :: PrimitiveFunc-floatPlus = twoArgs $ \val val' -> case (val, val') of-                                     (Float x y, Float x' y') -> return $ Float (x + x')  (y + y')-                                     _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack -floatMinus :: PrimitiveFunc-floatMinus = twoArgs $ \val val' -> case (val, val') of-                                      (Float x y, Float x' y') -> return $ Float (x - x')  (y - y')-                                      _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack--floatMult :: PrimitiveFunc-floatMult = twoArgs $ \val val' -> case (val, val') of-                                     (Float x y, Float x' y') -> return $ Float (x * x' - y * y')  (x * y' + x' * y)-                                     _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack--floatDivide :: PrimitiveFunc-floatDivide = twoArgs $ \val val' -> case (val, val') of-                                       (Float x y, Float x' y') -> return $ Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y'))-                                       _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack-- -- -- Arith --@@ -487,10 +463,10 @@     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (<) r r'-  scalarBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (<) f f'-  scalarBinaryPred' (ScalarData _) val         = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _ _)  val           = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val          _             = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float f)      (Float f') = return $ Bool (f < f')+  scalarBinaryPred' (ScalarData _) val        = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float _)      val        = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack+  scalarBinaryPred' val            _          = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack  lte :: PrimitiveFunc lte = twoArgs' $ \val val' -> scalarBinaryPred' val val'@@ -499,10 +475,10 @@     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (<=) r r'-  scalarBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (<=) f f'-  scalarBinaryPred' (ScalarData _) val         = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _ _)  val           = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val          _             = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float f)      (Float f') = return $ Bool (f <= f')+  scalarBinaryPred' (ScalarData _) val        = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float _)      val        = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack+  scalarBinaryPred' val            _          = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack  gt :: PrimitiveFunc gt = twoArgs' $ \val val' -> scalarBinaryPred' val val'@@ -511,10 +487,10 @@     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (>) r r'-  scalarBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (>) f f'+  scalarBinaryPred' (Float f)      (Float f')  = return $ Bool $ (f > f')   scalarBinaryPred' (ScalarData _) val         = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _ _)  val           = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val          _             = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float _)      val         = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack+  scalarBinaryPred' val            _           = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack  gte :: PrimitiveFunc gte = twoArgs' $ \val val' -> scalarBinaryPred' val val'@@ -523,31 +499,19 @@     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (>=) r r'-  scalarBinaryPred' (Float f 0)    (Float f' 0)  = return $ Bool $ (>=) f f'-  scalarBinaryPred' (ScalarData _) val           = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _ _)    val           = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val            _             = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float f)      (Float f')  = return $ Bool (f >= f')+  scalarBinaryPred' (ScalarData _) val         = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+  scalarBinaryPred' (Float _)      val         = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack+  scalarBinaryPred' val            _           = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack  truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val  where   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' (Float x)             = return $ toEgison (truncate x :: Integer)   numberUnaryOp' val                   = throwError =<< TypeMismatch "rational or float" (Value val) <$> getFuncNameStack -realPart :: PrimitiveFunc-realPart =  oneArg realPart'- where-  realPart' (Float x y) = return $ Float x 0-  realPart' val         = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack--imaginaryPart :: PrimitiveFunc-imaginaryPart =  oneArg imaginaryPart'- where-  imaginaryPart' (Float _ y) = return $ Float y 0-  imaginaryPart' val         = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack- -- -- Tensor --@@ -574,8 +538,8 @@ -- Transform -- numberToFloat' :: EgisonValue -> EgisonValue-numberToFloat' (ScalarData (Div (Plus []) _)) = Float 0 0-numberToFloat' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = Float (fromRational (x % y)) 0+numberToFloat' (ScalarData (Div (Plus []) _)) = Float 0+numberToFloat' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = Float $ fromRational (x % y)  integerToFloat :: PrimitiveFunc integerToFloat = rationalToFloat@@ -645,22 +609,20 @@  regexString :: PrimitiveFunc regexString = twoArgs $ \pat src -> case (pat, src) of-                                      (String patStr, String srcStr) -> do-                                        let (a, b, c) = (T.unpack srcStr =~ T.unpack patStr) :: (String, String, String)-                                        if b == ""-                                          then return . Collection . Sq.fromList $ []-                                          else return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]]+                                      (String patStr, String srcStr) ->+                                        case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of+                                          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]]                                       (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack                                       (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack  regexStringCaptureGroup :: PrimitiveFunc regexStringCaptureGroup = twoArgs $ \pat src -> case (pat, src) of-                                                  (String patStr, String srcStr) -> do-                                                    let ret = (T.unpack srcStr =~ T.unpack patStr) :: [[String]]-                                                    case ret of-                                                      [] -> return . Collection . Sq.fromList $ []-                                                      ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr-                                                                       return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]]+                                                  (String patStr, String srcStr) ->+                                                    case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of+                                                      Nothing -> return . Collection . Sq.fromList $ []+                                                      Just ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr+                                                                            return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]]                                                   (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack                                                   (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack 

@@ -26,7 +26,7 @@     , InnerExpr (..)     , BindingExpr (..)     , MatchClause (..)-    , MatcherInfo (..)+    , PatternDef (..)     , LoopRange (..)     , PrimitivePatPattern (..)     , PrimitiveDataPattern (..)@@ -195,7 +195,6 @@ import qualified Data.Text                 as T  import           Data.Ratio-import           Numeric                   (showFFloat) import           System.IO  import           System.IO.Unsafe          (unsafePerformIO)@@ -221,7 +220,7 @@   | StringExpr Text   | BoolExpr Bool   | IntegerExpr Integer-  | FloatExpr Double Double+  | FloatExpr Double   | VarExpr Var   | FreshVarExpr   | IndexedExpr Bool EgisonExpr [Index EgisonExpr]  -- True -> delete old index and append new one@@ -258,14 +257,12 @@   | MatchLambdaExpr EgisonExpr [MatchClause]   | MatchAllLambdaExpr EgisonExpr [MatchClause] -  | MatcherExpr MatcherInfo+  | MatcherExpr [PatternDef]   | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]    | QuoteExpr EgisonExpr   | QuoteSymbolExpr EgisonExpr--  | WedgeExpr EgisonExpr                         -- Desugared to WedgeApplyExpr-  | WedgeApplyExpr EgisonExpr EgisonExpr         -- Appears after desugar+  | WedgeApplyExpr EgisonExpr EgisonExpr    | DoExpr [BindingExpr] EgisonExpr   | IoExpr EgisonExpr@@ -323,7 +320,7 @@  type BindingExpr = ([Var], EgisonExpr) type MatchClause = (EgisonPattern, EgisonExpr)-type MatcherInfo = [(PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])]+type PatternDef  = (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])  -- TODO(momohatt): AndPat and OrPat take only 2 arguments in new syntax data EgisonPattern =@@ -433,7 +430,7 @@   | Bool Bool   | ScalarData ScalarData   | TensorData (Tensor EgisonValue)-  | Float Double Double+  | Float Double   | InductiveData String [EgisonValue]   | Tuple [EgisonValue]   | Collection (Seq EgisonValue)@@ -441,7 +438,7 @@   | IntHash (HashMap Integer EgisonValue)   | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)-  | UserMatcher Env MatcherInfo+  | UserMatcher Env [PatternDef]   | Func (Maybe Var) Env [String] EgisonExpr   | PartialFunc Env Integer EgisonExpr   | CFunc (Maybe Var) Env String EgisonExpr@@ -1217,16 +1214,16 @@  removePairs :: (Int, Int) -> [a] -> [a] removePairs (m, n) xs =-  let (hs, ms, ts) = removePairs' (m, n) xs in-    hs ++ ms ++ ts+  let (hs, ms, ts) = removePairs' (m, n) xs+   in hs ++ ms ++ ts  removePairs' :: (Int, Int) -> [a] -> ([a],[a],[a])-removePairs' (m, n) xs =           -- (0,1) [i i]-  let (hms, tts) = splitAt n xs in -- [i] [i]-  let ts = tail tts in             -- []-  let (hs, tms) = splitAt m hms in -- [] [i]-  let ms = tail tms in             -- []-    (hs, ms, ts)                   -- [] [] []+removePairs' (m, n) xs =         -- (0,1) [i i]+  let (hms, tts) = splitAt n xs  -- [i] [i]+      ts = tail tts              -- []+      (hs, tms) = splitAt m hms  -- [] [i]+      ms = tail tms              -- []+   in (hs, ms, ts)               -- [] [] [] -- -- --@@ -1241,7 +1238,7 @@   show (BoolExpr True) = "#t"   show (BoolExpr False) = "#f"   show (IntegerExpr n) = show n-  show (FloatExpr x y) = showComplexFloat x y+  show (FloatExpr x) = show x   show (VarExpr name) = show name   show (PartialVarExpr n) = "%" ++ show n   show (FunctionExpr args) = "(function [" ++ unwords (map show args) ++ "])"@@ -1277,7 +1274,7 @@     f j [] = ""     f j xs = "[| " ++ unwords (map show (take j xs)) ++ " |] " ++ f j (drop j xs)   show (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map show (V.toList xs)) ++ "} )" ++ concatMap show js-  show (Float x y) = showComplexFloat x y+  show (Float x) = show x   show (InductiveData name []) = "<" ++ name ++ ">"   show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">"   show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]"@@ -1342,18 +1339,6 @@   show (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js   show (FunctionData (Just name) argnames args js) = show name ++ concatMap show js -showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String-showComplex x 0 = show x-showComplex 0 y = show y ++ "i"-showComplex x y = show x ++ (if y > 0 then "+" else "") ++ show y ++ "i"--showComplexFloat :: Double -> Double -> String-showComplexFloat x 0.0 = showFFloat Nothing x ""-showComplexFloat 0.0 y = showFFloat Nothing y "i"-showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0-                                                    then "+" ++ showFFloat Nothing y "i"-                                                    else showFFloat Nothing y "i"- 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))@@ -1365,7 +1350,7 @@  (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 y) == (Float x' y') = (x == x') && (y == y')+ (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'@@ -1457,9 +1442,9 @@   fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack  instance EgisonData Double where-  toEgison f = Float f 0-  fromEgison (Float f 0) = return f-  fromEgison val         = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+  toEgison f = Float f+  fromEgison (Float f) = return f+  fromEgison val       = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack  instance EgisonData Handle where   toEgison = Port@@ -1574,8 +1559,8 @@   fromWHNF whnf = throwError =<< TypeMismatch "integer" whnf <$> getFuncNameStack  instance EgisonWHNF Double where-  fromWHNF (Value (Float f 0)) = return f-  fromWHNF whnf                = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack+  fromWHNF (Value (Float f)) = return f+  fromWHNF whnf              = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack  instance EgisonWHNF Handle where   fromWHNF (Value (Port h)) = return h@@ -1948,7 +1933,7 @@ isScalar _              = False  isScalar' :: PrimitiveFunc-isScalar' (Value val) = return $ Value $ Bool $ isScalar val+isScalar' (Value (ScalarData _)) = return $ Value $ Bool $ True isScalar' _           = return $ Value $ Bool False  isTensor :: EgisonValue -> Bool@@ -1956,7 +1941,8 @@ isTensor _              = False  isTensor' :: PrimitiveFunc-isTensor' (Value val) = return $ Value $ Bool $ isTensor val+isTensor' (Value (TensorData _)) = return $ Value $ Bool $ True+isTensor' (Intermediate (ITensor _)) = return $ Value $ Bool $ True isTensor' _           = return $ Value $ Bool False  isTensorWithIndex :: EgisonValue -> Bool@@ -1968,12 +1954,12 @@ isTensorWithIndex' _           = return $ Value $ Bool False  isFloat' :: PrimitiveFunc-isFloat' (Value (Float _ 0)) = return $ Value $ Bool True-isFloat' _                   = return $ Value $ Bool False+isFloat' (Value (Float _)) = return $ Value $ Bool True+isFloat' _                 = return $ Value $ Bool False  isComplex' :: PrimitiveFunc-isComplex' (Value (Float _ _)) = return $ Value $ Bool True-isComplex' _                   = return $ Value $ Bool False+isComplex' (Value (Float _)) = return $ Value $ Bool True+isComplex' _                 = return $ Value $ Bool False  isChar' :: PrimitiveFunc isChar' (Value (Char _)) = return $ Value $ Bool True@@ -2041,9 +2027,8 @@     optTestOnly         :: Bool,     optPrompt           :: String,     optMathExpr         :: Maybe String,-    optSExpr            :: Bool,-    optUseNonS2         :: Bool+    optSExpr            :: Bool     }  defaultOption :: EgisonOpts-defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True False+defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True

@@ -19,7 +19,6 @@  import           Language.Egison.Parser           as Parser import           Language.Egison.ParserNonS       as ParserNonS-import           Language.Egison.ParserNonS2      as ParserNonS2 import           Language.Egison.Types  -- |Get Egison expression from the prompt. We can handle multiline input.@@ -41,7 +40,7 @@       history <- getHistory       putHistory $ addHistoryUnlessConsecutiveDupe line history       let input = prev ++ line-      let parsedExpr = (if optUseNonS2 opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input+      let parsedExpr = (if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input       case parsedExpr of         Left err | show err =~ "unexpected end of input" ->           getEgisonExpr' opts $ input ++ "\n"

@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleInstances #-}++module Main where++import           Control.Arrow                         ((***))+import           Data.Char                             (toUpper)+import           Data.List                             (find)+import           Data.List.Split                       (splitOn)+import           Data.Maybe                            (fromJust)+import           Data.Text.Prettyprint.Doc.Render.Text (putDoc)+import           System.Environment                    (getArgs)++import           Language.Egison.Types+import           Language.Egison.Parser+import           Language.Egison.Pretty++class SyntaxElement a where+  toNonS :: a -> a++instance SyntaxElement EgisonTopExpr where+  toNonS (Define x y)   = Define (toNonS x) (toNonS y)+  toNonS (Redefine x y) = error "Not supported"+  toNonS (Test x)       = Test (toNonS x)+  toNonS (Execute x)    = Execute (toNonS x)+  toNonS x              = x++instance SyntaxElement EgisonExpr where+  toNonS (IntegerExpr x)+    | x < 0     = UnaryOpExpr "-" (IntegerExpr (-x))+    | otherwise = IntegerExpr x+  toNonS (VarExpr x) = VarExpr (toNonS x)++  toNonS (IndexedExpr b x ys)  = IndexedExpr  b (toNonS x) (map toNonS ys)+  toNonS (SubrefsExpr b x y)   = SubrefsExpr  b (toNonS x) (toNonS y)+  toNonS (SuprefsExpr b x y)   = SuprefsExpr  b (toNonS x) (toNonS y)+  toNonS (UserrefsExpr b x y)  = UserrefsExpr b (toNonS x) (toNonS y)+  toNonS (PowerExpr x y) = BinaryOpExpr powerOp (toNonS x) (toNonS y)+    where powerOp = fromJust $ find (\op -> repr op == "^") reservedBinops+  toNonS (InductiveDataExpr x ys) = InductiveDataExpr x (map toNonS ys)+  toNonS (TupleExpr xs)      = TupleExpr (map toNonS xs)+  toNonS (CollectionExpr xs) = CollectionExpr (map toNonS xs)+  toNonS (ArrayExpr xs)      = ArrayExpr (map toNonS xs)+  toNonS (HashExpr xs)       = HashExpr (map (toNonS *** toNonS) xs)+  toNonS (VectorExpr xs)     = VectorExpr (map toNonS xs)++  toNonS (LambdaExpr xs y)          = LambdaExpr xs (toNonS y)+  toNonS (MemoizedLambdaExpr xs y)  = MemoizedLambdaExpr xs (toNonS y)+  toNonS (CambdaExpr _ _)           = error "Not supported"+  toNonS (ProcedureExpr xs y)       = ProcedureExpr xs (toNonS y)+  toNonS (MacroExpr xs y)           = MacroExpr xs (toNonS y)+  -- PatternFunctionExpr++  toNonS (IfExpr x y z)         = IfExpr (toNonS x) (toNonS y) (toNonS z)+  toNonS (LetRecExpr xs y)      = LetRecExpr (map toNonS xs) (toNonS y)+  toNonS (LetExpr xs y)         = LetExpr (map toNonS xs) (toNonS y)+  toNonS (LetStarExpr xs y)     = LetStarExpr (map toNonS xs) (toNonS y)+  toNonS (WithSymbolsExpr xs y) = WithSymbolsExpr xs (toNonS y)++  toNonS (MatchExpr x y zs)        = MatchExpr       (toNonS x) (toNonS y) (map toNonS zs)+  toNonS (MatchDFSExpr x y zs)     = MatchDFSExpr    (toNonS x) (toNonS y) (map toNonS zs)+  toNonS (MatchAllExpr x y zs)     = MatchAllExpr    (toNonS x) (toNonS y) (map toNonS zs)+  toNonS (MatchAllDFSExpr x y zs)  = MatchAllDFSExpr (toNonS x) (toNonS y) (map toNonS zs)+  toNonS (MatchLambdaExpr x ys)    = MatchLambdaExpr    (toNonS x) (map toNonS ys)+  toNonS (MatchAllLambdaExpr x ys) = MatchAllLambdaExpr (toNonS x) (map toNonS ys)++  toNonS (MatcherExpr xs) = MatcherExpr (map toNonS xs)++  toNonS (QuoteExpr x)        = QuoteExpr (toNonS x)+  toNonS (QuoteSymbolExpr x)  = QuoteSymbolExpr (toNonS x)+  toNonS (WedgeApplyExpr x y) = WedgeApplyExpr (toNonS x) (toNonS y)++  toNonS (DoExpr xs y) = DoExpr (map toNonS xs) (toNonS y)+  toNonS (IoExpr x)    = IoExpr (toNonS x)++  toNonS (ApplyExpr x@(VarExpr (Var [f] [])) (TupleExpr [y, z])) =+    case find (\op -> repr op == f) reservedBinops of+      Just op -> BinaryOpExpr op (toNonS y) (toNonS z)+      Nothing -> ApplyExpr x (TupleExpr [toNonS y, toNonS z])++  toNonS x = x++instance SyntaxElement a => SyntaxElement (Index a) where+  toNonS (Subscript x)          = Subscript (toNonS x)+  toNonS (Superscript x)        = Superscript (toNonS x)+  toNonS (SupSubscript x)       = SupSubscript (toNonS x)+  toNonS (MultiSubscript x y)   = MultiSubscript (toNonS x) (toNonS y)+  toNonS (MultiSuperscript x y) = MultiSuperscript (toNonS x) (toNonS y)+  toNonS (Userscript x)         = Userscript (toNonS x)+  toNonS (DotSubscript x)       = DotSubscript (toNonS x)+  toNonS (DotSupscript x)       = DotSupscript (toNonS x)+  toNonS x = x -- DFScript++instance SyntaxElement InnerExpr where+  toNonS (ElementExpr x) = ElementExpr (toNonS x)+  toNonS (SubCollectionExpr _) = error "Not supported"++instance SyntaxElement BindingExpr where+  toNonS (vars, x) = (map toNonS vars, toNonS x)++instance SyntaxElement MatchClause where+  toNonS (x, y) = (x, toNonS y)++instance SyntaxElement PatternDef where+  toNonS (x, y, zs) = (x, toNonS y, map (\(z, w) -> (z, toNonS w)) zs)++instance SyntaxElement Var where+  toNonS (Var xs ys) = Var (map toCamelCase xs) ys+    where+      toCamelCase :: String -> String+      toCamelCase x =+        let heads:tails = splitOn "-" x+         in concat $ heads : map (\ (x:xs) -> toUpper x : xs) tails++main :: IO ()+main = do+  args <- getArgs+  input <- readFile $ head args+  -- 'ast' is not desugared+  let ast = parseTopExprs input+  case ast of+    Left _ -> return ()+    Right ast -> do+      putDoc $ prettyTopExprs $ map toNonS ast+      putStrLn ""

@@ -0,0 +1,55 @@+--+-- Matchers+--++assert "bool's value pattern"+  (match (True, False) as (bool, bool) with+   | #(True, False) -> True+   | _ -> False)++assert "char's value pattern"+  (match 'a' as char with+   | #'a' -> True+   | _ -> False)++assert "integer's value pattern"+  (match 10 as integer with+   | #10 -> True+   | _ -> False)++assert "float's value pattern"+  (match 0.1 as float with+   | #0.1 -> True+   | _ -> False)++--+-- Utility+--+assertEqual "id" (id 1) 1++assertEqual "fst" (fst (1, 2)) 1++assertEqual "snd" (snd (1, 2)) 2++assertEqual "compose - case 1" ((compose (fst, snd)) ((1, 2), 3)) 2++assertEqual "compose - case 2" ((compose (fst, snd, fst)) ((1, (2, 3)), 4)) 2++-- assertEqual("eq?/m",+--   eq?/m(integer, 1, 1),+--   True)++--+-- Booleans+--+assertEqual "and"+  [True && True, True && False, False && True, False && False]+  [True, False, False, False]++assertEqual "or"+  [True || True, True || False, False || True, False || False]+  [True, True, True, False]++assertEqual "not"+  [not True, not False]+  [False, True]

@@ -0,0 +1,35 @@+assertEqual "compare - case 1"+  (compare 10 10)+  Equal++assertEqual "compare - case 2"+  (compare 11 10)+  Greater++assertEqual "compare - case 3"+  (compare 10 11)+  Less++assertEqual "min"+  (min [20, 5])+  5++-- assertEqual "min/fn"+--   (min/fn compare [10, 20, 5, 20, 30])+--   5++assertEqual "max"+  (max [5, 30])+  30++-- assertEqual "max/fn"+--   (max/fn compare [10, 20, 5, 20, 30])+--   30++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]

@@ -0,0 +1,175 @@+assertEqual "numerator" (numerator (13 / 21)) 13++assertEqual "denominator" (denominator (13 / 21)) 21++assertEqual "modulo" (modulo (-21) 13) 5++assertEqual "quotient" (quotient (-21) 13) (-1)++assertEqual "remainder" (remainder (-21) 13) (-8)++assertEqual "neg" (neg (-89)) 89++assertEqual "abs" (abs 0)     0+assertEqual "abs" (abs 15)    15+assertEqual "abs" (abs (-89)) 89++assertEqual "lt?" (0.1 < 1.0) True+assertEqual "lt?" (1.0 < 0.1) False+assertEqual "lt?" (1.0 < 1.0) False++assertEqual "lte?" (0.1 <= 1.0) True+assertEqual "lte?" (1.0 <= 0.1) False+assertEqual "lte?" (1.0 <= 1.0) True++assertEqual "gt?" (0.1 > 1.0) False+assertEqual "gt?" (1.0 > 0.1) True+assertEqual "gt?" (1.0 > 1.0) False++assertEqual "gte?" (0.1 >= 1.0) False+assertEqual "gte?" (1.0 >= 0.1) True+assertEqual "gte?" (1.0 >= 1.0) True++assertEqual "round" (round 3.1)    3+assertEqual "round" (round 3.7)    4+assertEqual "round" (round (-2.2)) (-2)+assertEqual "round" (round (-2.7)) (-3)++assertEqual "floor" (floor 3.1)    3+assertEqual "floor" (floor 3.7)    3+assertEqual "floor" (floor (-2.2)) (-3)+assertEqual "floor" (floor (-2.7)) (-3)++assertEqual "ceiling" (ceiling 3.1)    4+assertEqual "ceiling" (ceiling 3.7)    4+assertEqual "ceiling" (ceiling (-2.2)) (-2)+assertEqual "ceiling" (ceiling (-2.7)) (-2)++assertEqual "truncate" (truncate 3.1)    3+assertEqual "truncate" (truncate 3.7)    3+assertEqual "truncate" (truncate (-2.2)) (-2)+assertEqual "truncate" (truncate (-2.7)) (-2)++-- assertEqual "sqrt" (sqrt 4) 2+assertEqual "sqrt" (sqrt 4.0) 2.0+-- assertEqual "sqrt" (sqrt (-1)) i++-- assertEqual "exp"+--   [exp 1, exp 1.0, exp (-1.0)]+--   [e, 2.718281828459045, 0.36787944117144233]++-- assertEqual "log"+--   [log e, log 10.0]+--   [1, 2.302585092994046]++-- TODO: trigonometric functions+-- * sin+-- * cos+-- * tan+-- * asin+-- * acos+-- * sinh+-- * cosh+-- * tanh+-- * asinh+-- * acosh+-- * atanh++-- tensorSize+-- tensorToList+-- dfOrder++assertEqual "itof" (itof 4)    4.0+assertEqual "itof" (itof (-1)) (-1.0)++assertEqual "rtof" (rtof (3 / 2)) 1.5+assertEqual "rtof" (rtof 1)       1.0++assertEqual "ctoi" (ctoi '1') 49++assertEqual "itoc" (itoc 49) '1'++assertEqual "pack" (pack []) ""+assertEqual "pack" (pack ['E', 'g', 'i', 's', 'o', 'n']) "Egison"++assertEqual "unpack" (unpack "Egison") ['E', 'g', 'i', 's', 'o', 'n']+assertEqual "unpack" (unpack "") []++assertEqual "unconsString" (unconsString "Egison") ('E', "gison")++assertEqual "lengthString" (lengthString "") 0+assertEqual "lengthString" (lengthString "Egison") 6++assertEqual "appendString" (appendString "" "")       ""+assertEqual "appendString" (appendString "" "Egison") "Egison"+assertEqual "appendString" (appendString "Egison" "") "Egison"+assertEqual "appendString" (appendString "Egi" "son") "Egison"++assertEqual "splitString" (splitString "," "") [""]+assertEqual "splitString" (splitString "," "2,3,5,7,11,13") ["2", "3", "5", "7", "11", "13"]++assertEqual "regex" (regex "cde" "abcdefg") [("ab", "cde", "fg")]+assertEqual "regex" (regex "[0-9]+" "abc123defg") [("abc", "123", "defg")]+assertEqual "regex" (regex "a*" "") [("", "", "")]++assertEqual "regexCg" (regexCg "([0-9]+),([0-9]+)" "abc,123,45,defg") [("abc,", ["123", "45"], ",defg")]++-- addPrime+-- addSubscript+-- addSuperscript+-- readProcess++assertEqual "read" (read "3")                3+assertEqual "read" (read "3.14")             3.14+assertEqual "read" (read "{1 2}")            [1, 2]+assertEqual "read" (read "\"Hello world!\"") "Hello world!"++-- TODO: read-tsv++assertEqual "show" (show 3)              "3"+assertEqual "show" (show 3.14159)        "3.14159"+assertEqual "show" (show [1, 2])         "{1 2}"+assertEqual "show" (show "Hello world!") "\"Hello world!\""++-- TODO: show-tsv++assertEqual "empty?" (empty? [])  True+assertEqual "empty?" (empty? [1]) False++assertEqual "uncons" (uncons [1, 2, 3]) (1, [2, 3])+assertEqual "unsnoc" (unsnoc [1, 2, 3]) ([1, 2], 3)++assertEqual "bool?" (bool? False) True++assertEqual "integer?" (integer? 1) True++assertEqual "rational?" (rational? 1)       True+assertEqual "rational?" (rational? (1 / 2)) True+assertEqual "rational?" (rational? 3.1)     False++assertEqual "scalar?" (scalar? 1) True+assertEqual "scalar?" (scalar? (| 1, 2 |)) False++assertEqual "float?" (float? 1.0) True+assertEqual "float?" (float? 1)   False++assertEqual "char?" (char? 'c') True++assertEqual "string?" (string? "hoge") True++assertEqual "collection?" (collection? []) True+assertEqual "collection?" (collection? [1]) True++assertEqual "array?" (array? (| |)) True+assertEqual "array?" (array? (| 1, 2, 3 |)) True++assertEqual "hash?" (hash? {| |}) True+assertEqual "hash?" (hash? {| [1, 2] |}) True++-- TODO: Add a test case where tensor? returns True+assertEqual "tensor?" (tensor? 1)                           False+assertEqual "tensor?" (tensor? (| 1 |))                     False+assertEqual "tensor?" (tensor? [| 1 |])                     True+assertEqual "tensor?" (tensor? (generateTensor (+) [1, 2])) True++-- TODO: tensorWithIndex?

@@ -0,0 +1,467 @@+--+-- Syntax test+--++--+-- Primitive Data+--++assertEqual "char literal"+  ['a', '\n', '\'']+  ['a', '\n', '\'']++assertEqual "string literal" "" ""+assertEqual "string literal" "abc\n" "abc\n"++assertEqual "bool literal"+  [True, False]+  [True, False]++assertEqual "integer literal"+  [1, 0, -100, 1 - 100]+  [1, 0, -100, -99]++assertEqual "rational number"+  [10 / 3, 10 / 20, -1 / 2]+  [10 / 3 , 1 / 2, -1 / 2]++assertEqual "float literal" [1.0, 0.0, -100.012001, 1.0 + 2] [1.0, 0.0, -100.012001, 3.0]++assertEqual "inductive data literal" A A++assertEqual "tuple literal" (1, 2, 3) (1, 2, 3)++assertEqual "singleton tuple literal" (1) 1++assertEqual "collection literal" [1, 2, 3, 4, 5, 6] [1, 2, 3, 4, 5, 6]++assertEqual "collection between" [1..5] [1, 2, 3, 4, 5]+assertEqual "collection from" (take 5 [1..]) [1, 2, 3, 4, 5]++--+-- Basic Sytax+--++assertEqual "if"+  (if True then True else False)+  True++assertEqual "if"+  (if False then True else False)+  False++assertEqual "let binding"+  (let t = (1, 2)+       (x, y) = t+    in x + y)+  3++assertEqual "let binding"+  (let x = 1+       y = x + 1+    in y)+  2++assertEqual "mutual recursion"+  (let even? n = if n == 0 then True else odd? (n - 1)+       odd? n = if n == 0 then False else even? (n - 1)+    in even? 10)+  True++assertEqual "lambda and application"+  ((\x -> x + 1) 10)+  11++assertEqual "application with binops"+  ((\x y -> x + y) 1 2 + 3)+  6++assertEqual "append op" ([1] ++ [2]) [1, 2]+assertEqual "append op" ((++) [1] [2]) [1, 2]++assertEqual "point free expr" ((+) 10 1) 11+assertEqual "point free expr" ((+ 1) 10) 11+assertEqual "point free expr" (foldl (*) 1 [1..5]) 120+assertEqual "point free expr" ((10 -) 1) 9+assertEqual "point free expr" ((10 - ) 1) 9+assertEqual "not point free expr" (- 2) (1 - 3)++-- findFactor = memoizedLambda+--                n -> match takeWhile (<= floor (sqrt (itof n))) primes as list integer with+--                     | _ ++ (?(\m -> divisor? n m) && $x)  :  _ -> x+--                     | _ -> n+-- assertEqual "memoized lambda"+--   (map findFactor [1..10])+--   [1, 2, 3, 2, 5, 2, 7, 2, 3, 2]++twinPrimes =+  matchAll primes as list integer with+  | _ ++ $p : #(p + 2) : _ -> (p, p + 2)++assertEqual "twin primes"+  (take 10 twinPrimes)+  [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)]++someFunction x y z =+  x + y * z++assertEqual "function definition"+  (someFunction 1 2 3)+  7++gcd m n =+  if (m >= n) then+              if (n == 0) then m+                          else gcd n (m % n)+              else gcd n m++assertEqual "recursive function definition"+  (gcd 143 22)+  11++--+-- Pattern-Matching+--++assertEqual "match"+  (match 1 as integer with+   | #0 -> 0+   | $x -> 10 + x)+  11++assertEqual "match-all"+  (matchAll [1, 2, 3] as multiset integer with+   | $x : _ -> x)+  [1, 2, 3]++assertEqual "match-all-multi"+  (matchAll [1, 2, 3] as multiset integer with+   | $x : #(x + 1) : _ -> [x, x + 1]+   | $x : #(x + 2) : _ -> [x, x + 2])+  [[1, 2], [2, 3], [1, 3]]++assertEqual "match-lambda"+  ((\match as list integer with+    | [] -> 0+    | $x : _ -> x) [1, 2, 3])+  1++assertEqual "match-all-lambda"+  ((\matchAll as list something with+    | _ ++ $x : _ -> x) [1, 2, 3])+  [1, 2, 3]++assertEqual "match-all-lambda-multi"+  ((\matchAll as multiset something with+    | $x : #(x + 1) : _ -> [x, x + 1]+    | $x : #(x + 2) : _ -> [x, x + 2]) [1, 2, 3])+  [[1, 2], [2, 3], [1, 3]]++assert "nested pattern match"+  (match [1, 2, 3] as list integer with+   | #2 : $x -> match x as multiset integer with+                | _ -> False+   | #1 : $x -> match x as multiset integer with+                | #1 : _ -> False+                | #2 : _ -> True)++assertEqual "pattern variable"+  (match 1 as something with $x -> x)+  1++assert "value pattern" (match 1 as integer with #1 -> True)++assert "inductive pattern"+  (match [1, 2, 3] as list integer with+   | snoc #3 _ -> True)++assert "and pattern"+  (match [1, 2, 3] as list integer with+   | #1 : _ && snoc #3 _ -> True)++assert "and pattern"+  (match [1, 2, 3] as list integer with+   | #1 : _ && #3 : _ -> False+   | _ -> True)++assert "or pattern"+  (match [1, 2, 3] as list integer with+   | snoc #1 _ || snoc #3 _ -> True)++assert "or pattern"+  (match [1, 2, 3] as list integer with+   | #2 : _ || #1 : _ -> True)++assert "not pattern"+  (match 1 as integer with+   | ! #1 -> False+   | ! #2 -> True)++assertEqual "not pattern"+  (matchAll [1, 2, 2, 3, 3, 3] as multiset integer with+   | $n : !(#n : _) -> n)+  [1]++assert "predicate pattern"+  (match [1, 2, 3] as list integer with+   | ?(== 1) : _ -> True)++assert "predicate pattern"+  (match [1, 2, 3] as list integer with+   | ?(== 2) : _ -> False+   | _ -> True)++assertEqual "indexed pattern variable"+  (match 23 as mod 10 with+   | $a_1 -> a)+  {| [1, 23] |}++assert "loop pattern"+  (match [3, 2, 1] as list integer with+   | loop $i (1, [3], _)+       | snoc #i ...+       | [] -> True)++assertEqual "loop pattern"+  (match [1..10] as list integer with+   | loop $i (1, $n)+       | #i : ...+       | [] -> n)+  10++assert "loop pattern"+  (match [3, 2, 1] as list integer with+   | loop $i (1, [3], _)+       | snoc #i ...+       | [] -> True)++assertEqual "double loop pattern"+  (match [[1, 2, 3], [4, 5, 6], [7, 8, 9]] as (list (list integer)) with+   | loop $i (1, [3], _)+       | ((loop $j (1, [3], _)+             | $n_i_j : ...+             | []) : ...)+       | [] -> n)+  {| [1, {| [1, 1], [2, 2], [3, 3] |}],+     [2, {| [1, 4], [2, 5], [3, 6] |}],+     [3, {| [1, 7], [2, 8], [3, 9] |}] |}++assertEqual "let pattern"+  (match [1, 2, 3] as list integer with+   | let a = 42 in _ -> a)+  42++assertEqual "let pattern"+  (match [1, 2, 3] as list integer with+   | $a : (let x = a in $xs) -> [x, xs])+  [1, [2, 3]]++assertEqual "let pattern"+  (match [1, 2, 3] as list integer with+   | $a && (let n = length a in _) -> [a, n])+  [[1, 2, 3], 3]++assertEqual "tuple pattern"+  (matchAll (1, (2, 3)) as (integer, (integer, integer)) with+   | ($m, ($n, $w)) -> [m, n, w])+  [[1, 2, 3]]++assertEqual "tuple pattern"+  (matchAll [(1, 1), (2, 2)] as multiset (integer, integer) with+   | ($x, #x) : _ -> x)+  [1, 2]++-- assertEqual "pattern function call"+--   (let twin = \pat1 pat2 => (~pat1 && $x) : #x : ~pat2 in+--    match [1, 1, 1, 2, 3] as list integer with+--    | twin $n $ns -> [n, ns])+--   [1, [1, 2, 3]]++-- assertEqual "recursive pattern function call"+--   (let repeat = \pat => [] || (~pat && $x) : (repeat x) in+--    match [1, 1, 1, 1] as list integer with+--    | repeat $n -> n)+--   1++-- assertEqual "loop pattern in pattern function"+--   let comb n = \p =>+--     loop $i (1, n, _) _ ++ ~p_i : ... | _+--    in+--   matchAll [1, 2, 3, 4, 5] as (list integer) with+--   | (comb 2) $n -> n+--   [{|[1, 1], [2, 2]|}, {|[1, 1], [2, 3]|}, {|[1, 2], [2, 3]|}, {|[1, 1], [2, 4]|}, {|[1, 2], [2, 4]|}, {|[1, 3], [2, 4]|}, {|[1, 1], [2, 5]|}, {|[1, 2], [2, 5]|}, {|[1, 3], [2, 5]|}, {|[1, 4], [2, 5]|}]++assertEqual "pairs of 2, natural numbers"+  (take 10 (matchAll nats as set integer with+            | $m : $n : _ -> [m, n]))+  [[1, 1], [1, 2], [2, 1], [1, 3], [2, 2], [3, 1], [1, 4], [2, 3], [3, 2], [4, 1]]++assertEqual "pairs of 2, different natural numbers"+  (take 10 (matchAll nats as list integer with+            | _ ++ $m : _ ++ $n : _ -> [m, n]))+  [[1, 2], [1, 3], [2, 3], [1, 4], [2, 4], [3, 4], [1, 5], [2, 5], [3, 5], [4, 5]]++tree a = algebraicDataMatcher+  | leaf+  | node (tree a) a (tree a)++treeInsert n t =+  match t as tree integer with+  | leaf -> Node Leaf n Leaf+  | node $t1 $m $t2 -> match (compare n m) as ordering with+      | less    -> Node (treeInsert n t1) m t2+      | equal   -> Node t1 n t2+      | greater -> Node t1 m (treeInsert n t2)++treeMember? n t =+  match t as tree integer with+  | leaf -> False+  | node $t1 $m $t2 -> match (compare n m) as ordering with+      | less    -> treeMember? n t1+      | equal   -> True+      | greater -> treeMember? n t2++assertEqual "tree set using algebraic-data-matcher"+  (let t = foldr treeInsert Leaf [4, 1, 2, 4, 3]+    in [treeMember? 1 t, treeMember? 0 t])+  [True, False]++assert "sequential pattern"+  (match [2,3,1,4,5] as list integer with+    { @ : @ : $x : _,+      (#(x + 1), @),+      #(x + 2)} -> True)++--+-- Tensor+--++assertEqual "generate-tensor"+  (generateTensor (*) [3, 5])+  [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |], [| 3, 6, 9, 12, 15 |] |]++assertEqual "tensor"+  (tensor [2, 5] [1, 2, 3, 4, 5, 2, 4, 6, 8, 10])+  [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |] |]++assertEqual "tensor wedge expr"+  (! b.min [| 1, 2, 3 |] [| 1, 2, 3 |])+  [| [| 1, 1, 1 |], [| 1, 2, 2 |], [| 1, 2, 3 |] |]++assertEqual "tensor wedge expr of binary operator"+  ([| 1, 2, 3 |] !+ [| 1, 2, 3 |])+  [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |]++assertEqual "tensor multiplication"+  ([| 1, 2, 3 |]_i * [| 1, 2, 3 |]_i)+  [| 1, 4, 9 |]_i++--+-- Hash+--++assertEqual "hash-literal"+  {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |}+  {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |}++assertEqual "empty hash-literal"+  {| |}+  {| |}++assertEqual "hash access"+  {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |}_3+  13++--+-- Partial Application+--+-- assertEqual "partial application '$'"+--   ($ + $)(1, 2)+--   3+--+-- assertEqual "partial application '$' with index"+--   ($2-$1)(1, 2)+--   1+--+-- assertEqual "partial application '#'"+--   2#(10 * %1 + %2)(1, 2)+--   12+--+-- assertEqual "recursive partial application '#'"+--   take(10, 1#[%1, @(%0(%1 * 2))](2))+--   [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024]++f *x *y = x + y++assertEqual "double inverted index"+  (f [|1, 2, 3|]_i [|10, 20, 30|]_j)+  [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]~i~j++g x *y = x + y++assertEqual "single inverted index"+  (g [|1, 2, 3|]_i  [|10, 20, 30|]_j)+  [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]_i~j++--+-- matcherExpr, macroExpr+--++list a = matcher+  | [] as () with+    | [] -> [()]+    | _  -> []+  | $ : $    as (a, list a) with+    | $x : $xs -> [(x, xs)]+    | _        -> []+  | snoc $ $ as (a, list a) with+    | snoc $xs $x -> [(x, xs)]+    | _           -> []+  | join _ $ as (list a) with+    | $tgt -> matchAll tgt as list a with+              | loop $i (1, _) | _ : ...  | $rs -> rs+  | join $ $ as (list a, list a) with+    | $tgt -> matchAll tgt as list a with+              | loop $i (1, $n) $xa_i : ... | $rs ->+                (foldr (\%i %r -> xa_i : r) [] [1..n], rs)+  | nioj $ $ as (list a, list a) with+    | $tgt -> matchAll tgt as list a with+              | loop $i (1, $n) snoc $xa_i ... | $rs ->+                (foldr (\%i %r -> r ++ [xa_i]) [] [1..n], rs)+  | #$val as () with+    | $tgt -> if val == tgt then [()] else []+  | $ as something with+    | $tgt -> [tgt]++multiset a = matcher+  | [] as () with+    | $tgt -> match tgt as (mutiset a) with+                | [] -> [()]+                | _ -> []+  | $ : $ as (a, multiset a) with+    | $tgt -> matchAll tgt as list a with+                | $hs ++ $x : $ts -> (x, hs ++ ts)+  | #$val as () with+    | $tgt -> match (val, tgt) as (list a, multiset a) with+                | ([], []) -> [()]+                | ($x : $xs, #x : #xs) -> [()]+                | (_, _) -> []+  | $ as something with+    | $tgt -> [tgt]++assertEqual "matcher definition"+  (matchAll [1, 2, 3] as multiset integer with+   | $x : _ -> x)+  [1, 2, 3]++nishiwakiIf =+  macro b e1 e2 ->+    car (matchAll b as (matcher+                        | $ as something with+                            | True  -> [e1]+                            | False -> [e2]) with+         | $x -> x)++assertEqual "case 1" (nishiwakiIf True     1 2) 1+assertEqual "case 2" (nishiwakiIf False    1 2) 2+assertEqual "case 3" (nishiwakiIf (1 == 1) 1 2) 1

@@ -52,8 +52,6 @@       (Just {})]      [[<var $x> (& $t !(occur ,x))]       (Just {[x t]})]-     [[<compound $f <nil>> <compound ,f <nil>>]-      (Just {})]      [[<compound $f $xs> <compound ,f $ys>]       (unify-list xs ys)]      [_ Nothing]}))

@@ -16,7 +16,7 @@ import           Language.Egison import           Language.Egison.Core import qualified Language.Egison.Parser         as Parser-import qualified Language.Egison.ParserNonS2    as ParserNonS2+import qualified Language.Egison.ParserNonS     as ParserNonS import           Language.Egison.Primitives import           Language.Egison.Types @@ -74,9 +74,9 @@  runUnitTestCaseNonS :: FilePath -> Test runUnitTestCaseNonS file = TestLabel file . TestCase $ do-  env <- initialEnv (defaultOption { optUseNonS2 = True })+  env <- initialEnv (defaultOption { optSExpr = False })   assertEgisonM $ do-    exprs <- ParserNonS2.loadFile file+    exprs <- ParserNonS.loadFile file     let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs     env' <- recursiveBind env bindings     forM_ tests $ evalExprDeep env'

@@ -0,0 +1,2 @@+#t+#f

@@ -0,0 +1,23 @@+[| [| (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |] [| (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |] |]_i_j+[| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_#+[| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#+(tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_#+[| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#+[| [| 0 (* r^2 (sin θ) (cos θ)) |] [| (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#+(tensor {2 2 2} {0 0 0 (* -1 (sin θ) (cos θ)) 0 (/ (cos θ) (sin θ)) (/ (cos θ) (sin θ)) 0} )~#_#_#+[| [| 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) |] |]_#_#+[| [| 0 (/ (cos θ) (sin θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]_#_#+(tensor {2 2 2} {0 0 0 0 0 0 0 0} )_#_#_#+(tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_#+[| [| 0 0 |] [| 0 0 |] |]~#_#+[| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#+[| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#+[| [| 0 0 |] [| 0 0 |] |]~#_#+(tensor {2 2 2 2} {0 0 0 0 0 (* r^2 (sin θ)^2) (* -1 r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) (* r^2 (sin θ)^2) 0 0 0 0 0} )_#_#_#_#+[| [| 0 0 |] [| 0 0 |] |]_#_#+[| [| 0 (* r^2 (sin θ)^2) |] [| (* -1 r^2 (sin θ)^2) 0 |] |]_#_#+[| [| 0 (* -1 r^2 (sin θ)^2) |] [| (* r^2 (sin θ)^2) 0 |] |]_#_#+[| [| 0 0 |] [| 0 0 |] |]_#_#+[| [| 1 0 |] [| 0 (sin θ)^2 |] |]_#_#+(/ 2 r^2)+(tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#

@@ -0,0 +1,2 @@+(/ (+ -1 (sqrt 17) (* (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* -2 (sqrt 2) (sqrt (+ 17 (sqrt 17)))))))) 8)+(/ (+ -1 (sqrt 17) (* (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* -2 (sqrt 2) (sqrt (+ 17 (sqrt 17)))))))) 8)

@@ -0,0 +1,4 @@+<Straight-Flush>+<Full-House>+<Straight>+<One-Pair>

@@ -0,0 +1,4 @@+"Straight flush"+"Full house"+"Straight"+"Nothing"

@@ -0,0 +1,2 @@+{[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]}+{[5 7 11] [7 11 13] [11 13 17] [13 17 19] [17 19 23] [37 41 43] [41 43 47] [67 71 73] [97 101 103] [101 103 107]}

@@ -0,0 +1,68 @@+;;+;; Matchers+;;+(assert "bool's value pattern"+  (match [#t #f] [bool bool]+    {[[,#t ,#f] #t]+     [_ #f]}))++(assert "char's value pattern"+  (match c#a char+    {[,c#a #t]+     [_ #f]}))++(assert "integer's value pattern"+  (match 10 integer+    {[,10 #t]+     [_ #f]}))++(assert "float's value pattern"+  (match 0.1 float+    {[,0.1 #t]+     [_ #f]}))++;;+;; Utility+;;+(assert-equal "id"+  (id 1)+  1)++(assert-equal "fst"+  (fst [1 2])+  1)++(assert-equal "snd"+  (snd [1 2])+  2)++(assert-equal "compose - case 1"+  ((compose fst snd) [[1 2] 3])+  2)++(assert-equal "compose - case 2"+  ((compose fst snd fst) [[1 [2 3]] 4])+  2)++; (assert-equal "ref"+;  (ref (| 1 2 3 |) 2)+;  2)++(assert-equal "eq?/m"+  (eq?/m integer 1 1)+  #t)++;;+;; Booleans+;;+(assert-equal "and"+  [(and #t #t) (and #t #f) (and #f #t) (and #f #f)]+  [#t #f #f #f])++(assert-equal "or"+  [(or #t #t) (or #t #f) (or #f #t) (or #f #f)]+  [#t #t #t #f])++(assert-equal "not"+  [(not #t) (not #f)]+  [#f #t])

@@ -0,0 +1,417 @@+;;;;;+;;;;; Collection Test+;;;;;++;;;+;;; List Pattern-Matching+;;;+(assert "list's value pattern"+  (match {1 2 3} (list integer)+    {[,{@{@{1}} @{2 @{3}}} #t]+     [_ #f]}))++(assert "list's nil - case 1"+  (match {} (list integer)+    {[<nil> #t]+     [_ #f]}))++(assert "list's nil - case 2"+  (match {1} (list integer)+    {[<nil> #f]+     [_ #t]}))++(assert-equal "list's cons"+  (match {1 2 3} (list integer)+    {[<cons $n $ns> [n ns]]})+  [1 {2 3}])++(assert-equal "list's cons with value pattern"+  (match {1 2 3} (list integer)+    {[<cons ,1 $ns> ns]})+  {2 3})++(assert-equal "list's snoc"+  (match {1 2 3} (list integer)+    {[<snoc $n $ns> [n ns]]})+  [3 {1 2}])++(assert-equal "list's snoc with value pattern"+  (match {1 2 3} (list integer)+    {[<snoc ,3 $ns> ns]})+  {1 2})++(assert-equal "list's join"+  (match-all {1 2 3} (list integer)+    [<join $xs $ys> [xs ys]])+  {[{} {1 2 3}]+   [{1} {2 3}]+   [{1 2} {3}]+   [{1 2 3} {}]})++(assert-equal "list's join with value pattern"+  (match {1 2 3} (list integer)+    {[<join ,{1} $ns> ns]})+  {2 3})++(assert-equal "list's nioj"+  (match-all {1 2 3} (list integer)+    [<nioj $xs $ys> [xs ys]])+  {[{} {1 2 3}]+   [{3} {1 2}]+   [{2 3} {1}]+   [{1 2 3} {}]})++(assert-equal "list's nioj with value pattern"+  (match {1 2 3} (list integer)+    {[<nioj ,{3} $ns> ns]})+  {1 2})++;;;+;;; Multiset Pattern-Matching+;;;+(assert "multiset's nil - case 1"+  (match {} (multiset integer)+    {[<nil> #t]+     [_ #f]}))++(assert "multiset's nil - case 2"+  (match {1} (multiset integer)+    {[<nil> #f]+     [_ #t]}))++(assert "multiset's value pattern"+  (match {1 1 1 2 3} (multiset integer)+    {[,{@{@{1}} @{2 @{1 3}} 1} #t]+     [_ #f]}))++(assert-equal "multiset's cons"+  (match-all {1 2 3} (multiset integer)+    [<cons $n $ns> [n ns]])+  {[1 {2 3}] [2 {1 3}] [3 {1 2}]})++(assert-equal "multiset's cons with value pattern"+  (match {1 2 3} (multiset integer)+    {[<cons ,2 $ns> ns]})+  {1 3})++(assert-equal "multiset's join"+  (match-all {1 2 3} (multiset integer)+    [<join $xs $ys> [xs ys]])+  {[{} {1 2 3}] [{1} {2 3}] [{2} {1 3}] [{3} {1 2}] [{1 2} {3}] [{1 3} {2}] [{2 3} {1}] [{1 2 3} {}]})++(assert-equal "multiset's join with value pattern - case 1"+  (match {1 2 3} (multiset integer)+    {[<join ,{1} $ns> ns]})+  {2 3})++(assert-equal "multiset's join with value pattern - case 2"+  (match-all {1 2 3} (multiset integer)+    [<join ,{1 3} $ys> ys])+  {{2}})++(assert-equal "multiset's join with value pattern - case 3"+  (match-all {1 2 3} (multiset integer)+    [<join ,{1 5 3} $ys> ys])+  {})++;;;+;;; Set Pattern-Matching+;;;;+(assert "set's nil - case 1"+  (match {} (set integer)+    {[<nil> #t]+     [_ #f]}))++(assert "set's nil - case 2"+  (match {1} (set integer)+    {[<nil> #f]+     [_ #t]}))++(assert-equal "set's cons"+  (match-all {1 2 3} (set integer)+    [<cons $n $ns> [n ns]])+  {[1 {1 2 3}] [2 {1 2 3}] [3 {1 2 3}]})++(assert-equal "set's cons with value pattern"+  (match {1 2 3} (set integer)+    {[<cons ,2 $ns> ns]})+  {1 2 3})++(assert-equal "set's join"+  (match-all {1 2 3} (set integer)+    [<join $xs $ys> [xs ys]])+  {[{} {1 2 3}] [{1} {1 2 3}] [{2} {1 2 3}] [{3} {1 2 3}] [{1 2} {1 2 3}] [{1 3} {1 2 3}] [{2 3} {1 2 3}] [{1 2 3} {1 2 3}]})++(assert-equal "set's join with value pattern 1"+  (match-all {1 2 3} (set integer)+    [<join ,{1 3} $ys> ys])+  {{1 2 3}})++(assert-equal "set's join with value pattern 2"+  (match-all {1 2 3} (set integer)+    [<join ,{1 5 3} $ys> ys])+  {})++;;+;; Simple accessors+;;+(assert-equal "nth"+  (nth 1 {1 2 3})+  1)++(assert-equal "take"+  (take 2 {1 2 3})+  {1 2})++(assert-equal "drop"+  (drop 2 {1 2 3})+  {3})++(assert-equal "take-and-drop"+  (take-and-drop 2 {1 2 3})+  [{1 2} {3}])++(assert-equal "take-while"+  (take-while (lt? $ 10) primes)+  {2 3 5 7})++;;+;; cons, car, cdr+;;++(assert-equal "cons"+  (cons 1 {2 3})+  {1 2 3})++(assert-equal "car"+  (car {1 2 3})+  1)++(assert-equal "cdr"+  (cdr {1 2 3})+  {2 3})++(assert-equal "rac"+  (rac {1 2 3})+  3)++(assert-equal "rdc"+  (rdc {1 2 3})+  {1 2})++;;+;; List Functions+;;+(assert-equal "length"+  (length {1 2 3})+  3)++(assert-equal "map"+  (map (* $ 2) {1 2 3})+  {2 4 6})++(assert-equal "map2"+  (map2 (* $ $) {1 2 3} {10 20 30})+  {10 40 90}+  )++(assert-equal "filter"+  (let {[$odd? (lambda [$n] (eq? (modulo n 2) 1))]}+    (filter odd? {1 2 3}))+  {1 3})++(assert-equal "zip"+  (zip {1 2 3} {10 20 30})+  {[1 10] [2 20] [3 30]})++(assert-equal "lookup"+  (lookup 2 {[1 10] [2 20] [3 30]})+  20)++(assert-equal "foldr"+  (foldr (lambda [$n $ns] {n @ns}) {} {1 2 3})+  {1 2 3})++(assert-equal "foldl"+  (foldl (lambda [$ns $n] {n @ns}) {} {1 2 3})+  {3 2 1})++(assert-equal "scanl"+  (scanl (lambda [$r $n] (* r n)) 2 {2 2 2})+  {2 4 8 16})++(assert-equal "append"+  (append {1 2} {3 4 5})+  {1 2 3 4 5})++(assert-equal "concat"+  (concat {{1 2} {3 4 5}})+  {1 2 3 4 5})++(assert-equal "reverse"+  (reverse {1 2 3})+  {3 2 1})++(assert-equal "intersperse"+  (intersperse {0} {{1 2} {3 3} {4} {}})+  {{1 2} {0} {3 3} {0} {4} {0} {}})++(assert-equal "intercalate"+  (intercalate {0} {{1 2} {3 3} {4} {}})+  {1 2 0 3 3 0 4 0})++(assert-equal "split"+  (split {0} {1 2 0 3 3 0 4 0})+  {{1 2} {3 3} {4} {}})++(assert-equal "split/m"+  (split/m integer {0} {1 2 0 3 3 0 4 0})+  {{1 2} {3 3} {4} {}})++(assert-equal "find-cycle"+  (find-cycle {1 3 4 5 2 7 5 2 7 5 2 7})+  [{1 3 4} {5 2 7}])++(assert-equal "repeat"+  (take 5 (repeat {1 2 3}))+  {1 2 3 1 2})++(assert-equal "repeat1"+  (take 5 (repeat1 2))+  {2 2 2 2 2})++;;+;; Others+;;+(assert-equal "all - case 1"+  (all (eq? $ 1) {1 1 1})+  #t)++(assert-equal "all - case 2"+  (all (eq? $ 1) {1 1 2})+  #f)++(assert-equal "any - case 1"+  (any (eq? $ 1) {0 1 0})+  #t)++(assert-equal "any - case 2"+  (any (eq? $ 1) {0 0 0})+  #f)++(assert-equal "from"+  (take 3 (from 2))+  {2 3 4})++(assert-equal "between"+  (between 2 5)+  {2 3 4 5})++;;+;; Multiset Functions+;;+(assert-equal "add - case 1"+  (add 1 {2 3})+  {2 3 1})++(assert-equal "add - case 2"+  (add 1 {1 2 3})+  {1 2 3})++(assert-equal "add/m - case 1"+  (add/m integer 1 {2 3})+  {2 3 1})++(assert-equal "add/m - case 2"+  (add/m integer 1 {1 2 3})+  {1 2 3})++(assert-equal "delete-first"+  (delete-first 2 {1 2 3 2})+  {1 3 2})++(assert-equal "delete-first/m"+  (delete-first/m integer 2 {1 2 3 2})+  {1 3 2})++(assert-equal "delete"+  (delete 2 {1 2 3 1 2 3})+  {1 3 1 3})++(assert-equal "delete/m"+  (delete/m integer 2 {1 2 3 1 2 3})+  {1 3 1 3})++(assert-equal "difference"+  (difference {1 2 3} {1 3})+  {2})++(assert-equal "difference/m"+  (difference/m integer {1 2 3} {1 3})+  {2})++(assert-equal "union"+  (union {1 2 3} {1 3 4})+  {1 2 3 4})++(assert-equal "union/m"+  (union/m integer {1 2 3} {1 3 4})+  {1 2 3 4})++(assert-equal "intersect"+  (intersect {1 2 3} {1 3 4})+  {1 3})++(assert-equal "intersect/m"+  (intersect/m integer {1 2 3} {1 3 4})+  {1 3})++;;+;; Simple predicate+;;++(assert-equal "member? - case 1"+  (member? 1 {1 3 1 4})+  #t)++(assert-equal "member? - case 2"+  (member? 2 {1 3 1 4})+  #f)++(assert-equal "member?/m - case 1"+  (member?/m integer 1 {1 3 1 4})+  #t)++(assert-equal "member?/m - case 2"+  (member?/m integer 2 {1 3 1 4})+  #f)++;;+;; Counting+;;+(assert-equal "count"+  (count 1 {1 3 1 4})+  2)++(assert-equal "count/m"+  (count/m integer 1 {1 3 1 4})+  2)++(assert-equal "frequency"+  (frequency {1 3 1 4})+  {[1 2] [3 1] [4 1]})++(assert-equal "frequency/m"+  (frequency/m integer {1 3 1 4})+  {[1 2] [3 1] [4 1]})++;;+;; Set Functions+;;+(assert-equal "unique"+  (unique {1 2 3 2 1 4})+  {1 2 3 4})++(assert-equal "unique/m"+  (unique/m integer {1 2 3 2 1 4})+  {1 2 3 4})

@@ -0,0 +1,143 @@+;;+;; Matcher+;;+(assert-equal "nat's o - case 1"+  (match 0 nat+    {[<o> #t]+     [_ #f]})+  #t)++(assert-equal "nat's o - case 2"+  (match 1 nat+    {[<o> #t]+     [_ #f]})+  #f)++(assert-equal "nat's s - case 1"+  (match 10 nat+    {[<s $n> n]})+  9)++(assert-equal "nat's s - case 2"+  (match 0 nat+    {[<s <o>> #t]+     [_ #f]})+  #f)++;;+;; Sequences+;;+(assert-equal "nats"+  (take 10 nats)+  {1 2 3 4 5 6 7 8 9 10})++(assert-equal "nats0"+  (take 10 nats0)+  {0 1 2 3 4 5 6 7 8 9})++(assert-equal "odds"+  (take 10 odds)+  {1 3 5 7 9 11 13 15 17 19})++(assert-equal "evens"+  (take 10 evens)+  {2 4 6 8 10 12 14 16 18 20})++(assert-equal "primes"+  (take 10 primes)+  {2 3 5 7 11 13 17 19 23 29})++;;+;; Natural numbers+;;+(assert-equal "divisor?"+  (divisor? 10 5)+  #t)++(assert-equal "find-factor"+  (find-factor 100)+  2)++(assert-equal "p-f"+  (p-f 100)+  {2 2 5 5})++(assert-equal "odd? - case 1"+  (odd? 3)+  #t)++(assert-equal "odd? - case 2"+  (odd? 4)+  #f)++(assert-equal "even? - case 1"+  (even? 4)+  #t)++(assert-equal "even? - case 2"+  (even? 5)+  #f)++(assert-equal "prime? - case 1"+  (prime? 17)+  #t)++(assert-equal "prime? - case 2"+  (prime? 18)+  #f)++(assert-equal "perm"+  (perm 5 2)+  20)++(assert-equal "comb"+  (comb 5 2)+  10)++(assert-equal "n-adic - case 1"+  (n-adic 10 123)+  {1 2 3})++(assert-equal "n-adic - case 2"+  (n-adic 2 10)+  {1 0 1 0})++;;+;; Dicimal fractions+;;+(assert-equal "rtod"+  (2#[%1 (take 10 %2)] (rtod (/ 6 35)))+  [0 {1 7 1 4 2 8 5 7 1 4}])++(assert-equal "rtod'"+  (rtod' (/ 6 35))+  [0 {1} {7 1 4 2 8 5}])++(assert-equal "show-decimal"+  (show-decimal 10 (/ 6 35))+  "0.1714285714")++(assert-equal "show-decimal'"+  (show-decimal' (/ 6 35))+  "0.1 714285 ...")++(assert-equal "regular-continued-fraction sqrt of 2"+  (rtof (regular-continued-fraction 1 {2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2}))+  1.4142135623730951)++(assert-equal "regular-continued-fraction pi"+  (rtof (regular-continued-fraction 3 {7 15 1 292 1 1 1 2 1 3 1 14 2 1 1 2 2 2 2 1 84 2 1 1 15 3 13}))+  3.141592653589793)++(assert-equal "continued-fraction pi"+  (rtof (continued-fraction 3 {7 15 1 292 1 1 1 2 1 3 1 14 2 1 1 2 2 2 2 1 84 2 1 1 15 3 13}+                              {1 1  1 1   1 1 1 1 1 1 1 1  1 1 1 1 1 1 1 1 1  1 1 1 1  1 1}))+  3.141592653589793)++(assert-equal "regular-continued-fraction-of-sqrt case 1"+  (2#[%1 (take 10 %2)] (regular-continued-fraction-of-sqrt 2))+  [1 {2 2 2 2 2 2 2 2 2 2}])+  +(assert-equal "regular-continued-fraction-of-sqrt case 2"+  (rtof (regular-continued-fraction (2#[%1 (take 100 %2)] (regular-continued-fraction-of-sqrt 2))))+  1.4142135623730951)

@@ -0,0 +1,35 @@+(assert-equal "compare - case 1"+  (compare 10 10)+  <Equal>)++(assert-equal "compare - case 2"+  (compare 11 10)+  <Greater>)++(assert-equal "compare - case 3"+  (compare 10 11)+  <Less>)++(assert-equal "min"+  (min {20 5})+  5)++(assert-equal "min/fn"+  (min/fn compare {10 20 5 20 30})+  5)++(assert-equal "max"+  (max {5 30})+  30)++(assert-equal "max/fn"+  (max/fn compare {10 20 5 20 30})+  30)++(assert-equal "sort"+  (sort {10 20 5 20 30})+  {5 10 20 20 30})++(assert-equal "sort/fn"+  (sort/fn compare {10 20 5 20 30})+  {5 10 20 20 30})

@@ -0,0 +1,99 @@+(assert "string's value pattern"+  (match "abc" string+    {[,"abc" #t]+     [_ #f]}))++(assert "string's nil - case 1"+  (match "" string+    {[<nil> #t]+     [_ #f]}))++(assert "string's nil - case 2"+  (match "abc" string+    {[<nil> #f]+     [_ #t]}))++(assert-equal "string's cons"+  (match-all "abc" string+    [<cons $x $xs> [x xs]])+  {[c#a "bc"]})++(assert-equal "string's join"+  (match-all "abc" string+    [<join $xs $ys> [xs ys]])+  {["" "abc"] ["a" "bc"]+   ["ab" "c"] ["abc" ""]})++;;;+;;; String as collection+;;;+(assert-equal "S.empty? - case 1"+  (S.empty? "")+  #t)++(assert-equal "S.empty? - case 2"+  (S.empty? "Egison")+  #f)++(assert-equal "S.car"+  (S.car "Egison")+  c#E)++(assert-equal "S.cdr"+  (S.cdr "Egison")+  "gison")++(assert-equal "S.rac"+  (S.rac "Egison")+  c#n)++(assert-equal "S.map"+  (S.map id "Egison")+  "Egison")++(assert-equal "S.length"+  (S.length "Egison")+  6)++(assert-equal "S.split"+  (S.split "," "Lisp,Haskell,Egison")+  {"Lisp" "Haskell" "Egison"})++(assert-equal "S.append"+  (S.append "Egi" "son")+  "Egison")++(assert-equal "S.concat"+  (S.concat {"Egi" "son"})+  "Egison")++(assert-equal "S.intercalate"+  (S.intercalate "," {"Lisp" "Haskell" "Egison"})+  "Lisp,Haskell,Egison")++;;+;; Characters+;;+(assert-equal "C.between"+  (C.between c#a c#c)+  {c#a c#b c#c})++(assert-equal "C.between?"+  (C.between? c#a c#c c#b)+  #t)++(assert-equal "alphabet?"+  (alphabet? c#a)+  #t)++(assert-equal "alphabets?"+  (alphabets? "Egison")+  #t)++(assert-equal "upper-case"+  (upper-case c#e)+  c#E)++(assert-equal "lower-case"+  (lower-case c#E)+  c#e)

@@ -0,0 +1,15 @@+(assert-equal "q-f' - case 1"+  (q-f' 1 2 1)+  [-1 -1])++(assert-equal "q-f' - case 2"+  (q-f' 1 1 -1)+  [(/ (+ -1 (sqrt 5)) 2) (/ (+ -1 (* -1 (sqrt 5))) 2)])++(assert-equal "q-f' - case 3"+  (q-f' 1 (* -1 (/ (+ -1 (sqrt 5)) 2)) 1)+  [(/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4) (/ (+ -1 (sqrt 5) (* -1 (sqrt (+ -10 (* -2 (sqrt 5)))))) 4)])++(assert-equal "fifth root of unity"+  (** (/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4) 5)+  1)

@@ -0,0 +1,41 @@+(assert-equal "d/d - case 1"+  (d/d (** x 2) x)+  (* 2 x))++(assert-equal "d/d - case 2"+  (d/d (** a (** x 2)) x)+  (* 2 (** a x^2) (log a) x))++(assert-equal "d/d - case 3"+  (d/d (* (cos x) (sin x)) x)+  (+ (* -1 (sin x)^2) (cos x)^2))++(assert-equal "d/d - case 4"+  (d/d (sigmoid z) z)+  (/ (exp (* -1 z)) (+ 1 (* 2 (exp (* -1 z))) (exp (* -1 z))^2)))++(assert-equal "d/d - case 5"+  (d/d (d/d (log x) x) x)+  (/ -1 x^2))++(assert-equal "tailor-expansion - case 1"+  (take 4 (taylor-expansion (** e (* i x)) x 0))+  {1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6)})++(assert-equal "tailor-expansion - case 2"+  (take 4 (taylor-expansion (* i (sin x)) x 0))+  {0 (* i x) 0 (/ (* -1 i x^3) 6)})++;(assert-equal "multivariate-tailor-expansion - case 1"+;  (take 3 (multivariate-taylor-expansion (f x y) [| x y |] [| 0 0 |]))+;  {(f 0 0) (+ (* x (f|1 0 0)) (* y (f|2 0 0))) (/ (+ (* x^2 (f|1|1 0 0)) (* 2 x y (f|1|2 0 0)) (* y^2 (f|2|2 0 0))) 2)})++(assert-equal "multivariate-tailor-expansion - case 2"+  (take 3 (multivariate-taylor-expansion (** e (+ x y)) [| x y |] [| 0 0 |]))+  {1 (+ x y) (/ (+ x^2 (* 2 x y) y^2) 2)})++(assert-equal "function expr"+  (let {[$f (function [x y])]}+    (d/d f y))+  (let {[$f (function [x y])]}+    (user-refs f {y})))

@@ -0,0 +1,31 @@+(assert-equal "sum"+  (sum (take 5 nats))+  15)++(assert-equal "product"+  (product (take 5 nats))+  120)++(assert-equal "power"+  (power 2 5)+  32)++(assert-equal "** - case 1"+  (power x 3)+  x^3)++(assert-equal "** - case 2"+  (power (sqrt 2) 4)+  4)++(assert-equal "gcd"+  (gcd 15 40)+  5)++(assert-equal "sqrt - case 1"+  (sqrt (/ (* 50 x^2) y))+  (/ (* 5 x (sqrt (* 2 y))) y))++(assert-equal "sqrt - case 2"+  (* (sqrt (* 3 x)) (sqrt (* 2 y)))+  (* (sqrt 6) (sqrt x) (sqrt y)))

@@ -0,0 +1,85 @@+(assert-equal "Tensor product - case 1"+  (. [| [| 1 1 |] [| 0 1 |] |]~i~j [| [| 1 1 |] [| 0 1 |] |]_j_k)+  [| [| 1 2 |] [| 0 1 |] |])++(assert-equal "Tensor product - case 2"+  (. [| [| 1 1 |] [| 0 1 |] |]~i~j [| [| 1 1 |] [| 0 1 |] |]_j~k [| [| 1 1 |] [| 0 1 |] |]_k_l)+  [| [| 1 3 |] [| 0 1 |] |]~i_l)++(assert-equal "Vector *"+  (V.* [| 1 1 0 |] [| 10 5 10 |])+  15)++(assert-equal "Matrix * - case 1"+  (M.* [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |])+  [| [| 1 2 |] [| 0 1 |] |])++(assert-equal "Matrix * - case 2"+  (M.* [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |])+  [| [| 1 3 |] [| 0 1 |] |])++(assert-equal "Tensor '+' - case 1"+  (+ 1 [|1 2 3|])+  [|2 3 4|])++(assert-equal "Tensor '+' - case 2"+  (+ [|1 2 3|] 1)+  [|2 3 4|])++(assert-equal "Tensor '+' - case 3"+  (+ [|[|11 12|]+       [|21 22|]+       [|31 32|]|]_i_j+     [|100 200 300|]_i)+  [| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j)++(assert-equal "Tensor '+' - case 4"+  (+ [|100 200 300|]_i+     [|[|11 12|]+       [|21 22|]+       [|31 32|]|]_i_j)+  [| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j)++(assert-equal "Tensor '+' - case 5"+  (+ [|[|1 2 3|]+       [|10 20 30|]|]_i_j+     [|100 200 300|]_j)+  [| [| 101 202 303 |] [| 110 220 330 |] |]_i_j)++(assert-equal "Tensor '+' - case 6"+  (+ [|100 200 300|]_j+     [|[|1 2 3|]+       [|10 20 30|]|]_i_j)+  [| [| 101 110 |] [| 202 220 |] [| 303 330 |] |]_j_i)++;(assert-equal "Tensor ∂/∂ - case 1"+;  (∂/∂ [|(f x) (g x)|] x)+;  [|(f|1 x) (g|1 x)|])++;(assert-equal "Tensor ∂/∂ - case 2"+;  (∂/∂ (f x y z) [|x y z|])+;  [|(f|1 x y z) (f|2 x y z) (f|3 x y z)|])++;(assert-equal "Tensor ∂/∂ - case 3"+;  (apply [|(∂/∂ $ x) (∂/∂ $ y)|] (f x y))+;  [|(f|1 x y) (f|2 x y)|])++(assert-equal "append indices with ..."+  (show (let {[$A (generate-tensor 2#1 {2 2})]+              [$f (lambda [%B] B..._j)]}+          (f A_i)))+  (show [| [| 1 1 |] [| 1 1 |] |]_i_j))++(assert-equal "generate_tensor by using function expr"+  (letrec {[$g__ (generate-tensor+                    (match-lambda [integer integer]+                      {[[$n ,n] (function [x y z])]+                       [[_ _] 0]})+                    {3 3})]}+     (show (with-symbols {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 |] |]")++(assert-equal "define tensor having value of function expr"+  (letrec {[$g__ [| [| (function [x y z]) 0 0 |] [| 0 (function [x y z]) 0 |] [| 0 0 (function [x y z]) |] |]]}+     (show (with-symbols {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 |] |]")

@@ -0,0 +1,15 @@+(assert-equal "less than predicate"+  [(lt? 0.1 1.0) (lt? 1.0 0.1) (lt? 1.0 1.0)]+  [#t #f #f])++(assert-equal "less than or equal predicate"+  [(lte? 0.1 1.0) (lte? 1.0 0.1) (lte? 1.0 1.0)]+  [#t #f #t])++(assert-equal "greater than predicate"+  [(gt? 0.1 1.0) (gt? 1.0 0.1) (gt? 1.0 1.0)]+  [#f #t #f])++(assert-equal "greater than or equal predicate"+  [(gte? 0.1 1.0) (gte? 1.0 0.1) (gte? 1.0 1.0)]+  [#f #t #t])

@@ -0,0 +1,451 @@+;;;;;+;;;;; Syntax Test+;;;;;++;;;+;;; Primitive Data+;;;+(assert-equal "char literal"+  c#a+  c#a)++(assert-equal "string literal"+  "abc\n"+  "abc\n")++(assert-equal "bool literal"+  [#t #f]+  [#t #f])++(assert-equal "integer literal"+  [1 0 -100 (+ 1 -100)]+  [1 0 -100 -99])++(assert-equal "rational number"+  [(/ 10 3) (/ 10 20) (/ -1 2)]+  [(/ 10 3) (/ 1 2) (/ -1 2)])++(assert-equal "float literal"+  [1.0 0.0 -100.012001 (+ 1.0 2)]+  [1.0 0.0 -100.012001 3.0])++(assert-equal "inductive data literal"+  <A>+  <A>)++(assert-equal "tuple literal"+  [1 2 3]+  [1 2 3])++(assert-equal "singleton tuple literal"+  [1]+  1)++(assert-equal "collection literal"+  {1 @{2 3 @{@{4} 5}} 6}+  {1 2 3 4 5 6})++;;;+;;; Basic Sytax+;;;+(assert-equal "if"+  (if #t #t #f)+  #t)++(assert-equal "if"+  (if #f #t #f)+  #f)++(assert-equal "let binding"+  (let {[$t [1 2]]}+    (let {[[$x $y] t]}+      (+ x y)))+  3)++(assert-equal "let* binding"+  (let* {[$x 1] [$y (+ x 1)]} y)+  2)++(assert-equal "letrec binding"+  (letrec {[[$x $y] t]+           [$t [1 2]]}+    (+ x y))+  3)++(assert-equal "mutual recursion"+  (letrec {[$even? (lambda [$n]+                     (if (eq? n 0) #t (odd? (- n 1))))]+           [$odd? (lambda [$n]+                    (if (eq? n 0) #f (even? (- n 1))))]}+    (even? 10))+  #t)++(assert-equal "lambda and application"+  ((lambda [$x] (+ 1 x)) 10)+  11)++(assert-equal "placeholder"+  ((+ $ 1) 10)+  11)++(assert-equal "indexed placeholder"+  ((+ $1 $1) 10)+  20)++(assert-equal "indexed placeholder2"+  ((- $2 $1) 10 20)+  10)++;;;+;;; Pattern-Matching+;;;+(assert-equal "match"+  (match 1 integer+    {[,0 0]+     [$x (+ 10 x)]})+  11)++(assert-equal "match-all"+  (match-all {1 2 3} (list integer)+    [<cons $x $xs> [x xs]])+  {[1 {2 3}]})++(assert-equal "match-all-multi"+  (match-all {1 2 3} (multiset integer)+    {[<cons $x <cons ,(+ x 1) _>> [x (+ x 1)]]+     [<cons $x <cons ,(+ x 2) _>> [x (+ x 2)]]})+  {[1 2] [2 3] [1 3]})++(assert-equal "match-lambda"+  (letrec {[$count (match-lambda (list something)+                     {[<nil> 0]+                      [<cons _ $xs> (+ (count xs) 1)]})]}+    (count {1 2 3}))+  3)++(assert-equal "match-all-lambda"+  ((match-all-lambda (list something) [<join _ <cons $x _>> x]) {1 2 3})+  {1 2 3})++(assert-equal "match-all-lambda-multi"+  ((match-all-lambda (multiset something)+     {[<cons $x <cons ,(+ x 1) _>> [x (+ x 1)]]+      [<cons $x <cons ,(+ x 2) _>> [x (+ x 2)]]}) {1 2 3})+  {[1 2] [2 3] [1 3]})++(assert-equal "pattern variable"+  (match 1 something+    {[$x x]})+  1)++(assert "value pattern"+  (match 1 integer+    {[,1 #t]}))++(assert "and pattern"+  (match {1 2 3} (list integer)+    {[(& <cons ,1 _> <snoc ,3 _>) #t]}))++(assert "and pattern"+  (match {1 2 3} (list integer)+    {[(& <cons ,1 _> <cons ,3 _>) #f]+     [_ #t]}))++(assert "and pattern"+  (match #t something+    {[(&) #t]}))++(assert "or pattern"+  (match {1 2 3} (list integer)+    {[(| <snoc ,1 _> <snoc ,3 _>) #t]}))++(assert "or pattern"+  (match {1 2 3} (list integer)+    {[(| <cons ,2 _> <cons ,3 _>) #f]+     [_ #t]}))++(assert "or pattern"+  (match #t something+    {[(|) #f]+     [_ #t]}))++;(assert-equal "ordered or pattern"+;  (match {1 2 3 4 5} (list integer) {[<join (|* ,{2} ,{1 2 3} ,{1}) $xs> xs]})+;  {4 5})++;(assert-equal "ordered or pattern"+;  (let {[$x [| 1 2 3 |]]}+;    (match-all {2 1 3} (multiset integer)+;      [<cons (& (|* !,x_1 ,x_1) $y_1)+;             <cons (& (|* !,x_2 ,x_2) $y_2)+;                   <cons (& (|* !,x_3 ,x_3) $y_3) <nil>>>> (map 1#y_%1 (between 1 3))]))+;  {{2 3 1} {3 1 2} {2 1 3} {3 2 1} {1 3 2} {1 2 3}})++;(assert "ordered or pattern"+;  (match {1 2 3} (list integer)+;    {[(|* <cons ,2 _> <cons ,3 _>) #f]+;     [_ #t]}))++(assert "not pattern"+  (match 1 integer+    {[!,1 #f]+     [!,2 #t]}))++(assert-equal "not pattern"+  (match-all {1 2 2 3 3 3} (multiset integer)+    [<cons $n !<cons ,n _>> n])+  {1})++(assert-equal "later pattern"+  (match-all {1 1 2} (list integer)+    [<cons (later ,n) <cons $n _>> n])+  {1})++(assert "predicate pattern"+  (match {1 2 3} (list integer)+    {[<cons ?(eq? 1 $) _> #t]}))++(assert "predicate pattern"+  (match {1 2 3} (list integer)+    {[<cons ?(eq? 2 $) _> #f]+     [_ #t]}))++(assert-equal "indexed pattern variable"+  (match 23 (mod 10) {[$a_1 a]})+  {| [1 23] |})++(assert-equal "seq pattern"+  (match-all {1 2 3 2 4 3 5} (list integer)+    [{<join #                     <cons $x _>>+            !<join _ <cons ,x _>>             }+   x])+  {1 2 3 4 5})++;(assert-equal "dfs pattern 1"+;  (take 10 (match-all nats (set integer)+;       [(dfs <cons $m <cons $n <cons $l _>>>) [m n l]]))+;  {[1 1 1] [1 1 2] [1 1 3] [1 1 4] [1 1 5] [1 1 6] [1 1 7] [1 1 8] [1 1 9] [1 1 10]})++;(assert-equal "dfs pattern 2"+;  (take 10 (match-all nats (set integer)+;       [<cons $m (dfs <cons $n <cons $l _>>)> [m n l]]))+;  {[1 1 1] [2 1 1] [3 1 1] [4 1 1] [5 1 1] [6 1 1] [7 1 1] [8 1 1] [9 1 1] [10 1 1]})++;(assert-equal "dfs pattern 3"+;  (match-all (between 1 3) (set integer)+;       [<cons $m <cons $n (dfs <cons $l _>)>> [m n l]])+;  {[1 1 1] [1 2 1] [2 1 1] [1 3 1] [2 2 1] [3 1 1] [2 3 1] [3 2 1] [3 3 1] [1 1 2] [1 2 2] [2 1 2] [1 3 2] [2 2 2] [3 1 2] [2 3 2] [3 2 2] [3 3 2] [1 1 3] [1 2 3] [2 1 3] [1 3 3] [2 2 3] [3 1 3] [2 3 3] [3 2 3] [3 3 3]})++;(assert-equal "dfs and bfs pattern 1"+;  (take 10 (match-all nats (set integer)+;       [(dfs <cons $m (bfs <cons $n <cons $l _>>)>) [m n l]]))+;  {[1 1 1] [1 1 2] [1 2 1] [1 1 3] [1 2 2] [1 3 1] [1 1 4] [1 2 3] [1 3 2] [1 4 1]})++;(assert-equal "dfs and bfs pattern 2"+;  (take 10 (match-all nats (set integer)+;       [(dfs <cons $m <cons $n (bfs <cons $l _>)>>) [m n l]]))+;  {[1 1 1] [1 1 2] [1 1 3] [1 1 4] [1 1 5] [1 1 6] [1 1 7] [1 1 8] [1 1 9] [1 1 10]})++(assert "loop pattern"+  (match {3 2 1} (list integer)+    {[(loop $i [1 {3} _] <snoc ,i ...> <nil>) #t]}))++(assert-equal "double loop pattern"+  (match {{1 2 3} {4 5 6} {7 8 9}} (list (list integer))+    {[(loop $i [1 {3} _]+        <cons (loop $j [1 {3} _]+                <cons $n_i_j ...>+                <nil>) ...>+        <nil>)+      n]})+  {|[1 {|[1 1] [2 2] [3 3]|}] [2 {|[1 4] [2 5] [3 6]|}] [3 {|[1 7] [2 8] [3 9]|}]|})++(assert-equal "let pattern"+  (match {1 2 3} (list integer)+    {[(let {[$a 42]} _) a]})+  42)++(assert-equal "let pattern"+  (match {1 2 3} (list integer)+    {[<cons $a (let {[$x a]} $xs)> [x xs]]})+  [1 { 2 3 }])++(assert-equal "let pattern"+  (match {1 2 3} (list integer)+    {[(& $a (let {[$n (length a)]} _)) [a n]]})+  [{1 2 3} 3])++(assert-equal "tuple patterns"+  (match-all [1 [2 3]] [integer [integer integer]]+    [[$m [$n $w]] [m n w]])+  {[1 2 3]})++(assert-equal "pattern function call"+  (letrec {[$twin (pattern-function [$pat1 $pat2]+                    <cons (& pat1 $x) <cons ,x pat2>>)+            ]}+    (match {1 1 1 2 3} (list integer)+      {[(twin $n $ns) [n ns]]}))+  [1 {1 2 3}])++(assert-equal "recursive pattern function call"+  (letrec {[$repeat (pattern-function [$pat]+                      (| <nil>+                         <cons (& pat $x) (repeat ,x)>))+            ]}+    (match {1 1 1 1} (list integer)+      {[(repeat $n) n]}))+  1)++(assert-equal "loop pattern in pattern function"+  (letrec {[$comb (lambda [$n]+                    (pattern-function [$p]+                      (loop $i [1 {n} _]+                        <join _ <cons p_i ...>>+                        _)))+           ]}+    (match-all {1 2 3 4 5} (list integer)+      [((comb 2) $n) n]))+  {{|[1 1] [2 2]|} {|[1 1] [2 3]|} {|[1 2] [2 3]|} {|[1 1] [2 4]|} {|[1 2] [2 4]|} {|[1 3] [2 4]|} {|[1 1] [2 5]|} {|[1 2] [2 5]|} {|[1 3] [2 5]|} {|[1 4] [2 5]|}})++(assert-equal "pairs of 2 natural numbers"+  (take 10 (match-all nats (set integer)+             [<cons $m <cons $n _>> [m n]]))+  {[1 1] [1 2] [2 1] [1 3] [2 2] [3 1] [1 4] [2 3] [3 2] [4 1]})++(assert-equal "pairs of 2 different natural numbers"+  (take 10 (match-all nats (list integer)+             [<join _ <cons $m <join _ <cons $n _>>>> [m n]]))+  {[1 2] [1 3] [2 3] [1 4] [2 4] [3 4] [1 5] [2 5] [3 5] [4 5]})++(define $tree+  (lambda [$a]+    (algebraic-data-matcher+      {<leaf> <node (tree a) a (tree a)>})))++(define $tree-insert+  (lambda [$n $t]+    (match t (tree integer)+      {[<leaf> <Node <Leaf> n <Leaf>>]+       [<node $t1 $m $t2>+        (match (compare n m) ordering+          {[<less> <Node (tree-insert n t1) m t2>]+           [<equal> <Node t1 n t2>]+           [<greater> <Node t1 m (tree-insert n t2)>]})]})))++(define $tree-member?+  (lambda [$n $t]+    (match t (tree integer)+      {[<leaf> #f]+       [<node $t1 $m $t2>+        (match (compare n m) ordering+          {[<less> (tree-member? n t1)]+           [<equal> #t]+           [<greater> (tree-member? n t2)]})]})))++(assert-equal "tree set using algebraic-data-matcher"+  (let {[$t (foldr tree-insert <Leaf> {4 1 2 4 3})]}+    [(tree-member? 1 t) (tree-member? 0 t)])+  [#t #f])++(assert-equal "tuple pattern"+  (match-all {[1 1] [2 2]} (multiset [integer integer]) [<cons [$x ,x] _> x])+  {1 2})+++;;;+;;; Array+;;;++(assert-equal "array-literal"+  (| 1 2 3 4 5 |)+  (| 1 2 3 4 5 |)+  )++(assert-equal "empty array literal"+  (||)+  (||)+  )++(assert-equal "generate-array"+  (generate-array (+ $ 100) [3 5])_4+  104+  )++(assert-equal "array-bounds - case 1"+  (array-bounds (| 1 2 3 |))+  [1 3]+  )++(assert-equal "array-bounds - case 2"+  (array-bounds (generate-array (+ $ 100) [3 5]))+  [3 5]+  )++(assert-equal "array-ref"+  (array-ref (| 1 2 3 4 5 |) 3)+  3)++;;;+;;; Tensor+;;;+(assert-equal "generate-tensor - case 1"+  (generate-tensor kronecker-delta {3})+  [| 1 1 1 |])++(assert-equal "generate-tensor - case 2"+  (generate-tensor kronecker-delta { 2 2 2 2 })+  (tensor {2 2 2 2} {1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1} ))++;;;+;;; Hash+;;;+(assert-equal "hash-literal"+  {| [1 11] [2 12] [3 13] [4 14] [5 15] |}+  {| [1 11] [2 12] [3 13] [4 14] [5 15] |}+  )++(assert-equal "empty hash-literal"+  {| |}+  {| |}+  )++(assert-equal "hash access"+  {| [1 11] [2 12] [3 13] [4 14] [5 15] |}_3+  13+  )++;(assert-equal "string hash access"+;  {| ["1" 11] ["2" 12] ["3" 13] ["4" 14] ["5" 15] |}_"3"+;  13+;  )++;;;+;;; Partial Application+;;;+(assert-equal "partial application '$'"+  ((+ $ $) 1 2)+  3)++(assert-equal "partial application '$' with index"+  ((- $2 $1) 1 2)+  1)++(assert-equal "partial application '#'"+  (2#(+ (* 10 %1) %2) 1 2)+  12)++(assert-equal "recursive partial application '#'"+  (take 10 (1#{%1 @(%0 (* %1 2))} 2))+  {2 4 8 16 32 64 128 256 512 1024})++(assert-equal "double inverted index"+  (let {[$f (lambda [*$x *$y] (+ x y))]}+    [(f [|1 2 3|]_i [|10 20 30|]_j)])+  [[| [| 11 21 31 |] [| 12 22 32 |] [| 13 23 33 |] |]~i~j])++(assert-equal "single inverted index"+  (let {[$f (lambda [$x *$y] (+ x y))]}+    [(f [|1 2 3|]_i [|10 20 30|]_j)])+  [[| [| 11 21 31 |] [| 12 22 32 |] [| 13 23 33 |] |]_i~j])+