egison 3.9.4 → 3.10.0

raw patch · 32 files changed

+1305/−932 lines, 32 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• egison.cabal +5/−2
• hs-src/Interpreter/egison.hs +2/−100
• hs-src/Language/Egison.hs +5/−1
• hs-src/Language/Egison/AST.hs +360/−0
• hs-src/Language/Egison/CmdOptions.hs +136/−0
• hs-src/Language/Egison/Core.hs +46/−104
• hs-src/Language/Egison/Desugar.hs +9/−13
• hs-src/Language/Egison/Parser.hs +16/−15
• hs-src/Language/Egison/ParserNonS.hs +34/−27
• hs-src/Language/Egison/Pretty.hs +261/−8
• hs-src/Language/Egison/Primitives.hs +41/−5
• hs-src/Language/Egison/Types.hs +75/−460
• hs-src/Language/Egison/Util.hs +2/−1
• hs-src/Tool/translator.hs +13/−13
• lib/core/sexpr.egi +6/−0
• nons-test/test/dp.egi +47/−0
• nons-test/test/lib/core/base.egi +10/−3
• nons-test/test/lib/core/order.egi +9/−9
• nons-test/test/poker.egi +39/−0
• nons-test/test/primitive.egi +2/−2
• nons-test/test/syntax.egi +96/−91
• sample/mahjong.egi +14/−10
• sample/math/others/mobius-transformation.egi +3/−2
• sample/poker-hands-with-joker.egi +28/−21
• sample/poker-hands.egi +28/−21
• sample/primes.egi +6/−3
• test/Test.hs +10/−7
• test/answer/sample/mahjong.egi +0/−2
• test/answer/sample/poker-hands-with-joker.egi +0/−4
• test/answer/sample/poker-hands.egi +0/−4
• test/answer/sample/primes.egi +0/−2
• test/lib/math/tensor.egi +2/−2

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.9.4+Version:             3.10.0 Synopsis:            Programming language with non-linear pattern-matching against non-free data Description:   An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.@@ -63,7 +63,7 @@                      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+                     test/answer/sample/math/geometry/*.egi test/answer/sample/math/number/*.egi                      elisp/egison-mode.el  @@ -93,13 +93,16 @@     , vector     , split     , hashable+    , optparse-applicative     , prettyprinter   if !impl(ghc > 8.0)     Build-Depends: fail   Hs-Source-Dirs:  hs-src   Exposed-Modules:                    Language.Egison+                   Language.Egison.AST                    Language.Egison.Core+                   Language.Egison.CmdOptions                    Language.Egison.Desugar                    Language.Egison.Types                    Language.Egison.Parser

@@ -9,8 +9,6 @@ import           Control.Monad.Trans.State import           Prelude                    hiding (catch) -import           Data.Char-import           Data.Semigroup             ((<>)) import qualified Data.Text                  as T  import           Data.Version@@ -22,111 +20,15 @@ import           System.IO  import           Language.Egison+import           Language.Egison.CmdOptions import           Language.Egison.Core       (recursiveBind) import           Language.Egison.MathOutput import           Language.Egison.Util  import           Options.Applicative - main :: IO ()-main = execParser parserInfo >>= runWithOptions--parserInfo :: ParserInfo EgisonOpts-parserInfo = info (helper <*> parser)-              $ fullDesc-              <> header "The Egison Programming Language"- where-  parser = EgisonOpts-            <$> optional ((,) <$> strArgument (metavar "FILE") <*> many (strArgument (metavar "ARGS")))-            <*> switch-                  (short 'v'-                  <> long "version"-                  <> help "Show version number")-            <*> optional (strOption-                  (short 'e'-                  <> long "eval"-                  <> metavar "EXPR"-                  <> help "Evaluate the argument string"))-            <*> optional (strOption-                  (short 'c'-                  <> long "command"-                  <> metavar "EXPR"-                  <> help "Execute the argument string"))-            <*> many (readFieldOption <$> strOption-                  (short 'F'-                  <> long "field"-                  <> metavar "FIELD"-                  <> help "Field information"))-            <*> many (strOption-                  (short 'L'-                  <> long "load-library"-                  <> metavar "FILE"-                  <> help "Load library"))-            <*> many (strOption-                  (short 'l'-                  <> long "load-file"-                  <> metavar "FILE"-                  <> help "Load file"))-            <*> optional (strOption-                  (short 's'-                  <> long "substitute"-                  <> metavar "EXPR"-                  <> help "Operate input in tsv format as infinite stream"))-            <*> optional ((\s -> "(map " ++ s ++ " $)") <$> strOption-                  (short 'm'-                  <> long "map"-                  <> metavar "EXPR"-                  <> help "Operate input in tsv format line by line"))-            <*> optional ((\s -> "(filter " ++ s ++ " $)") <$> strOption-                  (short 'f'-                  <> long "filter"-                  <> metavar "EXPR"-                  <> help "Filter input in tsv format line by line"))-            <*> switch-                  (short 'T'-                  <> long "tsv"-                  <> help "Output in tsv format")-            <*> switch-                  (long "no-io"-                  <> help "Prohibit all io primitives")-            <*> flag True False-                  (long "no-banner"-                  <> help "Do not display banner")-            <*> switch-                  (short 't'-                  <> long "test"-                  <> help "Execute only test expressions")-            <*> strOption-                  (short 'p'-                  <> long "prompt"-                  <> metavar "STRING"-                  <> value "> "-                  <> help "Set prompt string")-            <*> optional (strOption-                  (short 'M'-                  <> long "math"-                  <> metavar "(asciimath|latex|mathematica|maxima)"-                  <> help "Output in AsciiMath, Latex, Mathematica, or Maxima format"))-            <*> flag True False-                  (short 'N'-                  <> long "new-syntax"-                  <> help "[experimental] Use non-S expression syntax")--readFieldOption :: String -> (String, String)-readFieldOption str =-   let (s, rs) = span isDigit str in-   case rs of-     ',':rs' -> let (e, opts) = span isDigit rs' in-                case opts of-                  ['s'] -> ("{" ++ s ++ " " ++ e ++ "}", "")-                  ['c'] -> ("{}", "{" ++ s ++ " " ++ e ++ "}")-                  ['s', 'c'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}")-                  ['c', 's'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}")-     ['s'] -> ("{" ++ s ++ "}", "")-     ['c'] -> ("", "{" ++ s ++ "}")-     ['s', 'c'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}")-     ['c', 's'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}")+main = execParser cmdParser >>= runWithOptions  runWithOptions :: EgisonOpts -> IO () runWithOptions opts

@@ -9,7 +9,8 @@ -}  module Language.Egison-       ( module Language.Egison.Types+       ( module Language.Egison.AST+       , module Language.Egison.Types        , module Language.Egison.Primitives        -- * Eval Egison expressions        , evalTopExprs@@ -33,6 +34,8 @@ import           Data.Version import qualified Paths_egison                as P +import           Language.Egison.AST+import           Language.Egison.CmdOptions import           Language.Egison.Core import           Language.Egison.MathOutput  (changeOutputInLang) import           Language.Egison.Parser      as Parser@@ -147,4 +150,5 @@   , "lib/core/random.egi"   , "lib/core/string.egi"   , "lib/core/maybe.egi"+  , "lib/core/sexpr.egi" -- For compatibility between new and old syntax   ]

@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleInstances #-}++{- |+Module      : Language.Egison.AST+Copyright   : Satoshi Egi+Licence     : MIT++This module defines the syntax of Egison.+-}++module Language.Egison.AST+  ( EgisonTopExpr (..)+  , EgisonExpr (..)+  , EgisonPattern (..)+  , Var (..)+  , Arg (..)+  , Index (..)+  , PMMode (..)+  , InnerExpr (..)+  , BindingExpr (..)+  , MatchClause (..)+  , PatternDef (..)+  , LoopRange (..)+  , PrimitivePatPattern (..)+  , PrimitiveDataPattern (..)+  , EgisonBinOp (..)+  , BinOpAssoc (..)+  , reservedBinops+  , stringToVar+  , stringToVarExpr+  ) where++import           Data.Hashable   (Hashable)+import           Data.List       (intercalate)+import           Data.List.Split (splitOn)+import           Data.Text       (Text)+import qualified Data.Text       as T+import           GHC.Generics    (Generic)++data EgisonTopExpr =+    Define Var EgisonExpr+  | Redefine Var EgisonExpr+  | Test EgisonExpr+  | Execute EgisonExpr+    -- temporary : we will replace load to import and export+  | LoadFile String+  | Load String+ deriving (Show, Eq)++data EgisonExpr =+    CharExpr Char+  | StringExpr Text+  | BoolExpr Bool+  | IntegerExpr Integer+  | FloatExpr Double+  | VarExpr Var+  | FreshVarExpr+  | IndexedExpr Bool EgisonExpr [Index EgisonExpr]  -- True -> delete old index and append new one+  | SubrefsExpr Bool EgisonExpr EgisonExpr+  | SuprefsExpr Bool EgisonExpr EgisonExpr+  | UserrefsExpr Bool EgisonExpr EgisonExpr+  | PowerExpr EgisonExpr EgisonExpr           -- TODO: delete this in v4.0.0+  | InductiveDataExpr String [EgisonExpr]+  | TupleExpr [EgisonExpr]+  | CollectionExpr [InnerExpr]                -- TODO: InnerExpr should be EgisonExpr from v4.0.0+  | ArrayExpr [EgisonExpr]+  | HashExpr [(EgisonExpr, EgisonExpr)]+  | VectorExpr [EgisonExpr]++  | LambdaExpr [Arg] EgisonExpr+  | LambdaArgExpr [Char]+  | MemoizedLambdaExpr [String] EgisonExpr+  | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr+  | CambdaExpr String EgisonExpr+  | ProcedureExpr [String] EgisonExpr+  | MacroExpr [String] EgisonExpr+  | PatternFunctionExpr [String] EgisonPattern++  | IfExpr EgisonExpr EgisonExpr EgisonExpr+  | LetRecExpr [BindingExpr] EgisonExpr+  | LetExpr [BindingExpr] EgisonExpr+  | LetStarExpr [BindingExpr] EgisonExpr+  | WithSymbolsExpr [String] EgisonExpr++  | MatchExpr PMMode EgisonExpr EgisonExpr [MatchClause]+  | MatchAllExpr PMMode EgisonExpr EgisonExpr [MatchClause]+  | MatchLambdaExpr EgisonExpr [MatchClause]+  | MatchAllLambdaExpr EgisonExpr [MatchClause]++  | MatcherExpr [PatternDef]+  | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]++  | QuoteExpr EgisonExpr+  | QuoteSymbolExpr EgisonExpr+  | WedgeApplyExpr EgisonExpr EgisonExpr++  | DoExpr [BindingExpr] EgisonExpr+  | IoExpr EgisonExpr++  | UnaryOpExpr String EgisonExpr+  | BinaryOpExpr EgisonBinOp EgisonExpr EgisonExpr++  | SeqExpr EgisonExpr EgisonExpr+  | ApplyExpr EgisonExpr EgisonExpr+  | CApplyExpr EgisonExpr EgisonExpr+  | PartialExpr Integer EgisonExpr+  | PartialVarExpr Integer++  | GenerateArrayExpr EgisonExpr (EgisonExpr, EgisonExpr)+  | ArrayBoundsExpr EgisonExpr+  | ArrayRefExpr EgisonExpr EgisonExpr++  | GenerateTensorExpr EgisonExpr EgisonExpr+  | TensorExpr EgisonExpr EgisonExpr EgisonExpr EgisonExpr+  | TensorContractExpr EgisonExpr EgisonExpr+  | TensorMapExpr EgisonExpr EgisonExpr+  | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr+  | TransposeExpr EgisonExpr EgisonExpr+  | FlipIndicesExpr EgisonExpr++  | FunctionExpr [EgisonExpr]++  | SomethingExpr+  | UndefinedExpr+ deriving (Eq)++data Var = Var [String] [Index ()]+  deriving (Eq, Generic)++data Arg =+    ScalarArg String+  | InvertedScalarArg String+  | TensorArg String+ deriving (Eq)++data Index a =+    Subscript a+  | Superscript a+  | SupSubscript a+  | MultiSubscript a a+  | MultiSuperscript a a+  | DFscript Integer Integer -- DifferentialForm+  | Userscript a+  | DotSubscript a+  | DotSupscript a+ deriving (Eq, Generic)++data InnerExpr =+    ElementExpr EgisonExpr+  | SubCollectionExpr EgisonExpr+ deriving (Show, Eq)++data PMMode = BFSMode | DFSMode+ deriving (Eq, Show)++type BindingExpr = ([Var], EgisonExpr)+type MatchClause = (EgisonPattern, EgisonExpr)+type PatternDef  = (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])++-- TODO(momohatt): AndPat and OrPat take only 2 arguments in new syntax+data EgisonPattern =+    WildCard+  | PatVar Var+  | ValuePat EgisonExpr+  | PredPat EgisonExpr+  | IndexedPat EgisonPattern [EgisonExpr]+  | LetPat [BindingExpr] EgisonPattern+  | LaterPat EgisonPattern+  | NotPat EgisonPattern+  | AndPat [EgisonPattern]+  | OrPat [EgisonPattern]+  | TuplePat [EgisonPattern]+  | InductivePat String [EgisonPattern]+  | LoopPat Var LoopRange EgisonPattern EgisonPattern+  | ContPat+  | PApplyPat EgisonExpr [EgisonPattern]+  | VarPat String+  | SeqNilPat+  | SeqConsPat EgisonPattern EgisonPattern+  | LaterPatVar+  -- For symbolic computing+  | DApplyPat EgisonPattern [EgisonPattern]+  | DivPat EgisonPattern EgisonPattern+  | PlusPat [EgisonPattern]+  | MultPat [EgisonPattern]+  | PowerPat EgisonPattern EgisonPattern+ deriving Eq++data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern+ deriving Eq++data PrimitivePatPattern =+    PPWildCard+  | PPPatVar+  | PPValuePat String+  | PPInductivePat String [PrimitivePatPattern]+  | PPTuplePat [PrimitivePatPattern]+ deriving (Show, Eq)++data PrimitiveDataPattern =+    PDWildCard+  | PDPatVar String+  | PDInductivePat String [PrimitiveDataPattern]+  | PDTuplePat [PrimitiveDataPattern]+  | PDEmptyPat+  | PDConsPat PrimitiveDataPattern PrimitiveDataPattern+  | PDSnocPat PrimitiveDataPattern PrimitiveDataPattern+  | PDConstantPat EgisonExpr+ deriving (Show, Eq)++data EgisonBinOp+  = EgisonBinOp { repr     :: String  -- syntastic representation+                , func     :: String  -- semantics+                , priority :: Int+                , assoc    :: BinOpAssoc+                , isWedge  :: Bool    -- True if operator is prefixed with '!'+                }+  deriving (Eq, Ord)++instance Show EgisonBinOp where+  show = repr++data BinOpAssoc+  = LeftAssoc+  | RightAssoc+  | NonAssoc+  deriving (Eq, Ord)++instance Show BinOpAssoc where+  show LeftAssoc  = "infixl"+  show RightAssoc = "infixr"+  show NonAssoc   = "infix"++reservedBinops :: [EgisonBinOp]+reservedBinops =+  [ makeBinOp "^"  "**"        8 LeftAssoc+  , makeBinOp "*"  "*"         7 LeftAssoc+  , makeBinOp "/"  "/"         7 LeftAssoc+  , makeBinOp "%"  "remainder" 7 LeftAssoc+  , makeBinOp "+"  "+"         6 LeftAssoc+  , makeBinOp "-"  "-"         6 LeftAssoc+  , makeBinOp "++" "append"    5 RightAssoc+  , makeBinOp "::" "cons"      5 RightAssoc+  , makeBinOp "="  "eq?"       4 LeftAssoc+  , makeBinOp "<=" "lte?"      4 LeftAssoc+  , makeBinOp ">=" "gte?"      4 LeftAssoc+  , makeBinOp "<"  "lt?"       4 LeftAssoc+  , makeBinOp ">"  "gt?"       4 LeftAssoc+  , makeBinOp "&&" "and"       3 RightAssoc+  , makeBinOp "||" "or"        2 RightAssoc+  ]+  where+    makeBinOp r f p a =+      EgisonBinOp { repr = r, func = f, priority = p, assoc = a, isWedge = False }++instance Hashable (Index ())+instance Hashable Var++stringToVar :: String -> Var+stringToVar name = Var (splitOn "." name) []++stringToVarExpr :: String -> EgisonExpr+stringToVarExpr = VarExpr . stringToVar++instance Show EgisonExpr where+  show (CharExpr c) = "c#" ++ [c]+  show (StringExpr str) = "\"" ++ T.unpack str ++ "\""+  show (BoolExpr True) = "#t"+  show (BoolExpr False) = "#f"+  show (IntegerExpr n) = show n+  show (FloatExpr x) = show x+  show (VarExpr name) = show name+  show (PartialVarExpr n) = "%" ++ show n+  show (FunctionExpr args) = "(function [" ++ unwords (map show args) ++ "])"+  show (IndexedExpr True expr idxs) = show expr ++ concatMap show idxs+  show (IndexedExpr False expr idxs) = show expr ++ "..." ++ concatMap show idxs+  show (TupleExpr exprs) = "[" ++ unwords (map show exprs) ++ "]"+  show (CollectionExpr ls) = "{" ++ unwords (map show ls) ++ "}"++  show (UnaryOpExpr op e) = op ++ " " ++ show e+  show (BinaryOpExpr op e1 e2) = "(" ++ show e1 ++ " " ++ show op ++ " " ++ show e2 ++ ")"++  show (QuoteExpr e) = "'" ++ show e+  show (QuoteSymbolExpr e) = "`" ++ show e++  show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")"+  show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")"+  show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")"+  show (VectorExpr xs) = "[| " ++ unwords (map show xs) ++ " |]"+  show (WithSymbolsExpr xs e) = "(withSymbols {" ++ unwords (map show xs) ++ "} " ++ show e ++ ")"+  show _ = "(not supported)"++instance Show Var where+  show (Var xs is) = intercalate "." xs ++ concatMap show is++instance Show Arg where+  show (ScalarArg name)         = "$" ++ name+  show (InvertedScalarArg name) = "*$" ++ name+  show (TensorArg name)         = "%" ++ name++instance Show (Index ()) where+  show (Superscript ())  = "~"+  show (Subscript ())    = "_"+  show (SupSubscript ()) = "~_"+  show (DFscript _ _)    = ""+  show (Userscript _)    = "|"++instance Show (Index String) where+  show (Superscript s)  = "~" ++ s+  show (Subscript s)    = "_" ++ s+  show (SupSubscript s) = "~_" ++ s+  show (DFscript _ _)   = ""+  show (Userscript i)   = "|" ++ show i++instance Show (Index EgisonExpr) where+  show (Superscript i)  = "~" ++ show i+  show (Subscript i)    = "_" ++ show i+  show (SupSubscript i) = "~_" ++ show i+  show (DFscript _ _)   = ""+  show (Userscript i)   = "|" ++ show i++instance Show EgisonPattern where+  show WildCard = "_"+  show (PatVar var) = "$" ++ show var+  show (ValuePat expr) = "," ++ show expr+  show (PredPat expr) = "?" ++ show expr+  show (IndexedPat pat exprs) = show pat ++ concatMap (("_" ++) . show) exprs+  show (LetPat bexprs pat) = "(let {" ++ unwords (map (\(vars, expr) -> "[" ++ showVarsHelper vars ++ " " ++ show expr ++ "]") bexprs) +++                             "} " ++ show pat ++ ")"+    where showVarsHelper [] = ""+          showVarsHelper [v] = "$" ++ show v+          showVarsHelper vs = "[" ++ unwords (map (("$" ++) . show) vs) ++ "]"+  show (LaterPat pat) = "(later " ++ show pat ++ ")"+  show (NotPat pat) = "!" ++ show pat+  show (AndPat pats) = "(&" ++ concatMap ((" " ++) . show) pats ++ ")"+  show (OrPat pats) = "(|" ++ concatMap ((" " ++) . show) pats ++ ")"+  show (TuplePat pats) = "[" ++ unwords (map show pats) ++ "]"+  show (InductivePat name pats) = "<" ++ name ++ concatMap ((" " ++) . show) pats ++ ">"+  show (LoopPat var range pat endPat) = "(loop $" ++ unwords [show var, show range, show pat, show endPat] ++ ")"+  show ContPat = "..."+  show (PApplyPat expr pats) = "(" ++ unwords (show expr : map show pats) ++ ")"+  show (VarPat name) = name+  show SeqNilPat = "{}"+  show (SeqConsPat pat pat') = "{" ++ show pat ++ showSeqPatHelper pat' ++ "}"+    where showSeqPatHelper SeqNilPat = ""+          showSeqPatHelper (SeqConsPat pat pat') = " " ++ show pat ++ showSeqPatHelper pat'+          showSeqPatHelper pat = " " ++ show pat+  show LaterPatVar = "#"++  show (DApplyPat pat pats) = "(" ++ unwords (show pat : map show pats) ++ ")"+  show (DivPat pat pat') = "(/ " ++ show pat ++ " " ++ show pat' ++ ")"+  show (PlusPat pats) = "(+" ++ concatMap ((" " ++) . show) pats+  show (MultPat pats) = "(*" ++ concatMap ((" " ++) . show) pats+  show (PowerPat pat pat') = "(" ++ show pat ++ " ^ " ++ show pat' ++ ")"++instance Show LoopRange where+  show (LoopRange start (ApplyExpr (VarExpr (Var ["from"] [])) (ApplyExpr _ (TupleExpr (x:_)))) endPat) =+    "[" ++ show start ++ " (from " ++ show x ++ ") " ++ show endPat ++ "]"+  show (LoopRange start ends endPat) = "[" ++ show start ++ " " ++ show ends ++ " " ++ show endPat ++ "]"

@@ -0,0 +1,136 @@+{- |+Module      : Language.Egison.CmdOptions+Copyright   : Satoshi Egi+Licence     : MIT++This module provides command line options of Egison interpreter.+-}++module Language.Egison.CmdOptions+  ( EgisonOpts (..)+  , defaultOption+  , cmdParser+  ) where++import           Data.Char           (isDigit)+import           Options.Applicative++data EgisonOpts = EgisonOpts {+    optExecFile         :: Maybe (String, [String]),+    optShowVersion      :: Bool,+    optEvalString       :: Maybe String,+    optExecuteString    :: Maybe String,+    optFieldInfo        :: [(String, String)],+    optLoadLibs         :: [String],+    optLoadFiles        :: [String],+    optSubstituteString :: Maybe String,+    optMapTsvInput      :: Maybe String,+    optFilterTsvInput   :: Maybe String,+    optTsvOutput        :: Bool,+    optNoIO             :: Bool,+    optShowBanner       :: Bool,+    optTestOnly         :: Bool,+    optPrompt           :: String,+    optMathExpr         :: Maybe String,+    optSExpr            :: Bool+    }++defaultOption :: EgisonOpts+defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True++cmdParser :: ParserInfo EgisonOpts+cmdParser = info (helper <*> cmdArgParser)+          $ fullDesc+          <> header "The Egison Programming Language"++cmdArgParser :: Parser EgisonOpts+cmdArgParser = EgisonOpts+            <$> optional ((,) <$> strArgument (metavar "FILE") <*> many (strArgument (metavar "ARGS")))+            <*> switch+                  (short 'v'+                  <> long "version"+                  <> help "Show version number")+            <*> optional (strOption+                  (short 'e'+                  <> long "eval"+                  <> metavar "EXPR"+                  <> help "Evaluate the argument string"))+            <*> optional (strOption+                  (short 'c'+                  <> long "command"+                  <> metavar "EXPR"+                  <> help "Execute the argument string"))+            <*> many (readFieldOption <$> strOption+                  (short 'F'+                  <> long "field"+                  <> metavar "FIELD"+                  <> help "Field information"))+            <*> many (strOption+                  (short 'L'+                  <> long "load-library"+                  <> metavar "FILE"+                  <> help "Load library"))+            <*> many (strOption+                  (short 'l'+                  <> long "load-file"+                  <> metavar "FILE"+                  <> help "Load file"))+            <*> optional (strOption+                  (short 's'+                  <> long "substitute"+                  <> metavar "EXPR"+                  <> help "Operate input in tsv format as infinite stream"))+            <*> optional ((\s -> "(map " ++ s ++ " $)") <$> strOption+                  (short 'm'+                  <> long "map"+                  <> metavar "EXPR"+                  <> help "Operate input in tsv format line by line"))+            <*> optional ((\s -> "(filter " ++ s ++ " $)") <$> strOption+                  (short 'f'+                  <> long "filter"+                  <> metavar "EXPR"+                  <> help "Filter input in tsv format line by line"))+            <*> switch+                  (short 'T'+                  <> long "tsv"+                  <> help "Output in tsv format")+            <*> switch+                  (long "no-io"+                  <> help "Prohibit all io primitives")+            <*> flag True False+                  (long "no-banner"+                  <> help "Do not display banner")+            <*> switch+                  (short 't'+                  <> long "test"+                  <> help "Execute only test expressions")+            <*> strOption+                  (short 'p'+                  <> long "prompt"+                  <> metavar "STRING"+                  <> value "> "+                  <> help "Set prompt string")+            <*> optional (strOption+                  (short 'M'+                  <> long "math"+                  <> metavar "(asciimath|latex|mathematica|maxima)"+                  <> help "Output in AsciiMath, Latex, Mathematica, or Maxima format"))+            <*> flag True False+                  (short 'N'+                  <> long "new-syntax"+                  <> help "[experimental] Use non-S expression syntax")++readFieldOption :: String -> (String, String)+readFieldOption str =+   let (s, rs) = span isDigit str in+   case rs of+     ',':rs' -> let (e, opts) = span isDigit rs' in+                case opts of+                  ['s'] -> ("{" ++ s ++ " " ++ e ++ "}", "")+                  ['c'] -> ("{}", "{" ++ s ++ " " ++ e ++ "}")+                  ['s', 'c'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}")+                  ['c', 's'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}")+     ['s'] -> ("{" ++ s ++ "}", "")+     ['c'] -> ("", "{" ++ s ++ "}")+     ['s', 'c'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}")+     ['c', 's'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}")

@@ -64,8 +64,11 @@ import           Data.Text                   (Text) import qualified Data.Text                   as T +import           Language.Egison.AST+import           Language.Egison.CmdOptions import           Language.Egison.Parser      as Parser import           Language.Egison.ParserNonS  as ParserNonS+import           Language.Egison.Pretty import           Language.Egison.Types  --@@ -82,27 +85,28 @@     LoadFile file ->       if optNoIO opts          then throwError $ Default "No IO support"-         else do exprs' <- if-                   | optSExpr opts    -> Parser.loadFile file-                   | otherwise        -> ParserNonS.loadFile file+         else do exprs' <- if optSExpr opts then Parser.loadFile file+                                            else ParserNonS.loadFile file                  collectDefs opts (exprs' ++ exprs) bindings rest     Load file ->       if optNoIO opts          then throwError $ Default "No IO support"-         else do exprs' <- if-                   | optSExpr opts    -> Parser.loadLibraryFile file-                   | otherwise        -> ParserNonS.loadLibraryFile file+         else do exprs' <- if optSExpr opts then Parser.loadLibraryFile file+                                            else ParserNonS.loadLibraryFile file                  collectDefs opts (exprs' ++ exprs) bindings rest collectDefs _ [] bindings rest = return (bindings, reverse rest)  evalTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> EgisonTopExpr -> EgisonM (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env) evalTopExpr' _ st (Define name expr) = return (Nothing, withStateT (\defines -> (name, expr):defines) st) evalTopExpr' _ st (Redefine name expr) = return (Nothing, mapStateT (>>= \(env, defines) -> (, defines) <$> recursiveRebind env (name, expr)) st)-evalTopExpr' _ st (Test expr) = do+evalTopExpr' opts st (Test expr) = do   pushFuncName "<stdin>"   val <- evalStateT st [] >>= flip evalExprDeep expr   popFuncName-  return (Just (show val), st)+  case (optSExpr opts, optMathExpr opts) of+    (False, Nothing) -> return (Just (show val), st)+    _  -> return (Just (prettyS val), st)+   evalTopExpr' _ st (Execute expr) = do   pushFuncName "<stdin>"   io <- evalStateT st [] >>= flip evalExpr expr@@ -142,12 +146,12 @@   return (case x of             Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) ->               case fn of-                Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) argnames args js, 1)]]) p)+                Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ prettyS name) argnames args js, 1)]]) p)                 Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)             _ -> x)  where   refVar' :: Env -> Var -> EgisonM ObjectRef-  refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ show var))) return+  refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ prettyS var))) return                           (refVar env var)  evalExpr env (PartialVarExpr n) = evalExpr env (stringToVarExpr ("::" ++ show n))@@ -177,8 +181,8 @@  evalExpr env@(Env frame maybe_vwi) (VectorExpr exprs) = do   whnfs <- mapM (\(expr, i) ->-            let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList [toEgison $ toInteger i]) maybe_vwi in-            evalExpr env' expr) $ zip exprs [1..(length exprs + 1)]+    let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList [toEgison $ toInteger i]) maybe_vwi+     in evalExpr env' expr) $ zip exprs [1..(length exprs + 1)]   case whnfs of     (Intermediate (ITensor Tensor{}):_) ->       mapM toTensor (zipWith (curry f) whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor@@ -188,8 +192,8 @@     Intermediate $ ITensor $ Tensor ns (V.fromList $ zipWith (curry g) (V.toList xs) $ map (\ms -> map toEgison $ toInteger i:ms) $ enumTensorIndices ns) indices   f (x, _) = x   g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) =-    let fn' = maybe fn (\(VarWithIndices nameString indexList) -> Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi in-    Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p+    let fn' = maybe fn (\(VarWithIndices nameString indexList) -> Just $ symbolScalarData "" $ prettyS $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi+     in Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p   g (x, _) = x  evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do@@ -243,29 +247,13 @@                   (Just objRef) -> evalRef objRef                   Nothing       -> evalExpr env expr               _ -> evalExpr env expr-  js <- mapM (\case-                 Superscript n -> Superscript <$> evalExprDeep env n-                 Subscript n -> Subscript <$> evalExprDeep env n-                 SupSubscript n -> SupSubscript <$> evalExprDeep env n-                 Userscript n -> Userscript <$> evalExprDeep env n-              ) indices-+  js <- mapM evalIndex indices   ret <- case tensor of       (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])))) -> do-        js2 <- mapM (\case-                        Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar)-                        Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar)-                        SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)-                        Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar)-                    ) indices+        js2 <- mapM evalIndexToScalar indices         return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js2, 1)]]) (Plus [Term 1 []])))       (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js', 1)]]) (Plus [Term 1 []])))) -> do-        js2 <- mapM (\case-                        Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar)-                        Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar)-                        SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)-                        Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar)-                    ) indices+        js2 <- mapM evalIndexToScalar indices         return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (js' ++ js2), 1)]]) (Plus [Term 1 []])))       (Value (TensorData (Tensor ns xs is))) ->         if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)@@ -274,12 +262,7 @@         if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor                 else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor       _ -> do-        js2 <- mapM (\case-                        Superscript n -> Superscript <$> (evalExprDeep env n >>= extractScalar)-                        Subscript n -> Subscript <$> (evalExprDeep env n >>= extractScalar)-                        SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)-                        Userscript n -> Userscript <$> (evalExprDeep env n >>= extractScalar)-                    ) indices+        js2 <- mapM evalIndexToScalar indices         refArray tensor (map (\case                                  Superscript k  -> ScalarData k                                  Subscript k    -> ScalarData k@@ -291,12 +274,25 @@                  case ret of                    Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) ->                      case fn of-                       Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show var ++ concatMap show indices) argnames args js, 1)]]) p)+                       Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ prettyS var ++ concatMap show indices) argnames args js, 1)]]) p)                        Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)                    _ -> ret                _ -> ret   return ret2  where+  evalIndex :: Index EgisonExpr -> EgisonM (Index EgisonValue)+  evalIndex = \case+    Superscript n  -> Superscript  <$> evalExprDeep env n+    Subscript n    -> Subscript    <$> evalExprDeep env n+    SupSubscript n -> SupSubscript <$> evalExprDeep env n+    Userscript n   -> Userscript   <$> evalExprDeep env n+  evalIndexToScalar :: Index EgisonExpr -> EgisonM (Index ScalarData)+  evalIndexToScalar = \case+    Superscript n  -> Superscript  <$> (evalExprDeep env n >>= extractScalar)+    Subscript n    -> Subscript    <$> (evalExprDeep env n >>= extractScalar)+    SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)+    Userscript n   -> Userscript   <$> (evalExprDeep env n >>= extractScalar)+   f :: Index a -> Index ()   f (Superscript _)  = Superscript ()   f (Subscript _)    = Subscript ()@@ -322,12 +318,6 @@       if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor               else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor     _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack- where-  f :: Index a -> Index ()-  f (Superscript _)  = Superscript ()-  f (Subscript _)    = Subscript ()-  f (SupSubscript _) = SupSubscript ()-  f (Userscript _)   = Userscript ()  evalExpr env (SuprefsExpr bool expr jsExpr) = do   js <- map Superscript <$> (evalExpr env jsExpr >>= collectionToList)@@ -348,12 +338,6 @@       if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor               else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor     _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack- where-  f :: Index a -> Index ()-  f (Superscript _)  = Superscript ()-  f (Subscript _)    = Subscript ()-  f (SupSubscript _) = SupSubscript ()-  f (Userscript _)   = Userscript ()  evalExpr env (UserrefsExpr bool expr jsExpr) = do   val <- evalExprDeep env expr@@ -383,16 +367,7 @@  evalExpr env@(Env frame (Just name)) (FunctionExpr args) = do   args' <- mapM (evalExprDeep env) args-  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ show name) (map (symbolScalarData "" . show) args) args' [], 1)]]) (Plus [Term 1 []]))--evalExpr env (SymbolicTensorExpr args sizeExpr name) = do-  args' <- mapM (evalExprDeep env) args-  size' <- evalExpr env sizeExpr-  size'' <- collectionToList size'-  ns <- mapM fromEgison size'' :: EgisonM [Integer]-  let xs = map ((\ms -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" (name ++ concatMap ((\m -> "_" ++ m) . show) ms)) (map (symbolScalarData "" . show) args) args' [], 1)]]) (Plus [Term 1 []])))-               . map toEgison) (enumTensorIndices ns)-  fromTensor (Tensor ns (V.fromList xs) [])+  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ prettyS name) (map (symbolScalarData "" . prettyS) args) args' [], 1)]]) (Plus [Term 1 []]))  evalExpr env (IfExpr test expr expr') = do   test <- evalExpr env test >>= fromWHNF@@ -423,7 +398,7 @@         nth n =           let pattern = TuplePat $ flip map [1..k] $ \i ->                 if i == n then PatVar (stringToVar "#_") else WildCard-          in MatchExpr target matcher [(pattern, stringToVarExpr "#_")]+          in MatchExpr BFSMode target matcher [(pattern, stringToVarExpr "#_")]     return ((var, expr) : map (second nth) (zip names [1..]))    genVar :: State Int Var@@ -498,25 +473,7 @@         Tuple [_, val'] -> return $ Value val'     _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack -evalExpr env (MatchAllExpr target matcher clauses) = do-  target <- evalExpr env target-  matcher <- evalExpr env matcher >>= evalMatcherWHNF-  f matcher target >>= fromMList- where-  fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData-  fromMList MNil = return . Value $ Collection Sq.empty-  fromMList (MCons val m) = do-    head <- IElement <$> newEvaluatedObjectRef val-    tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)-    seqRef <- liftIO . newIORef $ Sq.fromList [head, tail]-    return . Intermediate $ ICollection seqRef-  f matcher target = do-      let tryMatchClause (pattern, expr) results = do-            result <- patternMatch BFSMode env pattern target matcher-            mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results-      mfoldr tryMatchClause (return MNil) (fromList clauses)--evalExpr env (MatchAllDFSExpr target matcher clauses) = do+evalExpr env (MatchAllExpr pmmode target matcher clauses) = do   target <- evalExpr env target   matcher <- evalExpr env matcher >>= evalMatcherWHNF   f matcher target >>= fromMList@@ -530,33 +487,18 @@     return . Intermediate $ ICollection seqRef   f matcher target = do       let tryMatchClause (pattern, expr) results = do-            result <- patternMatch DFSMode env pattern target matcher+            result <- patternMatch pmmode env pattern target matcher             mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results       mfoldr tryMatchClause (return MNil) (fromList clauses) -evalExpr env (MatchExpr target matcher clauses) = do-  target <- evalExpr env target-  matcher <- evalExpr env matcher >>= evalMatcherWHNF-  f matcher target- where-  f matcher target = do-      let tryMatchClause (pattern, expr) cont = do-            result <- patternMatch BFSMode env pattern target matcher-            case result of-              MCons bindings _ -> evalExpr (extendEnv env bindings) expr-              MNil             -> cont-      currentFuncName <- topFuncName-      callstack <- getFuncNameStack-      foldr tryMatchClause (throwError $ MatchFailure currentFuncName callstack) clauses--evalExpr env (MatchDFSExpr target matcher clauses) = do+evalExpr env (MatchExpr pmmode target matcher clauses) = do   target <- evalExpr env target   matcher <- evalExpr env matcher >>= evalMatcherWHNF   f matcher target  where   f matcher target = do       let tryMatchClause (pattern, expr) cont = do-            result <- patternMatch DFSMode env pattern target matcher+            result <- patternMatch pmmode env pattern target matcher             case result of               MCons bindings _ -> evalExpr (extendEnv env bindings) expr               MNil             -> cont@@ -1016,7 +958,7 @@ recursiveRebind :: Env -> (Var, EgisonExpr) -> EgisonM Env recursiveRebind env (name, expr) = do   case refVar env name of-    Nothing -> throwError =<< UnboundVariable (show name) <$> getFuncNameStack+    Nothing -> throwError =<< UnboundVariable (prettyS name) <$> getFuncNameStack     Just ref -> case expr of                   MemoizedLambdaExpr names body -> do                     hashRef <- liftIO $ newIORef HL.empty@@ -1147,7 +1089,7 @@   let env' = extendEnvForNonLinearPatterns env bindings loops in   case pattern of     NotPat _ -> throwError =<< EgisonBug "should not reach here (not pattern)" <$> getFuncNameStack-    VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern+    VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ prettyS pattern      LetPat bindings' pattern' ->       let extractBindings ([name], expr) =@@ -1294,13 +1236,13 @@                 subst k nv ((k', v'):xs) | k == k'   = (k', nv):subst k nv xs                                          | otherwise = (k', v'):subst k nv xs                 subst _ _ [] = []-            IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern)+            IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ prettyS pattern)             TuplePat patterns -> do               targets <- fromTupleWHNF target               when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack               let trees' = zipWith3 MAtom patterns targets (replicate (length patterns) Something) ++ trees               return $ msingleton $ MState env loops seqs bindings trees'-            _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ show pattern+            _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ prettyS pattern         _ ->  throwError =<< EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern) <$> getFuncNameStack  inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher ->

@@ -22,6 +22,7 @@ import           Data.Set              (Set) import qualified Data.Set              as S +import           Language.Egison.AST import           Language.Egison.Types  desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr@@ -53,7 +54,8 @@       genMainClause patterns matcher = do         clauses <- genClauses patterns         return (PPValuePat "val", TupleExpr []-               ,[(PDPatVar "tgt", MatchExpr (TupleExpr [stringToVarExpr "val", stringToVarExpr "tgt"])+               ,[(PDPatVar "tgt", MatchExpr BFSMode+                                            (TupleExpr [stringToVarExpr "val", stringToVarExpr "tgt"])                                             (TupleExpr [matcher, matcher])                                              clauses)])         where@@ -105,11 +107,11 @@  desugar (MatchAllLambdaExpr matcher clauses) = do   name <- fresh-  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (stringToVarExpr name) matcher clauses)+  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr BFSMode (stringToVarExpr name) matcher clauses)  desugar (MatchLambdaExpr matcher clauses) = do   name <- fresh-  desugar $ LambdaExpr [TensorArg name] (MatchExpr (stringToVarExpr name) matcher clauses)+  desugar $ LambdaExpr [TensorArg name] (MatchExpr BFSMode (stringToVarExpr name) matcher clauses)  desugar (ArrayRefExpr expr nums) =   case nums of@@ -265,17 +267,11 @@ desugar (WithSymbolsExpr vars expr) =   WithSymbolsExpr vars <$> desugar expr -desugar (MatchExpr expr0 expr1 clauses) =-  MatchExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses--desugar (MatchDFSExpr expr0 expr1 clauses) =-  MatchDFSExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses--desugar (MatchAllExpr expr0 expr1 clauses) =-  MatchAllExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses+desugar (MatchExpr pmmode expr0 expr1 clauses) =+  MatchExpr pmmode <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses -desugar (MatchAllDFSExpr expr0 expr1 clauses) =-  MatchAllDFSExpr <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses+desugar (MatchAllExpr pmmode expr0 expr1 clauses) =+  MatchAllExpr pmmode <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses  desugar (DoExpr binds expr) =   DoExpr <$> desugarBindings binds <*> desugar expr

@@ -25,27 +25,28 @@        , loadFile        ) where +import           Prelude                 hiding (mapM)+ 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) import           Data.Either import           Data.Functor            (($>)) import           Data.List.Split         (splitOn) import           Data.Ratio import qualified Data.Set                as Set+import qualified Data.Text               as T import           Data.Traversable        (mapM)  import           Text.Parsec import           Text.Parsec.String import qualified Text.Parsec.Token       as P--import qualified Data.Text               as T+import           System.Directory        (doesFileExist, getHomeDirectory)+import           System.IO +import           Language.Egison.AST import           Language.Egison.Desugar import           Language.Egison.Types import           Paths_egison            (getDataFileName)@@ -111,6 +112,12 @@   shebang ('#':'!':cs) = ';':'#':'!':cs   shebang cs           = cs +readUTF8File :: FilePath -> IO String+readUTF8File name = do+  h <- openFile name ReadMode+  hSetEncoding h utf8+  hGetContents h+ -- -- Parser --@@ -226,7 +233,6 @@                         <|> arrayBoundsExpr                         <|> arrayRefExpr                         <|> generateTensorExpr-                        <|> symbolicTensorExpr                         <|> tensorExpr                         <|> tensorContractExpr                         <|> tensorMapExpr@@ -290,23 +296,20 @@     lp = P.lexeme lexer (char '[')     rp = char ']' -symbolicTensorExpr :: Parser EgisonExpr-symbolicTensorExpr = keywordSymbolicTensor >> SymbolicTensorExpr <$> brackets (sepEndBy expr whiteSpace) <*> expr <*> ident- quoteSymbolExpr :: Parser EgisonExpr quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr  matchAllExpr :: Parser EgisonExpr-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)+matchAllExpr = keywordMatchAll >> MatchAllExpr BFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)  matchAllDFSExpr :: Parser EgisonExpr-matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)+matchAllDFSExpr = keywordMatchAllDFS >> MatchAllExpr DFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)  matchExpr :: Parser EgisonExpr-matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses+matchExpr = keywordMatch >> MatchExpr BFSMode <$> expr <*> expr <*> matchClauses  matchDFSExpr :: Parser EgisonExpr-matchDFSExpr = keywordMatchDFS >> MatchDFSExpr <$> expr <*> expr <*> matchClauses+matchDFSExpr = keywordMatchDFS >> MatchExpr DFSMode <$> expr <*> expr <*> matchClauses  matchAllLambdaExpr :: Parser EgisonExpr matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((:[]) <$> matchClause) <|> matchClauses)@@ -796,7 +799,6 @@   , "user-refs"   , "user-refs!"   , "function"-  , "symbolic-tensor"   , "something"   , "undefined"] @@ -877,7 +879,6 @@ keywordUserrefs             = reserved "user-refs" keywordUserrefsNew          = reserved "user-refs!" keywordFunction             = reserved "function"-keywordSymbolicTensor       = reserved "symbolic-tensor"  sign :: Num a => Parser (a -> a) sign = (char '-' >> return negate)

@@ -25,16 +25,16 @@        , loadFile        ) where +import           Prelude                        hiding (mapM)+ 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.Text                      (pack) import           Data.Traversable               (mapM)  import           Control.Monad.Combinators.Expr@@ -43,9 +43,10 @@ import qualified Text.Megaparsec.Char.Lexer     as L import           Text.Megaparsec.Debug          (dbg) import           Text.Megaparsec.Pos            (Pos)--import           Data.Text                      (pack)+import           System.Directory               (doesFileExist, getHomeDirectory)+import           System.IO +import           Language.Egison.AST import           Language.Egison.Desugar import           Language.Egison.Types import           Paths_egison                   (getDataFileName)@@ -99,6 +100,12 @@   shebang ('#':'!':cs) = ';':'#':'!':cs   shebang cs           = cs +readUTF8File :: FilePath -> IO String+readUTF8File name = do+  h <- openFile name ReadMode+  hSetEncoding h utf8+  hGetContents h+ -- -- Parser --@@ -139,7 +146,7 @@ defineOrTestExpr :: Parser EgisonTopExpr defineOrTestExpr = do   e <- expr-  (do symbol "="+  (do symbol ":="       body <- expr       return $ convertToDefine e body)       <|> return (Test e)@@ -176,6 +183,7 @@    <|> letExpr    <|> withSymbolsExpr    <|> doExpr+   <|> ioExpr    <|> matcherExpr    <|> algebraicDataMatcherExpr    <|> memoizedLambdaExpr@@ -212,10 +220,10 @@           , [ InfixL (binary "+" )             , InfixL (binary "-" ) ]           -- 5-          , [ InfixR (binary ":" )+          , [ InfixR (binary "::" )             , InfixR (binary "++") ]           -- 4-          , [ InfixL (binary "==")+          , [ InfixL (binary "=")             , InfixL (binary "<=")             , InfixL (binary "<" )             , InfixL (binary ">=")@@ -230,10 +238,10 @@ ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr  patternMatchExpr :: Parser EgisonExpr-patternMatchExpr = makeMatchExpr keywordMatch       MatchExpr-               <|> makeMatchExpr keywordMatchDFS    MatchDFSExpr-               <|> makeMatchExpr keywordMatchAll    MatchAllExpr-               <|> makeMatchExpr keywordMatchAllDFS MatchAllDFSExpr+patternMatchExpr = makeMatchExpr keywordMatch       (MatchExpr BFSMode)+               <|> makeMatchExpr keywordMatchDFS    (MatchExpr DFSMode)+               <|> makeMatchExpr keywordMatchAll    (MatchAllExpr BFSMode)+               <|> makeMatchExpr keywordMatchAllDFS (MatchAllExpr DFSMode)                <?> "pattern match expression"   where     makeMatchExpr keyword ctor = ctor <$> (keyword >> expr)@@ -285,7 +293,7 @@               <|> do var <- varLiteral                      args <- many arg                      return ([var], args)-  body <- symbol "=" >> expr+  body <- symbol ":=" >> expr   return $ case args of              [] -> (vars, body)              _  -> (vars, LambdaExpr args body)@@ -303,6 +311,9 @@     statement :: Parser BindingExpr     statement = (keywordLet >> binding) <|> ([],) <$> expr +ioExpr :: Parser EgisonExpr+ioExpr = IoExpr <$> (keywordIo >> expr)+ matcherExpr :: Parser EgisonExpr matcherExpr = do   keywordMatcher@@ -410,7 +421,7 @@ hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)   where     hashBraces = between (symbol "{|") (symbol "|}")-    hashElem = brackets $ (,) <$> expr <*> (comma >> expr)+    hashElem = parens $ (,) <$> expr <*> (comma >> expr)  index :: Parser (Index EgisonExpr) index = SupSubscript <$> (string "~_" >> atomExpr')@@ -494,13 +505,9 @@   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+loopPattern =+  LoopPat <$> (keywordLoop >> patVarLiteral) <*> loopRange+          <*> atomPattern <*> atomPattern   where     loopRange :: Parser LoopRange     loopRange =@@ -525,12 +532,12 @@     table =       [ [ Prefix (NotPat <$ symbol "!") ]       -- 5-      , [ InfixR (inductive2 "cons" ":" )+      , [ InfixR (inductive2 "cons" "::" )         , InfixR (inductive2 "join" "++") ]       -- 3-      , [ InfixR (binary AndPat "&&") ]+      , [ InfixR (binary AndPat "&") ]       -- 2-      , [ InfixR (binary OrPat  "||") ]+      , [ InfixR (binary OrPat  "|") ]       ]     inductive2 name sym = (\x y -> InductivePat name [x, y]) <$ patOperator sym     binary name sym     = (\x y -> name [x, y]) <$ patOperator sym@@ -574,7 +581,7 @@   where     table :: [[Operator Parser PrimitivePatPattern]]     table =-      [ [ InfixR (inductive2 "cons" ":" )+      [ [ InfixR (inductive2 "cons" "::" )         , InfixR (inductive2 "join" "++") ]       ]     inductive2 name sym = (\x y -> PPInductivePat name [x, y]) <$ operator sym@@ -594,7 +601,7 @@   where     table :: [[Operator Parser PrimitiveDataPattern]]     table =-      [ [ InfixR (PDConsPat <$ symbol ":") ]+      [ [ InfixR (PDConsPat <$ symbol "::") ]       ]     pdAtom :: Parser PrimitiveDataPattern     pdAtom = PDWildCard    <$ symbol "_"@@ -674,7 +681,7 @@  -- Characters that consist identifiers identChar :: Parser Char-identChar = alphaNumChar <|> oneOf ['.', '?', '\'']+identChar = alphaNumChar <|> oneOf ['.', '?', '\'', '/']  parens    = between (symbol "(") (symbol ")") braces    = between (symbol "{") (symbol "}")

@@ -10,10 +10,18 @@  module Language.Egison.Pretty     ( prettyTopExprs+    , PrettyS(..)+    , showTSV     ) where +import qualified Data.Array                as Array+import           Data.Foldable             (toList)+import qualified Data.HashMap.Strict       as HashMap+import           Data.List                 (intercalate) import           Data.Text.Prettyprint.Doc+import qualified Data.Vector               as V +import           Language.Egison.AST import           Language.Egison.Types  --@@ -25,9 +33,11 @@  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 x <+> hsep (map pretty args) <+> pretty ":=" <> nest 2 (softline <> pretty body)+  pretty (Define x expr) = pretty x <+> pretty ":=" <> nest 2 (softline <> pretty expr)   pretty (Test expr) = pretty expr+  pretty (LoadFile file) = pretty "loadFile" <+> pretty (show file)+  pretty (Load lib) = pretty "load" <+> pretty (show lib)  instance Pretty EgisonExpr where   pretty (CharExpr x)    = squote <> pretty x <> squote@@ -42,23 +52,55 @@   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 (HashExpr xs)   = listoid "{|" "|}" (map (\(x, y) -> tupled [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 (IfExpr x y z) =+    pretty "if" <+> pretty x+               <> nest 2 (softline <> pretty "then" <+> pretty y <>+                          softline <> pretty "else" <+> pretty z)+  pretty (LetRecExpr bindings body) =+    hang 1 (pretty "let" <+> align (vsep (map pretty bindings)) <> hardline <> pretty "in" <+> pretty body)+  pretty (LetExpr _ _) = error "unreachable"+  pretty (LetStarExpr _ _) = error "unreachable"++  pretty (MatchExpr BFSMode tgt matcher clauses) =+    pretty "match"       <+> pretty tgt <+> prettyMatch matcher clauses+  pretty (MatchExpr DFSMode tgt matcher clauses) =+    pretty "matchDFS"    <+> pretty tgt <+> prettyMatch matcher clauses+  pretty (MatchAllExpr BFSMode tgt matcher clauses) =+    pretty "matchAll"    <+> pretty tgt <+> prettyMatch matcher clauses+  pretty (MatchAllExpr DFSMode tgt matcher clauses) =+    pretty "matchAllDFS" <+> pretty tgt <+> prettyMatch matcher clauses+  pretty (MatchLambdaExpr matcher clauses) =+    pretty "\\match"     <+> prettyMatch matcher clauses+  pretty (MatchAllLambdaExpr matcher clauses) =+    pretty "\\matchAll"  <+> prettyMatch matcher clauses+   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+  -- (x1 op' x2) op y+  pretty (BinaryOpExpr op x@(BinaryOpExpr op' _ _) y) =+    if priority op > priority op' || priority op == priority op' && assoc op == RightAssoc+       then parens (pretty x) <+> pretty (repr op) <+> pretty' y+       else pretty x <+> pretty (repr op) <+> pretty' y+  -- x op (y1 op' y2)+  pretty (BinaryOpExpr op x y@(BinaryOpExpr op' _ _)) =+    if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc+       then pretty x <+> pretty (repr op) <+> parens (pretty y)+       else 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)) +  pretty SomethingExpr = pretty "something"+  pretty UndefinedExpr = pretty "undefined"+ instance Pretty Arg where   pretty (ScalarArg x)         = pretty x-  pretty (InvertedScalarArg x) = pretty "*$" <> pretty x+  pretty (InvertedScalarArg x) = pretty "*" <> pretty x   pretty (TensorArg x)         = pretty '%' <> pretty x  instance Pretty Var where@@ -69,12 +111,223 @@   pretty (ElementExpr x) = pretty x   pretty (SubCollectionExpr _) = error "Not supported" +instance {-# OVERLAPPING #-} Pretty BindingExpr where+  pretty ([var], expr) = pretty var <+> pretty ":=" <+> pretty expr+  pretty (vars, expr) = tupled (map pretty vars) <+> pretty ":=" <+> pretty expr++instance {-# OVERLAPPING #-} Pretty MatchClause where+  pretty (pat, expr) = pipe <+> pretty pat <+> pretty "->" <> softline <> pretty expr+ instance Pretty EgisonPattern where-  pretty x = undefined+  pretty WildCard     = pretty "_"+  pretty (PatVar x)   = pretty "$" <> pretty x+  pretty (ValuePat v) = pretty "#" <> parens (pretty v) -- TODO: remove parens+  pretty (PredPat v)  = pretty "?" <> parens (pretty v)+  pretty _            = pretty "hoge"  pretty' :: EgisonExpr -> Doc ann pretty' x@(UnaryOpExpr _ _) = parens $ pretty x pretty' x                   = pretty x +prettyMatch :: EgisonExpr -> [MatchClause] -> Doc ann+prettyMatch matcher clauses =+  pretty "as" <+> pretty matcher <+> pretty "with" <> hardline <>+    align (vsep (map pretty clauses))+ listoid :: String -> String -> [Doc ann] -> Doc ann listoid lp rp elems = encloseSep (pretty lp) (pretty rp) (comma <> space) elems++--+-- Pretty printer for S-expression+--++class PrettyS a where+  prettyS :: a -> String++instance PrettyS EgisonExpr where+  prettyS (CharExpr c) = "c#" ++ [c]+  prettyS (StringExpr str) = show str+  prettyS (BoolExpr True) = "#t"+  prettyS (BoolExpr False) = "#f"+  prettyS (IntegerExpr n) = show n+  prettyS (FloatExpr x) = show x+  prettyS (VarExpr name) = prettyS name+  prettyS (PartialVarExpr n) = "%" ++ show n+  prettyS (FunctionExpr args) = "(function [" ++ unwords (map prettyS args) ++ "])"+  prettyS (IndexedExpr True expr idxs) = prettyS expr ++ concatMap prettyS idxs+  prettyS (IndexedExpr False expr idxs) = prettyS expr ++ "..." ++ concatMap prettyS idxs+  prettyS (TupleExpr exprs) = "[" ++ unwords (map prettyS exprs) ++ "]"+  prettyS (CollectionExpr ls) = "{" ++ unwords (map prettyS ls) ++ "}"++  prettyS (UnaryOpExpr op e) = op ++ " " ++ prettyS e+  prettyS (BinaryOpExpr op e1 e2) = "(" ++ prettyS e1 ++ " " ++ prettyS op ++ " " ++ prettyS e2 ++ ")"++  prettyS (QuoteExpr e) = "'" ++ prettyS e+  prettyS (QuoteSymbolExpr e) = "`" ++ prettyS e++  prettyS (ApplyExpr fn (TupleExpr [])) = "(" ++ prettyS fn ++ ")"+  prettyS (ApplyExpr fn (TupleExpr args)) = "(" ++ prettyS fn ++ " " ++ unwords (map prettyS args) ++ ")"+  prettyS (ApplyExpr fn arg) = "(" ++ prettyS fn ++ " " ++ prettyS arg ++ ")"+  prettyS (VectorExpr xs) = "[| " ++ unwords (map prettyS xs) ++ " |]"+  prettyS (WithSymbolsExpr xs e) = "(withSymbols {" ++ unwords xs ++ "} " ++ prettyS e ++ ")"+  prettyS _ = "(not supported)"++instance PrettyS EgisonValue where+  prettyS (Char c) = "c#" ++ [c]+  prettyS (String str) = show str+  prettyS (Bool True) = "#t"+  prettyS (Bool False) = "#f"+  prettyS (ScalarData mExpr) = prettyS mExpr+  prettyS (TensorData (Tensor [_] xs js)) = "[| " ++ unwords (map prettyS (V.toList xs)) ++ " |]" ++ concatMap prettyS js+  prettyS (TensorData (Tensor [0, 0] _ js)) = "[| [|  |] |]" ++ concatMap prettyS js+  prettyS (TensorData (Tensor [i, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concatMap prettyS js+   where+    f j [] = ""+    f j xs = "[| " ++ unwords (map prettyS (take j xs)) ++ " |] " ++ f j (drop j xs)+  prettyS (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map prettyS (V.toList xs)) ++ "} )" ++ concatMap prettyS js+  prettyS (Float x) = show x+  prettyS (InductiveData name vals) = "<" ++ name ++ concatMap ((' ':) . prettyS) vals ++ ">"+  prettyS (Tuple vals)      = "[" ++ unwords (map prettyS vals) ++ "]"+  prettyS (Collection vals) = "{" ++ unwords (map prettyS (toList vals)) ++ "}"+  prettyS (Array vals)      = "(|" ++ unwords (map prettyS $ Array.elems vals) ++ "|)"+  prettyS (IntHash hash)    = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ prettyS val ++ "]") $ HashMap.toList hash) ++ "|}"+  prettyS (CharHash hash)   = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ prettyS val ++ "]") $ HashMap.toList hash) ++ "|}"+  prettyS (StrHash hash)    = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ prettyS val ++ "]") $ HashMap.toList hash) ++ "|}"+  prettyS UserMatcher{} = "#<user-matcher>"+  prettyS (Func Nothing _ args _) = "(lambda [" ++ unwords (map ('$':) args) ++ "] ...)"+  prettyS (Func (Just name) _ _ _) = prettyS name+  prettyS (PartialFunc _ n expr) = show n ++ "#" ++ prettyS expr+  prettyS (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"+  prettyS (CFunc (Just name) _ _ _) = prettyS name+  prettyS (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)"+  prettyS (MemoizedFunc (Just name) _ _ _ names _) = prettyS name+  prettyS (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)"+  prettyS (Proc (Just name) _ _ _) = name+  prettyS (Macro names _) = "(macro [" ++ unwords names ++ "] ...)"+  prettyS PatternFunc{} = "#<pattern-function>"+  prettyS (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"+  prettyS (IOFunc _) = "#<io-function>"+  prettyS (QuotedFunc _) = "#<quoted-function>"+  prettyS (Port _) = "#<port>"+  prettyS Something = "something"+  prettyS Undefined = "undefined"+  prettyS World = "#<world>"+  prettyS EOF = "#<eof>"++instance PrettyS Var where+  prettyS = show++instance PrettyS VarWithIndices where+  prettyS = show++instance PrettyS EgisonBinOp where+  prettyS = show++instance PrettyS InnerExpr where+  prettyS (ElementExpr e) = prettyS e+  prettyS (SubCollectionExpr e) = '@' : prettyS e++instance PrettyS Arg where+  prettyS (ScalarArg name)         = "$" ++ name+  prettyS (InvertedScalarArg name) = "*$" ++ name+  prettyS (TensorArg name)         = "%" ++ name++instance PrettyS ScalarData where+  prettyS (Div p1 (Plus [Term 1 []])) = prettyS p1+  prettyS (Div p1 p2)                 = "(/ " ++ prettyS p1 ++ " " ++ prettyS p2 ++ ")"++instance PrettyS PolyExpr where+  prettyS (Plus [])  = "0"+  prettyS (Plus [t]) = prettyS t+  prettyS (Plus ts)  = "(+ " ++ unwords (map prettyS ts)  ++ ")"++instance PrettyS TermExpr where+  prettyS (Term a []) = show a+  prettyS (Term 1 [x]) = showPoweredSymbol x+  prettyS (Term 1 xs) = "(* " ++ unwords (map showPoweredSymbol xs) ++ ")"+  prettyS (Term a xs) = "(* " ++ show a ++ " " ++ unwords (map showPoweredSymbol xs) ++ ")"++showPoweredSymbol :: (SymbolExpr, Integer) -> String+showPoweredSymbol (x, 1) = prettyS x+showPoweredSymbol (x, n) = prettyS x ++ "^" ++ show n++instance PrettyS SymbolExpr where+  prettyS (Symbol _ (':':':':':':_) []) = "#"+  prettyS (Symbol _ s []) = s+  prettyS (Symbol _ s js) = s ++ concatMap prettyS js+  prettyS (Apply fn mExprs) = "(" ++ prettyS fn ++ " " ++ unwords (map prettyS mExprs) ++ ")"+  prettyS (Quote mExprs) = "'" ++ prettyS mExprs+  prettyS (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map prettyS argnames) ++ "])" ++ concatMap prettyS js+  prettyS (FunctionData (Just name) argnames args js) = prettyS name ++ concatMap prettyS js++showTSV :: EgisonValue -> String+showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (prettyS val) (map prettyS vals)+showTSV (Collection vals) = intercalate "\t" (map prettyS (toList vals))+showTSV val = prettyS val++instance PrettyS (Index EgisonExpr) where+  prettyS (Superscript i)  = "~" ++ prettyS i+  prettyS (Subscript i)    = "_" ++ prettyS i+  prettyS (SupSubscript i) = "~_" ++ prettyS i+  prettyS (DFscript _ _)   = ""+  prettyS (Userscript i)   = "|" ++ prettyS i++instance PrettyS (Index ScalarData) where+  prettyS (Superscript i)  = "~" ++ prettyS i+  prettyS (Subscript i)    = "_" ++ prettyS i+  prettyS (SupSubscript i) = "~_" ++ prettyS i+  prettyS (DFscript _ _)   = ""+  prettyS (Userscript i)   = "|" ++ prettyS i++instance PrettyS (Index EgisonValue) where+  prettyS (Superscript i) = case i of+    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "~[" ++ prettyS i ++ "]"+    _ -> "~" ++ prettyS i+  prettyS (Subscript i) = case i of+    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]"+    _ -> "_" ++ prettyS i+  prettyS (SupSubscript i) = "~_" ++ prettyS i+  prettyS (DFscript i j) = "_d" ++ show i ++ show j+  prettyS (Userscript i) = case i of+    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]"+    _ -> "|" ++ prettyS i++instance PrettyS EgisonPattern where+  prettyS WildCard = "_"+  prettyS (PatVar var) = "$" ++ prettyS var+  prettyS (ValuePat expr) = "," ++ prettyS expr+  prettyS (PredPat expr) = "?" ++ prettyS expr+  prettyS (IndexedPat pat exprs) = prettyS pat ++ concatMap (("_" ++) . prettyS) exprs+  prettyS (LetPat bexprs pat) =+    "(let {" ++ unwords (map (\(vars, expr) -> "[" ++ varsHelper vars ++ " " ++ prettyS expr ++ "]") bexprs) +++      "} " ++ prettyS pat ++ ")"+    where varsHelper [] = ""+          varsHelper [v] = "$" ++ prettyS v+          varsHelper vs = "[" ++ unwords (map (("$" ++) . prettyS) vs) ++ "]"+  prettyS (LaterPat pat) = "(later " ++ prettyS pat ++ ")"+  prettyS (NotPat pat) = "!" ++ prettyS pat+  prettyS (AndPat pats) = "(&" ++ concatMap ((" " ++) . prettyS) pats ++ ")"+  prettyS (OrPat pats) = "(|" ++ concatMap ((" " ++) . prettyS) pats ++ ")"+  prettyS (TuplePat pats) = "[" ++ unwords (map prettyS pats) ++ "]"+  prettyS (InductivePat name pats) = "<" ++ name ++ concatMap ((" " ++) . prettyS) pats ++ ">"+  prettyS (LoopPat var range pat endPat) = "(loop $" ++ unwords [prettyS var, prettyS range, prettyS pat, prettyS endPat] ++ ")"+  prettyS ContPat = "..."+  prettyS (PApplyPat expr pats) = "(" ++ unwords (prettyS expr : map prettyS pats) ++ ")"+  prettyS (VarPat name) = name+  prettyS SeqNilPat = "{}"+  prettyS (SeqConsPat pat pat') = "{" ++ prettyS pat ++ seqPatHelper pat' ++ "}"+    where seqPatHelper SeqNilPat = ""+          seqPatHelper (SeqConsPat pat pat') = " " ++ prettyS pat ++ seqPatHelper pat'+          seqPatHelper pat = " " ++ prettyS pat+  prettyS LaterPatVar = "#"++  prettyS (DApplyPat pat pats) = "(" ++ unwords (prettyS pat : map prettyS pats) ++ ")"+  prettyS (DivPat pat pat') = "(/ " ++ prettyS pat ++ " " ++ prettyS pat' ++ ")"+  prettyS (PlusPat pats) = "(+" ++ concatMap ((" " ++) . prettyS) pats+  prettyS (MultPat pats) = "(*" ++ concatMap ((" " ++) . prettyS) pats+  prettyS (PowerPat pat pat') = "(" ++ prettyS pat ++ " ^ " ++ prettyS pat' ++ ")"++instance PrettyS LoopRange where+  prettyS (LoopRange start (ApplyExpr (VarExpr (Var ["from"] [])) (ApplyExpr _ (TupleExpr (x:_)))) endPat) =+    "[" ++ show start ++ " (from " ++ show x ++ ") " ++ prettyS endPat ++ "]"+  prettyS (LoopRange start ends endPat) = "[" ++ show start ++ " " ++ show ends ++ " " ++ prettyS endPat ++ "]"

@@ -42,8 +42,10 @@ import qualified Database.SQLite3 as SQLite  --}  -- for 'egison-sqlite' +import           Language.Egison.AST import           Language.Egison.Core import           Language.Egison.Parser+import           Language.Egison.Pretty import           Language.Egison.Types  primitiveEnv :: IO Env@@ -353,6 +355,27 @@               , ("assert", assert)              , ("assertEqual", assertEqual)++             -- for old library compatibility+             , ("from-math-expr", fromScalarData)+             , ("to-math-expr", toScalarData)+             , ("to-math-expr'", toScalarData)+             , ("tensor-size", tensorSize')+             , ("tensor-to-list", tensorToList')+             , ("df-order", dfOrder')+             , ("uncons-string", unconsString)+             , ("length-string", lengthString)+             , ("append-string", appendString)+             , ("split-string", splitString)+             , ("regex-cg", regexStringCaptureGroup)+             , ("add-prime", addPrime)+             , ("add-subscript", addSubscript)+             , ("add-superscript", addSuperscript)+             , ("read-process", readProcess')+             , ("read-tsv", readTSV)+             , ("show-tsv", showTSV')+             , ("tensor-with-index?", isTensorWithIndex')+             , ("assert-equal", assertEqual)              ]  rationalUnaryOp :: (Rational -> Rational) -> PrimitiveFunc@@ -726,8 +749,7 @@ --  ioPrimitives :: [(String, PrimitiveFunc)]-ioPrimitives = [-                 ("return", return')+ioPrimitives = [ ("return", return')                , ("open-input-file", makePort ReadMode)                , ("open-output-file", makePort WriteMode)                , ("close-input-port", closePort)@@ -755,8 +777,7 @@  -- For Non-S syntax ioPrimitives' :: [(String, PrimitiveFunc)]-ioPrimitives' = [-                 ("return", return')+ioPrimitives' = [ ("return", return')                , ("openInputFile", makePort ReadMode)                , ("openOutputFile", makePort WriteMode)                , ("closeInputPort", closePort)@@ -779,7 +800,22 @@                 , ("rand", randRange)                , ("f.rand", randRangeDouble)---               , ("sqlite", sqlite)++               -- for S-expression library compatibility+               , ("open-input-file", makePort ReadMode)+               , ("open-output-file", makePort WriteMode)+               , ("close-input-port", closePort)+               , ("close-output-port", closePort)+               , ("read-char", readChar)+               , ("read-line", readLine)+               , ("write-char", writeChar)+               , ("read-char-from-port", readCharFromPort)+               , ("read-line-from-port", readLineFromPort)+               , ("write-char-to-port", writeCharToPort)+               , ("write-to-port", writeStringToPort)+               , ("eof-port?", isEOFPort)+               , ("flush-port", flushPort)+               , ("read-file", readFile')                ]  makeIO :: EgisonM EgisonValue -> EgisonValue

@@ -1,12 +1,10 @@ {-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE UndecidableInstances       #-}+ {- | Module      : Language.Egison.Types Copyright   : Satoshi Egi@@ -17,32 +15,15 @@  module Language.Egison.Types     (-    -- * Egison expressions-      EgisonTopExpr (..)-    , EgisonExpr (..)-    , EgisonPattern (..)-    , Arg (..)-    , Index (..)-    , InnerExpr (..)-    , BindingExpr (..)-    , MatchClause (..)-    , PatternDef (..)-    , LoopRange (..)-    , PrimitivePatPattern (..)-    , PrimitiveDataPattern (..)+    -- * Egison values+      EgisonValue (..)     , Matcher (..)     , PrimitiveFunc (..)-    , EgisonData (..)-    , showTSV-    , EgisonBinOp(..)-    , BinOpAssoc(..)-    , reservedBinops-    -- * Egison values-    , EgisonValue (..)     , ScalarData (..)     , PolyExpr (..)     , TermExpr (..)     , SymbolExpr (..)+    , EgisonData (..)     , Tensor (..)     , HasTensor (..)     -- * Tensor@@ -95,16 +76,14 @@     , EgisonWHNF (..)     -- * Environment     , Env (..)-    , Var (..)     , VarWithIndices (..)     , Binding (..)-    , Id     , nullEnv     , extendEnv     , refVar+    , varToVarWithIndices     -- * Pattern matching     , Match-    , PMMode (..)     , MatchingTree (..)     , MatchingState (..)     , PatternBinding (..)@@ -155,12 +134,6 @@     , isCollection'     , isArray'     , isHash'-    , readUTF8File-    , stringToVar-    , stringToVarExpr-    , varToVarWithIndices-    , EgisonOpts (..)-    , defaultOption     ) where  import           Prelude                   hiding (foldr, mappend, mconcat)@@ -178,7 +151,6 @@  import qualified Data.Array                as Array import           Data.Foldable             (foldr, toList)-import           Data.Hashable             (Hashable) import           Data.HashMap.Strict       (HashMap) import qualified Data.HashMap.Strict       as HashMap import           Data.IORef@@ -190,234 +162,14 @@ import           Data.List                 (any, delete, elem, elemIndex, find,                                             findIndex, intercalate, partition,                                             splitAt, (\\))-import           Data.List.Split           (splitOn) import           Data.Text                 (Text)-import qualified Data.Text                 as T  import           Data.Ratio import           System.IO  import           System.IO.Unsafe          (unsafePerformIO) -import           GHC.Generics              (Generic)------- Expressions-----data EgisonTopExpr =-    Define Var EgisonExpr-  | Redefine Var EgisonExpr-  | Test EgisonExpr-  | Execute EgisonExpr-    -- temporary : we will replace load to import and export-  | LoadFile String-  | Load String- deriving (Show, Eq)--data EgisonExpr =-    CharExpr Char-  | StringExpr Text-  | BoolExpr Bool-  | IntegerExpr Integer-  | FloatExpr Double-  | VarExpr Var-  | FreshVarExpr-  | IndexedExpr Bool EgisonExpr [Index EgisonExpr]  -- True -> delete old index and append new one-  | SubrefsExpr Bool EgisonExpr EgisonExpr-  | SuprefsExpr Bool EgisonExpr EgisonExpr-  | UserrefsExpr Bool EgisonExpr EgisonExpr-  | PowerExpr EgisonExpr EgisonExpr           -- TODO: delete this in v4.0.0-  | InductiveDataExpr String [EgisonExpr]-  | TupleExpr [EgisonExpr]-  | CollectionExpr [InnerExpr]                -- TODO: InnerExpr should be EgisonExpr from v4.0.0-  | ArrayExpr [EgisonExpr]-  | HashExpr [(EgisonExpr, EgisonExpr)]-  | VectorExpr [EgisonExpr]--  | LambdaExpr [Arg] EgisonExpr-  | LambdaArgExpr [Char]-  | MemoizedLambdaExpr [String] EgisonExpr-  | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr-  | CambdaExpr String EgisonExpr-  | ProcedureExpr [String] EgisonExpr-  | MacroExpr [String] EgisonExpr-  | PatternFunctionExpr [String] EgisonPattern--  | IfExpr EgisonExpr EgisonExpr EgisonExpr-  | LetRecExpr [BindingExpr] EgisonExpr-  | LetExpr [BindingExpr] EgisonExpr-  | LetStarExpr [BindingExpr] EgisonExpr-  | WithSymbolsExpr [String] EgisonExpr--  | MatchExpr EgisonExpr EgisonExpr [MatchClause]-  | MatchDFSExpr EgisonExpr EgisonExpr [MatchClause]-  | MatchAllExpr EgisonExpr EgisonExpr [MatchClause]-  | MatchAllDFSExpr EgisonExpr EgisonExpr [MatchClause]-  | MatchLambdaExpr EgisonExpr [MatchClause]-  | MatchAllLambdaExpr EgisonExpr [MatchClause]--  | MatcherExpr [PatternDef]-  | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]--  | QuoteExpr EgisonExpr-  | QuoteSymbolExpr EgisonExpr-  | WedgeApplyExpr EgisonExpr EgisonExpr--  | DoExpr [BindingExpr] EgisonExpr-  | IoExpr EgisonExpr--  | UnaryOpExpr String EgisonExpr-  | BinaryOpExpr EgisonBinOp EgisonExpr EgisonExpr--  | SeqExpr EgisonExpr EgisonExpr-  | ApplyExpr EgisonExpr EgisonExpr-  | CApplyExpr EgisonExpr EgisonExpr-  | PartialExpr Integer EgisonExpr-  | PartialVarExpr Integer--  | GenerateArrayExpr EgisonExpr (EgisonExpr, EgisonExpr)-  | ArrayBoundsExpr EgisonExpr-  | ArrayRefExpr EgisonExpr EgisonExpr--  | GenerateTensorExpr EgisonExpr EgisonExpr-  | TensorExpr EgisonExpr EgisonExpr EgisonExpr EgisonExpr-  | TensorContractExpr EgisonExpr EgisonExpr-  | TensorMapExpr EgisonExpr EgisonExpr-  | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr-  | TransposeExpr EgisonExpr EgisonExpr-  | FlipIndicesExpr EgisonExpr--  | FunctionExpr [EgisonExpr]-  | SymbolicTensorExpr [EgisonExpr] EgisonExpr String--  | SomethingExpr-  | UndefinedExpr- deriving (Eq)--data Arg =-    ScalarArg String-  | InvertedScalarArg String-  | TensorArg String- deriving (Eq)--data Index a =-    Subscript a-  | Superscript a-  | SupSubscript a-  | MultiSubscript a a-  | MultiSuperscript a a-  | DFscript Integer Integer -- DifferentialForm-  | Userscript a-  | DotSubscript a-  | DotSupscript a- deriving (Eq, Generic)--data InnerExpr =-    ElementExpr EgisonExpr-  | SubCollectionExpr EgisonExpr- deriving (Show, Eq)--type BindingExpr = ([Var], EgisonExpr)-type MatchClause = (EgisonPattern, EgisonExpr)-type PatternDef  = (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])---- TODO(momohatt): AndPat and OrPat take only 2 arguments in new syntax-data EgisonPattern =-    WildCard-  | PatVar Var-  | ValuePat EgisonExpr-  | PredPat EgisonExpr-  | IndexedPat EgisonPattern [EgisonExpr]-  | LetPat [BindingExpr] EgisonPattern-  | LaterPat EgisonPattern-  | NotPat EgisonPattern-  | AndPat [EgisonPattern]-  | OrPat [EgisonPattern]-  | TuplePat [EgisonPattern]-  | InductivePat String [EgisonPattern]-  | LoopPat Var LoopRange EgisonPattern EgisonPattern-  | ContPat-  | PApplyPat EgisonExpr [EgisonPattern]-  | VarPat String-  | SeqNilPat-  | SeqConsPat EgisonPattern EgisonPattern-  | LaterPatVar-  -- For symbolic computing-  | DApplyPat EgisonPattern [EgisonPattern]-  | DivPat EgisonPattern EgisonPattern-  | PlusPat [EgisonPattern]-  | MultPat [EgisonPattern]-  | PowerPat EgisonPattern EgisonPattern- deriving Eq--data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern- deriving Eq--data PrimitivePatPattern =-    PPWildCard-  | PPPatVar-  | PPValuePat String-  | PPInductivePat String [PrimitivePatPattern]-  | PPTuplePat [PrimitivePatPattern]- deriving (Show, Eq)--data PrimitiveDataPattern =-    PDWildCard-  | PDPatVar String-  | PDInductivePat String [PrimitiveDataPattern]-  | PDTuplePat [PrimitiveDataPattern]-  | PDEmptyPat-  | PDConsPat PrimitiveDataPattern PrimitiveDataPattern-  | PDSnocPat PrimitiveDataPattern PrimitiveDataPattern-  | PDConstantPat EgisonExpr- deriving (Show, Eq)--data EgisonBinOp-  = EgisonBinOp { repr     :: String  -- syntastic representation-                , func     :: String  -- semantics-                , priority :: Int-                , assoc    :: BinOpAssoc-                , isWedge  :: Bool    -- True if operator is prefixed with '!'-                }-  deriving (Eq, Ord)--data BinOpAssoc-  = LeftAssoc-  | RightAssoc-  | NonAssoc-  deriving (Eq, Ord)--instance Show EgisonBinOp where-  show op = repr op--instance Show BinOpAssoc where-  show LeftAssoc  = "infixl"-  show RightAssoc = "infixr"-  show NonAssoc   = "infix"--reservedBinops :: [EgisonBinOp]-reservedBinops =-  [ makeBinOp "^"  "**"        8 LeftAssoc-  , makeBinOp "*"  "*"         7 LeftAssoc-  , makeBinOp "/"  "/"         7 LeftAssoc-  , makeBinOp "%"  "remainder" 7 LeftAssoc-  , makeBinOp "+"  "+"         6 LeftAssoc-  , makeBinOp "-"  "-"         6 LeftAssoc-  , makeBinOp "++" "append"    5 RightAssoc-  , makeBinOp ":"  "cons"      5 RightAssoc-  , makeBinOp "==" "eq?"       4 LeftAssoc-  , makeBinOp "<=" "lte?"      4 LeftAssoc-  , makeBinOp ">=" "gte?"      4 LeftAssoc-  , makeBinOp "<"  "lt?"       4 LeftAssoc-  , makeBinOp ">"  "gt?"       4 LeftAssoc-  , makeBinOp "&&" "and"       3 RightAssoc-  , makeBinOp "||" "or"        2 RightAssoc-  ]-  where-    makeBinOp r f p a =-      EgisonBinOp { repr = r, func = f, priority = p, assoc = a, isWedge = False }-+import           Language.Egison.AST  -- -- Values@@ -454,6 +206,10 @@   | Undefined   | EOF +type Matcher = EgisonValue++type PrimitiveFunc = WHNFData -> EgisonM WHNFData+ -- -- Scalar and Tensor Types --@@ -475,6 +231,8 @@   | FunctionData (Maybe EgisonValue) [EgisonValue] [EgisonValue] [Index ScalarData] -- fnname argnames args indices  deriving (Eq) +type Id = String+ instance Eq PolyExpr where   (Plus []) == (Plus []) = True   (Plus (x:xs)) == (Plus ys) =@@ -1224,78 +982,46 @@       (hs, tms) = splitAt m hms  -- [] [i]       ms = tail tms              -- []    in (hs, ms, ts)               -- [] [] []+ -- -- -- -type Matcher = EgisonValue--type PrimitiveFunc = WHNFData -> EgisonM WHNFData--instance Show EgisonExpr where-  show (CharExpr c) = "c#" ++ [c]-  show (StringExpr str) = "\"" ++ T.unpack str ++ "\""-  show (BoolExpr True) = "#t"-  show (BoolExpr False) = "#f"-  show (IntegerExpr n) = show n-  show (FloatExpr x) = show x-  show (VarExpr name) = show name-  show (PartialVarExpr n) = "%" ++ show n-  show (FunctionExpr args) = "(function [" ++ unwords (map show args) ++ "])"-  show (IndexedExpr True expr idxs) = show expr ++ concatMap show idxs-  show (IndexedExpr False expr idxs) = show expr ++ "..." ++ concatMap show idxs-  show (TupleExpr exprs) = "[" ++ unwords (map show exprs) ++ "]"-  show (CollectionExpr ls) = "{" ++ unwords (map show ls) ++ "}"--  show (UnaryOpExpr op e) = op ++ " " ++ show e-  show (BinaryOpExpr op e1 e2) = "(" ++ show e1 ++ " " ++ show op ++ " " ++ show e2 ++ ")"--  show (QuoteExpr e) = "'" ++ show e-  show (QuoteSymbolExpr e) = "`" ++ show e--  show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")"-  show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")"-  show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")"-  show (VectorExpr xs) = "[| " ++ unwords (map show xs) ++ " |]"-  show (WithSymbolsExpr xs e) = "(withSymbols {" ++ unwords (map show xs) ++ "} " ++ show e ++ ")"-  show _ = "(not supported)"- instance Show EgisonValue where-  show (Char c) = "c#" ++ [c]-  show (String str) = "\"" ++ T.unpack str ++ "\""-  show (Bool True) = "#t"-  show (Bool False) = "#f"+  show (Char c) = '\'' : c : "'"+  show (String str) = show str+  show (Bool True) = "True"+  show (Bool False) = "False"   show (ScalarData mExpr) = show mExpr---  show (TensorData (Scalar x)) = "invalid scalar:" ++ show x-  show (TensorData (Tensor [_] xs js)) = "[| " ++ unwords (map show (V.toList xs)) ++ " |]" ++ concatMap show js+  show (TensorData (Tensor [_] xs js)) = "[| " ++ intercalate ", " (map show (V.toList xs)) ++ " |]" ++ concatMap show js   show (TensorData (Tensor [0, 0] _ js)) = "[| [|  |] |]" ++ concatMap show js-  show (TensorData (Tensor [i, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concatMap show js-   where-    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 (TensorData (Tensor [i, j] xs js)) = "[| " ++ intercalate ", " (f (fromIntegral j) (V.toList xs)) ++ " |]" ++ concatMap show js+    where+      f j [] = []+      f j xs = ["[| " ++ intercalate ", " (map show (take j xs)) ++ " |]"] ++ f j (drop j xs)+  show (TensorData (Tensor ns xs js)) = "(tensor [" ++ intercalate ", " (map show ns) ++ "] [" ++ intercalate ", " (map show (V.toList xs)) ++ "] )" ++ concatMap show js   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) ++ "]"-  show (Collection vals) = if Sq.null vals-                             then "{}"-                             else "{" ++ unwords (map show (toList vals)) ++ "}"-  show (Array vals) = "(|" ++ unwords (map show $ Array.elems vals) ++ "|)"-  show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"-  show (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"-  show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ T.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"+  show (InductiveData name vals) = name ++ concatMap ((' ':) . show') vals+    where+      show' x | isAtomic x = show x+              | otherwise  = "(" ++ show x ++ ")"+  show (Tuple vals)      = "(" ++ intercalate ", " (map show vals) ++ ")"+  show (Collection vals) = "[" ++ intercalate ", " (map show (toList vals)) ++ "]"+  show (Array vals)      = "(| " ++ intercalate ", " (map show $ Array.elems vals) ++ " |)"+  show (IntHash hash)  = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"+  show (CharHash hash) = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"+  show (StrHash hash)  = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show UserMatcher{} = "#<user-matcher>"-  show (Func Nothing _ args _) = "(lambda [" ++ unwords (map show args) ++ "] ...)"+  show (Func Nothing _ args _) = "(lambda [" ++ intercalate ", " (map show args) ++ "] ...)"   show (Func (Just name) _ _ _) = show name   show (PartialFunc _ n expr) = show n ++ "#" ++ show expr   show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"   show (CFunc (Just name) _ _ _) = show name-  show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)"+  show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ intercalate ", " names ++ "] ...)"   show (MemoizedFunc (Just name) _ _ _ names _) = show name-  show (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)"+  show (Proc Nothing _ names _) = "(procedure [" ++ intercalate ", " names ++ "] ...)"   show (Proc (Just name) _ _ _) = name-  show (Macro names _) = "(macro [" ++ unwords names ++ "] ...)"+  show (Macro names _) = "(macro [" ++ intercalate ", " names ++ "] ...)"   show PatternFunc{} = "#<pattern-function>"   show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"   show (IOFunc _) = "#<io-function>"@@ -1306,25 +1032,30 @@   show World = "#<world>"   show EOF = "#<eof>" -instance Show Arg where-  show (ScalarArg name)         = "$" ++ name-  show (InvertedScalarArg name) = "*$" ++ name-  show (TensorArg name)         = "%" ++ name+-- False if we have to put parenthesis around it to make it an atomic expression.+isAtomic :: EgisonValue -> Bool+isAtomic (InductiveData _ []) = True+isAtomic (InductiveData _ _)  = False+isAtomic (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True+isAtomic (ScalarData _) = False+isAtomic _ = True  instance Show ScalarData where   show (Div p1 (Plus [Term 1 []])) = show p1-  show (Div p1 p2)                 = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")"+  show (Div p1 p2)                 = show' p1 ++ " / " ++ show' p2+    where+      show' :: PolyExpr -> String+      show' p@(Plus [_]) = show p+      show' p            = "(" ++ show p ++ ")"  instance Show PolyExpr where   show (Plus [])  = "0"-  show (Plus [t]) = show t-  show (Plus ts)  = "(+ " ++ unwords (map show ts)  ++ ")"+  show (Plus ts)  = intercalate " + " (map show ts)  instance Show TermExpr where   show (Term a []) = show a-  show (Term 1 [x]) = showPoweredSymbol x-  show (Term 1 xs) = "(* " ++ unwords (map showPoweredSymbol xs) ++ ")"-  show (Term a xs) = "(* " ++ show a ++ " " ++ unwords (map showPoweredSymbol xs) ++ ")"+  show (Term 1 xs) = intercalate " * " (map showPoweredSymbol xs)+  show (Term a xs) = intercalate " * " (show a : map showPoweredSymbol xs)  showPoweredSymbol :: (SymbolExpr, Integer) -> String showPoweredSymbol (x, 1) = show x@@ -1339,11 +1070,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 -showTSV :: EgisonValue -> String-showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map show vals)-showTSV (Collection vals) = intercalate "\t" (map show (toList vals))-showTSV val = show val- instance Eq EgisonValue where  (Char c) == (Char c') = c == c'  (String str) == (String str') = str == str'@@ -1367,45 +1093,6 @@  (Macro xs1 expr1) == (Macro xs2 expr2) = (xs1 == xs2) && (expr1 == expr2)  _ == _ = False -instance Show EgisonPattern where-  show WildCard = "_"-  show (PatVar var) = "$" ++ show var-  show (ValuePat expr) = "," ++ show expr-  show (PredPat expr) = "?" ++ show expr-  show (IndexedPat pat exprs) = show pat ++ concatMap (("_" ++) . show) exprs-  show (LetPat bexprs pat) = "(let {" ++ unwords (map (\(vars, expr) -> "[" ++ showVarsHelper vars ++ " " ++ show expr ++ "]") bexprs) ++-                             "} " ++ show pat ++ ")"-    where showVarsHelper [] = ""-          showVarsHelper [v] = "$" ++ show v-          showVarsHelper vs = "[" ++ unwords (map (("$" ++) . show) vs) ++ "]"-  show (LaterPat pat) = "(later " ++ show pat ++ ")"-  show (NotPat pat) = "!" ++ show pat-  show (AndPat pats) = "(&" ++ concatMap ((" " ++) . show) pats ++ ")"-  show (OrPat pats) = "(|" ++ concatMap ((" " ++) . show) pats ++ ")"-  show (TuplePat pats) = "[" ++ unwords (map show pats) ++ "]"-  show (InductivePat name pats) = "<" ++ name ++ concatMap ((" " ++) . show) pats ++ ">"-  show (LoopPat var range pat endPat) = "(loop $" ++ unwords [show var, show range, show pat, show endPat] ++ ")"-  show ContPat = "..."-  show (PApplyPat expr pats) = "(" ++ unwords (show expr : map show pats) ++ ")"-  show (VarPat name) = name-  show SeqNilPat = "{}"-  show (SeqConsPat pat pat') = "{" ++ show pat ++ showSeqPatHelper pat' ++ "}"-    where showSeqPatHelper SeqNilPat = ""-          showSeqPatHelper (SeqConsPat pat pat') = " " ++ show pat ++ showSeqPatHelper pat'-          showSeqPatHelper pat = " " ++ show pat-  show LaterPatVar = "#"--  show (DApplyPat pat pats) = "(" ++ unwords (show pat : map show pats) ++ ")"-  show (DivPat pat pat') = "(/ " ++ show pat ++ " " ++ show pat' ++ ")"-  show (PlusPat pats) = "(+" ++ concatMap ((" " ++) . show) pats-  show (MultPat pats) = "(*" ++ concatMap ((" " ++) . show) pats-  show (PowerPat pat pat') = "(" ++ show pat ++ " ^ " ++ show pat' ++ ")"--instance Show LoopRange where-  show (LoopRange start (ApplyExpr (VarExpr (Var ["from"] [])) (ApplyExpr _ (TupleExpr (x:_)))) endPat) =-    "[" ++ show start ++ " (from " ++ show x ++ ") " ++ show endPat ++ "]"-  show (LoopRange start ends endPat) = "[" ++ show start ++ " " ++ show ends ++ " " ++ show endPat ++ "]"- -- -- Egison data and Haskell data --@@ -1451,7 +1138,7 @@   fromEgison (Port h) = return h   fromEgison val      = throwError =<< TypeMismatch "port" (Value val) <$> getFuncNameStack -instance (EgisonData a) => EgisonData [a] where+instance EgisonData a => EgisonData [a] where   toEgison xs = Collection $ Sq.fromList (map toEgison xs)   fromEgison (Collection seq) = mapM fromEgison (toList seq)   fromEgison val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack@@ -1536,7 +1223,7 @@ -- -- Extract data from WHNF ---class (EgisonData a) => EgisonWHNF a where+class EgisonData a => EgisonWHNF a where   toWHNF :: a -> WHNFData   fromWHNF :: WHNFData -> EgisonM a   toWHNF = Value . toEgison@@ -1577,65 +1264,32 @@ data Env = Env [HashMap Var ObjectRef] (Maybe VarWithIndices)  deriving (Show) -data Var = Var [String] [Index ()]-  deriving (Eq, Generic)- data VarWithIndices = VarWithIndices [String] [Index String]  deriving (Eq) -instance Hashable (Index ())-instance Hashable Var- type Binding = (Var, ObjectRef) -type Id = String--instance Show Var where-  show (Var xs is) = intercalate "." xs ++ concatMap show is--instance Show VarWithIndices where-  show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is--instance Show (Index ()) where-  show (Superscript ())  = "~"-  show (Subscript ())    = "_"-  show (SupSubscript ()) = "~_"-  show (DFscript _ _)    = ""-  show (Userscript _)    = "|"--instance Show (Index String) where-  show (Superscript s)  = "~" ++ s-  show (Subscript s)    = "_" ++ s-  show (SupSubscript s) = "~_" ++ s-  show (DFscript _ _)   = ""-  show (Userscript i)   = "|" ++ show i--instance Show (Index EgisonExpr) where-  show (Superscript i)  = "~" ++ show i-  show (Subscript i)    = "_" ++ show i-  show (SupSubscript i) = "~_" ++ show i-  show (DFscript _ _)   = ""-  show (Userscript i)   = "|" ++ show i- instance Show (Index ScalarData) where   show (Superscript i)  = "~" ++ show i   show (Subscript i)    = "_" ++ show i   show (SupSubscript i) = "~_" ++ show i   show (DFscript _ _)   = ""   show (Userscript i)   = "|" ++ show i+instance Show VarWithIndices where+  show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is  instance Show (Index EgisonValue) where   show (Superscript i) = case i of-                         ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "~[" ++ show i ++ "]"-                         _ -> "~" ++ show i+    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "~[" ++ show i ++ "]"+    _ -> "~" ++ show i   show (Subscript i) = case i of-                         ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"-                         _ -> "_" ++ show i+    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"+    _ -> "_" ++ show i   show (SupSubscript i) = "~_" ++ show i   show (DFscript i j) = "_d" ++ show i ++ show j   show (Userscript i) = case i of-                         ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"-                         _ -> "|" ++ show i+    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"+    _ -> "|" ++ show i  nullEnv :: Env nullEnv = Env [] Nothing@@ -1646,15 +1300,20 @@ refVar :: Env -> Var -> Maybe ObjectRef refVar (Env env _) var = msum $ map (HashMap.lookup var) env +varToVarWithIndices :: Var -> VarWithIndices+varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is+ where+   f :: Index () -> Index String+   f (Superscript ())  = Superscript ""+   f (Subscript ())    = Subscript ""+   f (SupSubscript ()) = SupSubscript ""+ -- -- Pattern Match --  type Match = [Binding] -data PMMode = BFSMode | DFSMode- deriving (Show)- data MatchingState = MState Env [LoopPatContext] [SeqPatContext] [Binding] [MatchingTree]  instance Show MatchingState where@@ -1691,7 +1350,6 @@   | NotImplemented String CallStack   | Assertion String CallStack   | Parser String-  | ParserUnexpectedEOF   | EgisonBug String CallStack   | MatchFailure String CallStack   | Default String@@ -1714,7 +1372,6 @@   show (NotImplemented message stack) = "Not implemented: " ++ message ++ showTrace stack   show (Assertion message stack) = "Assertion failed: " ++ message ++ showTrace stack   show (Parser err) = "Parse error at: " ++ err-  show  ParserUnexpectedEOF = "Parser error: unexpected end of input"   show (EgisonBug message stack) = "Egison Error: " ++ message ++ showTrace stack   show (MatchFailure currentFunc stack) = "Failed pattern match in: " ++ currentFunc ++ showTrace stack   show (Default message) = "Error: " ++ message@@ -1855,6 +1512,9 @@ runFresh :: RuntimeState -> Fresh a -> (a, RuntimeState) runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m +--+-- MList+--  type MatchM = MaybeT EgisonM @@ -1899,7 +1559,9 @@ mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b) mfor = flip mmap +-- -- Typing+--  isBool :: EgisonValue -> Bool isBool (Bool _) = True@@ -1985,50 +1647,3 @@ isHash' (Intermediate (IIntHash _)) = return $ Value $ Bool True isHash' (Intermediate (IStrHash _)) = return $ Value $ Bool True isHash' _                           = return $ Value $ Bool False--readUTF8File :: FilePath -> IO String-readUTF8File name = do-  h <- openFile name ReadMode-  hSetEncoding h utf8-  hGetContents h--stringToVar :: String -> Var-stringToVar name = Var (splitOn "." name) []--stringToVarExpr :: String -> EgisonExpr-stringToVarExpr = VarExpr . stringToVar--varToVarWithIndices :: Var -> VarWithIndices-varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is- where-   f :: Index () -> Index String-   f (Superscript ())  = Superscript ""-   f (Subscript ())    = Subscript ""-   f (SupSubscript ()) = SupSubscript ""------- options-----data EgisonOpts = EgisonOpts {-    optExecFile         :: Maybe (String, [String]),-    optShowVersion      :: Bool,-    optEvalString       :: Maybe String,-    optExecuteString    :: Maybe String,-    optFieldInfo        :: [(String, String)],-    optLoadLibs         :: [String],-    optLoadFiles        :: [String],-    optSubstituteString :: Maybe String,-    optMapTsvInput      :: Maybe String,-    optFilterTsvInput   :: Maybe String,-    optTsvOutput        :: Bool,-    optNoIO             :: Bool,-    optShowBanner       :: Bool,-    optTestOnly         :: Bool,-    optPrompt           :: String,-    optMathExpr         :: Maybe String,-    optSExpr            :: Bool-    }--defaultOption :: EgisonOpts-defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True

@@ -17,9 +17,10 @@ import           System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe) import           Text.Regex.TDFA                  ((=~)) +import           Language.Egison.AST+import           Language.Egison.CmdOptions import           Language.Egison.Parser           as Parser import           Language.Egison.ParserNonS       as ParserNonS-import           Language.Egison.Types  -- |Get Egison expression from the prompt. We can handle multiline input. getEgisonExpr :: EgisonOpts -> InputT IO (Maybe (String, EgisonTopExpr))

@@ -10,7 +10,7 @@ import           Data.Text.Prettyprint.Doc.Render.Text (putDoc) import           System.Environment                    (getArgs) -import           Language.Egison.Types+import           Language.Egison.AST import           Language.Egison.Parser import           Language.Egison.Pretty @@ -52,16 +52,14 @@    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 (LetExpr xs y)         = LetRecExpr (map toNonS xs) (toNonS y)+  toNonS (LetStarExpr xs y)     = LetRecExpr (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 (MatchExpr pmmode x y zs)    = MatchExpr pmmode (toNonS x) (toNonS y) (map toNonS zs)+  toNonS (MatchAllExpr pmmode x y zs) = MatchAllExpr pmmode (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) @@ -72,10 +70,12 @@   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 (ApplyExpr x@(VarExpr (Var [f] [])) (TupleExpr (y:ys)))+    | any (\op -> repr op == f) reservedBinops =+      foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+      where+        op = fromJust $ find (\op -> repr op == f) reservedBinops+  toNonS (ApplyExpr x y) = ApplyExpr (toNonS x) (toNonS y)    toNonS x = x 

@@ -0,0 +1,6 @@+(define $unorderedPair unordered-pair)+(define $takeAndDrop take-and-drop)+(define $takeWhile take-while)+(define $dropWhile drop-while)+(define $deleteFirst delete-first)+(define $deleteFirst/m delete-first/m)

@@ -0,0 +1,47 @@+literal := integer++deleteLiteral l cnf :=+  map (\matchAll as multiset integer with+       | (!#l & $x) :: _ -> x)+      cnf++deleteClausesWith l cnf :=+  matchAll cnf as multiset (multiset integer) with+  | (!(#l :: _) & $c) :: _ -> c++assignTrue l cnf :=+  deleteLiteral (neg l) (deleteClausesWith l cnf)++resolveOn v cnf :=+  matchAll cnf as multiset (multiset integer) with+  | {(#v :: (@ & $xs)) :: (#(neg v) :: (@ & $ys)) :: _,+     !($l :: _, #(neg l) :: _)}+    -> unique (xs ++ ys)++dp vars cnf :=+  match (vars, cnf) as (multiset literal, multiset (multiset literal)) with+  -- satisfiable+  | (_, []) -> True+  -- unsatisfiable+  | (_, [] :: _) -> False+  -- 1-literal rule+  | (_, (($l :: []) :: _))+  -> dp (delete (abs l) vars) (assignTrue l cnf)+  -- pure literal rule (positive)+  | ($v :: $vs, !((#(neg v) :: _) :: _))+  -> dp vs (assignTrue v cnf)+  -- pure literal rule (negative)+  | ($v :: $vs, !((#v :: _) :: _))+  -> dp vs (assignTrue (neg v) cnf)+  -- otherwise+  | ($v :: $vs, _)+  -> dp vs (resolveOn v cnf +++            deleteClausesWith v (deleteClausesWith (neg v) cnf))++dp [1] [[1]] -- True+dp [1] [[1],[-1]] -- False+dp [1,2,3] [[1,2],[-1,3],[1,-3]] -- True+dp [1,2] [[1,2],[-1,-2],[1,-2]] -- True+dp [1,2] [[1,2],[-1,-2],[1,-2],[-1,2]] -- False+dp [1,2,3,4,5] [[-1,-2,3],[-1,-2,-3],[1,2,3,4],[-4,-2,3],[5,1,2,-3],[-3,1,-5],[1,-2,3,4],[1,-2,-3,5]] -- True+dp [1,2] [[-1,-2],[1]] -- True

@@ -35,9 +35,7 @@  assertEqual "compose - case 2" ((compose (fst, snd, fst)) ((1, (2, 3)), 4)) 2 --- assertEqual("eq?/m",---   eq?/m(integer, 1, 1),---   True)+assertEqual "eq?/m" (eq?/m integer 1 1) True  -- -- Booleans@@ -53,3 +51,12 @@ assertEqual "not"   [not True, not False]   [False, True]++--+-- Unordered-Pair+--++assertEqual "unorderedPair matcher"+  (match (1, 2) as unorderedPair integer with+   | (#2, $x) -> x)+  1

@@ -14,22 +14,22 @@   (min [20, 5])   5 --- assertEqual "min/fn"---   (min/fn compare [10, 20, 5, 20, 30])---   5+assertEqual "min/fn"+  (min/fn compare [10, 20, 5, 20, 30])+  5  assertEqual "max"   (max [5, 30])   30 --- assertEqual "max/fn"---   (max/fn compare [10, 20, 5, 20, 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]+assertEqual "sort/fn"+  (sort/fn compare [10, 20, 5, 20, 30])+  [5, 10, 20, 20, 30]

@@ -0,0 +1,39 @@+suit := algebraicDataMatcher+  | spade+  | heart+  | club+  | diamond++card := algebraicDataMatcher+  | card suit (mod 13)++poker cs :=+  match cs as multiset card with+  | card $s $n :: card #s #(n-1) :: card #s #(n-2) :: card #s #(n-3) :: card #s #(n-4) :: _+    -> "Straight flush"+  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []+    -> "Four of a kind"+  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []+    -> "Full house"+  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []+    -> "Flush"+  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []+    -> "Straight"+  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []+    -> "Three of a kind"+  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []+    -> "Two pair"+  | card _ $n :: card _ #n :: _ :: _ :: _ :: []+    -> "One pair"+  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing"+++poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9]    -- "Straight flush"+poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5]   -- "Four of a kind"+poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7]   -- "Full house"+poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9]   -- "Flush"+poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9]     -- "Straight"+poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8]   -- "Three of a kind"+poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10] -- "Two pair"+poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8]  -- "One pair"+poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11] -- "Nothing"

@@ -128,7 +128,7 @@  assertEqual "show" (show 3)              "3" assertEqual "show" (show 3.14159)        "3.14159"-assertEqual "show" (show [1, 2])         "{1 2}"+assertEqual "show" (show [1, 2])         "[1, 2]" assertEqual "show" (show "Hello world!") "\"Hello world!\""  -- TODO: show-tsv@@ -164,7 +164,7 @@ assertEqual "array?" (array? (| 1, 2, 3 |)) True  assertEqual "hash?" (hash? {| |}) True-assertEqual "hash?" (hash? {| [1, 2] |}) True+assertEqual "hash?" (hash? {| (1, 2) |}) True  -- TODO: Add a test case where tensor? returns True assertEqual "tensor?" (tensor? 1)                           False

@@ -51,20 +51,20 @@   False  assertEqual "let binding"-  (let t = (1, 2)-       (x, y) = t+  (let t := (1, 2)+       (x, y) := t     in x + y)   3  assertEqual "let binding"-  (let x = 1-       y = x + 1+  (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)+  (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 @@ -86,32 +86,40 @@ assertEqual "point free expr" ((10 - ) 1) 9 assertEqual "not point free expr" (- 2) (1 - 3) --- findFactor = memoizedLambda+-- findFactor := memoizedLambda --                n -> match takeWhile (<= floor (sqrt (itof n))) primes as list integer with---                     | _ ++ (?(\m -> divisor? n m) && $x)  :  _ -> x+--                     | _ ++ (?(\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 =+twinPrimes :=   matchAll primes as list integer with-  | _ ++ $p : #(p + 2) : _ -> (p, p + 2)+  | _ ++ $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 =+primeTriplets :=+  matchAll primes as list integer with+  | _ ++ $p :: ((#(p + 2) | #(p + 4)) & $m) :: #(p + 6) ::  _ -> (p, m, p + 6)++assertEqual "prime triplets"+  (take 10 primeTriplets)+  [(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)]++someFunction x y z :=   x + y * z  assertEqual "function definition"   (someFunction 1 2 3)   7 -gcd m n =+gcd m n :=   if (m >= n) then-              if (n == 0) then m+              if (n = 0) then m                           else gcd n (m % n)               else gcd n m @@ -131,39 +139,39 @@  assertEqual "match-all"   (matchAll [1, 2, 3] as multiset integer with-   | $x : _ -> x)+   | $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])+   | $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])+    | $x :: _ -> x) [1, 2, 3])   1  assertEqual "match-all-lambda"   ((\matchAll as list something with-    | _ ++ $x : _ -> x) [1, 2, 3])+    | _ ++ $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])+    | $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+   | #2 :: $x -> match x as multiset integer with                 | _ -> False-   | #1 : $x -> match x as multiset integer with-                | #1 : _ -> False-                | #2 : _ -> True)+   | #1 :: $x -> match x as multiset integer with+                | #1 :: _ -> False+                | #2 :: _ -> True)  assertEqual "pattern variable"   (match 1 as something with $x -> x)@@ -177,20 +185,20 @@  assert "and pattern"   (match [1, 2, 3] as list integer with-   | #1 : _ && snoc #3 _ -> True)+   | #1 :: _ & snoc #3 _ -> True)  assert "and pattern"   (match [1, 2, 3] as list integer with-   | #1 : _ && #3 : _ -> False+   | #1 :: _ & #3 :: _ -> False    | _ -> True)  assert "or pattern"   (match [1, 2, 3] as list integer with-   | snoc #1 _ || snoc #3 _ -> True)+   | snoc #1 _ | snoc #3 _ -> True)  assert "or pattern"   (match [1, 2, 3] as list integer with-   | #2 : _ || #1 : _ -> True)+   | #2 :: _ | #1 :: _ -> True)  assert "not pattern"   (match 1 as integer with@@ -199,66 +207,66 @@  assertEqual "not pattern"   (matchAll [1, 2, 2, 3, 3, 3] as multiset integer with-   | $n : !(#n : _) -> n)+   | $n :: !(#n :: _) -> n)   [1]  assert "predicate pattern"   (match [1, 2, 3] as list integer with-   | ?(== 1) : _ -> True)+   | ?(= 1) :: _ -> True)  assert "predicate pattern"   (match [1, 2, 3] as list integer with-   | ?(== 2) : _ -> False+   | ?(= 2) :: _ -> False    | _ -> True)  assertEqual "indexed pattern variable"   (match 23 as mod 10 with    | $a_1 -> a)-  {| [1, 23] |}+  {| (1, 23) |}  assert "loop pattern"   (match [3, 2, 1] as list integer with    | loop $i (1, [3], _)-       | snoc #i ...-       | [] -> True)+       (snoc #i ...)+       [] -> True)  assertEqual "loop pattern"   (match [1..10] as list integer with    | loop $i (1, $n)-       | #i : ...-       | [] -> n)+       (#i :: ...)+       [] -> n)   10  assert "loop pattern"   (match [3, 2, 1] as list integer with    | loop $i (1, [3], _)-       | snoc #i ...-       | [] -> True)+       (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] |}] |}+       ((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)+   | 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])+   | $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])+   | $a & (let n := length a in _) -> [a, n])   [[1, 2, 3], 3]  assertEqual "tuple pattern"@@ -268,44 +276,48 @@  assertEqual "tuple pattern"   (matchAll [(1, 1), (2, 2)] as multiset (integer, integer) with-   | ($x, #x) : _ -> x)+   | ($x, #x) :: _ -> x)   [1, 2]  -- assertEqual "pattern function call"---   (let twin = \pat1 pat2 => (~pat1 && $x) : #x : ~pat2 in+--   (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+--   (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 : ... | _+--   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]|}]+--   [{|(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]))+            | $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]))+            | _ ++ $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+tree a := algebraicDataMatcher   | leaf   | node (tree a) a (tree a) -treeInsert n t =+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@@ -313,7 +325,7 @@       | equal   -> Node t1 n t2       | greater -> Node t1 m (treeInsert n t2) -treeMember? n t =+treeMember? n t :=   match t as tree integer with   | leaf -> False   | node $t1 $m $t2 -> match (compare n m) as ordering with@@ -322,13 +334,13 @@       | greater -> treeMember? n t2  assertEqual "tree set using algebraic-data-matcher"-  (let t = foldr treeInsert Leaf [4, 1, 2, 4, 3]+  (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 :: _,       (#(x + 1), @),       #(x + 2)} -> True) @@ -361,28 +373,21 @@ --  assertEqual "hash-literal"-  {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |}-  {| [1, 11], [2, 12], [3, 13], [4, 14], [5, 15], |}+  {| (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+  {| (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@@ -391,13 +396,13 @@ --   take(10, 1#[%1, @(%0(%1 * 2))](2)) --   [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024] -f *x *y = x + y+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+g x *y := x + y  assertEqual "single inverted index"   (g [|1, 2, 3|]_i  [|10, 20, 30|]_j)@@ -407,54 +412,54 @@ -- matcherExpr, macroExpr -- -list a = matcher+list a := matcher   | [] as () with     | [] -> [()]     | _  -> []-  | $ : $    as (a, list a) with-    | $x : $xs -> [(x, xs)]-    | _        -> []+  | $ :: $    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+  | _ ++ $ as (list a) with     | $tgt -> matchAll tgt as list a with-              | loop $i (1, _) | _ : ...  | $rs -> rs-  | join $ $ as (list a, list a) with+              | loop $i (1, _) (_ :: ...) $rs -> rs+  | $ ++ $ 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)+              | 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 ->+              | 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 []+    | $tgt -> if val = tgt then [()] else []   | $ as something with     | $tgt -> [tgt] -multiset a = matcher+multiset a := matcher   | [] as () with     | $tgt -> match tgt as (mutiset a) with                 | [] -> [()]                 | _ -> []-  | $ : $ as (a, multiset a) with+  | $ :: $ as (a, multiset a) with     | $tgt -> matchAll tgt as list a with-                | $hs ++ $x : $ts -> (x, hs ++ ts)+                | $hs ++ $x :: $ts -> (x, hs ++ ts)   | #$val as () with     | $tgt -> match (val, tgt) as (list a, multiset a) with                 | ([], []) -> [()]-                | ($x : $xs, #x : #xs) -> [()]+                | ($x :: $xs, #x :: #xs) -> [()]                 | (_, _) -> []   | $ as something with     | $tgt -> [tgt]  assertEqual "matcher definition"   (matchAll [1, 2, 3] as multiset integer with-   | $x : _ -> x)+   | $x :: _ -> x)   [1, 2, 3] -nishiwakiIf =+nishiwakiIf :=   macro b e1 e2 ->     car (matchAll b as (matcher                         | $ as something with@@ -464,4 +469,4 @@  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+assertEqual "case 3" (nishiwakiIf (1 = 1) 1 2) 1

@@ -60,14 +60,18 @@ ;; ;; Demonstration code ;;-(test (complete? {<Hnr <Haku>> <Hnr <Haku>>-               <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>-               <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>-               <Num <Pin> 2> <Num <Pin> 3> <Num <Pin> 4>-               <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>}))+(assert-equal "mahjong 1"+  (complete? {<Hnr <Haku>> <Hnr <Haku>>+              <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>+              <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>+              <Num <Pin> 2> <Num <Pin> 3> <Num <Pin> 4>+              <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>})+  #t) -(test (complete? {<Hnr <Haku>> <Hnr <Haku>>-               <Num <Pin> 1> <Num <Pin> 3> <Num <Pin> 4>-               <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>-               <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>-               <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>}))+(assert-equal "mahjong 2"+  (complete? {<Hnr <Haku>> <Hnr <Haku>>+              <Num <Pin> 1> <Num <Pin> 3> <Num <Pin> 4>+              <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>+              <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>+              <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>})+  #f)

@@ -20,5 +20,6 @@   (lambda [$z]     (+ (/ a c) z))) -(f4 (f3 (f2 (f1 z))))-;(/ (+ (* a z) b) (+ (* c z) d))+(assert-equal "mobius transformation"+  (f4 (f3 (f2 (f1 z))))+  (/ (+ (* a z) b) (+ (* c z) d)))

@@ -94,27 +94,34 @@ ;; ;; Demonstration code ;;-(test (poker-hands {<Card <Club> 12>-                    <Card <Club> 10>-                    <Joker>-                    <Card <Club> 1>-                    <Card <Club> 11>}))--(test (poker-hands {<Card <Diamond> 1>-                    <Card <Club> 2>-                    <Joker>-                    <Card <Heart> 1>-                    <Card <Diamond> 2>}))+(assert-equal "poker-hands-with-joker 1"+  (poker-hands {<Card <Club> 12>+                <Card <Club> 10>+                <Joker>+                <Card <Club> 1>+                <Card <Club> 11>})+  <Straight-Flush>) -(test (poker-hands {<Card <Diamond> 4>-                    <Card <Club> 2>-                    <Joker>-                    <Card <Heart> 1>-                    <Card <Diamond> 3>}))+(assert-equal "poker-hands-with-joker 1"+  (poker-hands {<Card <Diamond> 1>+                <Card <Club> 2>+                <Joker>+                <Card <Heart> 1>+                <Card <Diamond> 2>})+  <Full-House>) -(test (poker-hands {<Card <Diamond> 4>-                    <Card <Club> 10>-                    <Joker>-                    <Card <Heart> 1>-                    <Card <Diamond> 3>}))+(assert-equal "poker-hands-with-joker 1"+  (poker-hands {<Card <Diamond> 4>+                <Card <Club> 2>+                <Joker>+                <Card <Heart> 1>+                <Card <Diamond> 3>})+  <Straight>) +(assert-equal "poker-hands-with-joker 1"+  (poker-hands {<Card <Diamond> 4>+                <Card <Club> 10>+                <Joker>+                <Card <Heart> 1>+                <Card <Diamond> 3>})+  <One-Pair>)

@@ -88,27 +88,34 @@ ;; ;; Demonstration code ;;-(test (poker-hands {<Card <Club> 12>-                    <Card <Club> 10>-                    <Card <Club> 13>-                    <Card <Club> 1>-                    <Card <Club> 11>}))--(test (poker-hands {<Card <Diamond> 1>-                    <Card <Club> 2>-                    <Card <Club> 1>-                    <Card <Heart> 1>-                    <Card <Diamond> 2>}))+(assert-equal "poker hands 1"+  (poker-hands {<Card <Club> 12>+                <Card <Club> 10>+                <Card <Club> 13>+                <Card <Club> 1>+                <Card <Club> 11>})+  "Straight flush") -(test (poker-hands {<Card <Diamond> 4>-                    <Card <Club> 2>-                    <Card <Club> 5>-                    <Card <Heart> 1>-                    <Card <Diamond> 3>}))+(assert-equal "poker hands 2"+  (poker-hands {<Card <Diamond> 1>+                <Card <Club> 2>+                <Card <Club> 1>+                <Card <Heart> 1>+                <Card <Diamond> 2>})+  "Full house") -(test (poker-hands {<Card <Diamond> 4>-                    <Card <Club> 10>-                    <Card <Club> 5>-                    <Card <Heart> 1>-                    <Card <Diamond> 3>}))+(assert-equal "poker hands 3"+  (poker-hands {<Card <Diamond> 4>+                <Card <Club> 2>+                <Card <Club> 5>+                <Card <Heart> 1>+                <Card <Diamond> 3>})+  "Straight") +(assert-equal "poker hands 4"+  (poker-hands {<Card <Diamond> 4>+                <Card <Club> 10>+                <Card <Club> 5>+                <Card <Heart> 1>+                <Card <Diamond> 3>})+  "Nothing")

@@ -11,7 +11,9 @@      [p (+ p 2)]]))  ;; Enumerate the first 10 twin primes-(take 10 twin-primes)+(assert-equal "first 10 twin prime"+  (take 10 twin-primes)+  {[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]})  ;; Extract all prime-triplets from the infinite list of prime numbers with pattern-matching! (define $prime-triplets@@ -22,5 +24,6 @@      [p m (+ p 6)]]))  ;; Enumerate the first 10 prime triplets-(take 10 prime-triplets)-+(assert-equal "first 10 prime triplets"+  (take 10 prime-triplets)+  {[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]})

@@ -15,8 +15,10 @@  import           Language.Egison import           Language.Egison.Core+import           Language.Egison.CmdOptions import qualified Language.Egison.Parser         as Parser import qualified Language.Egison.ParserNonS     as ParserNonS+import           Language.Egison.Pretty import           Language.Egison.Primitives import           Language.Egison.Types @@ -40,6 +42,11 @@   , "test/lib/core/collection.egi"   , "test/lib/core/order.egi"   , "test/lib/core/number.egi"++  , "sample/mahjong.egi"+  , "sample/poker-hands-with-joker.egi"+  , "sample/poker-hands.egi"+  , "sample/primes.egi"   ]  unitNonSTestCases :: [FilePath]@@ -52,11 +59,7 @@  sampleTestCases :: [FilePath] sampleTestCases =-  [ "test/answer/sample/poker-hands-with-joker.egi"-  , "test/answer/sample/primes.egi"-  , "test/answer/sample/mahjong.egi"-  , "test/answer/sample/poker-hands.egi"-  , "test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi"+  [ "test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi"   , "test/answer/sample/math/number/17th-root-of-unity.egi"   ] @@ -102,10 +105,10 @@     f :: [String] -> [(EgisonExpr, EgisonValue)] -> String     f answers ls = g answers ls 0     g x y i = let (e, v) = unzip y in-              if (x !! i) == show (v !! i)+              if (x !! i) == prettyS (v !! i)                  then (if i < (length y - 1) then g x y (i + 1)                                              else "")-                 else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ show (v !! i)+                 else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ prettyS (v !! i)  collectDefsAndTests :: EgisonTopExpr -> ([(Var, EgisonExpr)], [EgisonExpr]) -> ([(Var, EgisonExpr)], [EgisonExpr]) collectDefsAndTests (Define name expr) (bindings, tests) =

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

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

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

@@ -1,2 +0,0 @@-{[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]}

@@ -77,9 +77,9 @@                        [[_ _] 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 |] |]")+  "[| [| 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 |] |]")+  "[| [| g_1_1|x, 0, 0 |], [| 0, g_2_2|x, 0 |], [| 0, 0, g_3_3|x |] |]")