egison 3.8.2 → 3.9.0
raw patch · 26 files changed
+1164/−858 lines, 26 filesdep +optparse-applicativedep +semigroupsdep −lensdep ~basedep ~mtldep ~parsec
Dependencies added: optparse-applicative, semigroups
Dependencies removed: lens
Dependency ranges changed: base, mtl, parsec
Files
- benchmark/Benchmark.hs +11/−11
- egison.cabal +8/−3
- elisp/egison-mode.el +4/−0
- hs-src/Interpreter/egison.hs +146/−209
- hs-src/Language/Egison.hs +60/−51
- hs-src/Language/Egison/Core.hs +167/−196
- hs-src/Language/Egison/Desugar.hs +7/−16
- hs-src/Language/Egison/Lexer.x +122/−0
- hs-src/Language/Egison/MathOutput.hs +11/−2
- hs-src/Language/Egison/Parser.hs +16/−23
- hs-src/Language/Egison/ParserNonS.hs +5/−5
- hs-src/Language/Egison/ParserNonS2.y +96/−0
- hs-src/Language/Egison/Primitives.hs +55/−55
- hs-src/Language/Egison/Types.hs +220/−168
- hs-src/Language/Egison/Util.hs +30/−24
- lib/core/assoc.egi +2/−2
- lib/core/base.egi +13/−0
- lib/core/collection.egi +9/−2
- lib/core/io.egi +13/−2
- lib/core/order.egi +2/−2
- lib/math/algebra/matrix.egi +2/−2
- lib/math/expression.egi +2/−2
- sample/dp.egi +0/−43
- sample/order.egi +0/−23
- sample/unify.egi +145/−0
- test/Test.hs +18/−17
benchmark/Benchmark.hs view
@@ -1,24 +1,24 @@ {-# LANGUAGE FlexibleInstances #-} module Main where-import Control.Applicative ((<$>), (<*>))-import Control.Monad.Error-import Control.Applicative-import Control.DeepSeq (NFData(rnf))-import Criterion.Main-import Criterion.Config-import Language.Egison+import Control.Applicative ((<$>), (<*>))+import Control.Applicative+import Control.DeepSeq (NFData (rnf))+import Control.Monad.Error+import Criterion.Config+import Criterion.Main+import Language.Egison runEgisonFile :: String -> IO (Either EgisonError Env)-runEgisonFile path = loadPrimitives nullEnv >>= loadLibraries >>= flip loadEgisonFile path+runEgisonFile path = loadPrimitives nullEnv >>= loadLibraries >>= flip (loadEgisonFile defaultOption) path config :: Config-config = defaultConfig { cfgSamples = ljust 3 +config = defaultConfig { cfgSamples = ljust 3 , cfgPerformGC = ljust True } main :: IO ()-main = defaultMainWith config (return ()) +main = defaultMainWith config (return ()) [ bgroup "fact" [ bench "30000" $ runEgisonFile "benchmark/fact-30000.egi" ]- , bgroup "collection" + , bgroup "collection" [ bench "cons-bench" $ runEgisonFile "benchmark/collection-bench-cons.egi" , bench "cons-bench-large" $ runEgisonFile "benchmark/collection-bench-cons-large.egi" , bench "snoc-bench" $ runEgisonFile "benchmark/collection-bench-snoc.egi"
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 3.8.2+Version: 3.9.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.@@ -68,7 +68,7 @@ location: https://github.com/egison/egison.git Library- Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector, parallel, split, hashable, lens+ Build-Depends: base >= 4.7 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl >=2.2.1, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector, parallel, split, hashable if !impl(ghc > 8.0) Build-Depends: fail Hs-Source-Dirs: hs-src@@ -77,12 +77,15 @@ Language.Egison.Core Language.Egison.Desugar Language.Egison.Types+ Language.Egison.Lexer Language.Egison.Parser Language.Egison.ParserNonS+ Language.Egison.ParserNonS2 Language.Egison.Primitives Language.Egison.Util Language.Egison.MathOutput Other-modules: Paths_egison+ build-tools: happy, alex ghc-options: -O3 Test-Suite test@@ -101,7 +104,9 @@ Executable egison Main-is: egison.hs- Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process, vector+ Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.1, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process, vector, optparse-applicative+ if !impl(ghc > 8.0)+ Build-Depends: semigroups Hs-Source-Dirs: hs-src/Interpreter Other-modules: Paths_egison ghc-options: -O3 -threaded -eventlog -rtsopts
elisp/egison-mode.el view
@@ -71,8 +71,10 @@ "\\<loop\\>" "\\<match\\>"+ "\\<match-dfs\\>" "\\<match-lambda\\>" "\\<match-all\\>"+ "\\<match-all-dfs\\>" "\\<match-all-lambda\\>" "\\<matcher\\>" "\\<self\\>"@@ -194,8 +196,10 @@ ((equal "tensor-map" name) 2) ((equal "loop" name) 2) ((equal "match" name) 2)+ ((equal "match-dfs" name) 2) ((equal "match-lambda" name) 2) ((equal "match-all" name) 2)+ ((equal "match-all-dfs" name) 2) ((equal "match-all-lambda" name) 2) ((equal "matcher" name) 2) ((equal "algebraic-data-matcher" name) 2)
hs-src/Interpreter/egison.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} module Main where@@ -10,6 +11,7 @@ import Data.Char import Data.List (intercalate)+import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Version@@ -28,158 +30,95 @@ import Language.Egison.MathOutput import Language.Egison.Util -main :: IO ()-main = do args <- getArgs- let (actions, nonOpts, _) = getOpt Permute options args- let opts = foldl (flip id) defaultOptions actions- case opts of- Options {optShowHelp = True} -> printHelp- Options {optShowVersion = True} -> printVersionNumber- Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag, optMathExpr = mathExprLang, optSExpr = isSExpr} -> do- coreEnv <- if noIOFlag then initialEnvNoIO else initialEnv- mEnv <- evalEgisonTopExprs coreEnv $ map (Load isSExpr) loadLibs ++ map (LoadFile isSExpr) loadFiles- case mEnv of- Left err -> print err- Right env ->- case mExpr of- Just expr ->- if tsvFlag- then do ret <- runEgisonTopExprs isSExpr env $ "(execute (each (compose show-tsv print) " ++ expr ++ "))"- case ret of- Left err -> hPrint stderr err- Right _ -> return ()- else do ret <- runEgisonExpr isSExpr env expr- case ret of- Left err -> hPrint stderr err >> exitFailure- Right val -> print val >> exitSuccess- Nothing ->- case mCmd of- Just cmd -> do cmdRet <- runEgisonTopExpr isSExpr env ("(execute " ++ cmd ++ ")")- case cmdRet of- Left err -> print err >> exitFailure- _ -> exitSuccess- Nothing ->- case mSub of- Just sub -> do cmdRet <- runEgisonTopExprs isSExpr env ("(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if tsvFlag then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ unwords (map fst fieldInfo) ++ "} {" ++ unwords (map snd fieldInfo) ++ "})]} (" ++ sub ++ " SH.input))))")- case cmdRet of- Left err -> print err >> exitFailure- _ -> exitSuccess- Nothing ->- case nonOpts of- [] -> when bannerFlag showBanner >> repl noIOFlag isSExpr mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitSuccess- (file:args) ->- case opts of- Options {optTestOnly = True} -> do- result <- if noIOFlag- then do input <- readFile file- runEgisonTopExprsNoIO isSExpr env input- else evalEgisonTopExprsTestOnly env [LoadFile isSExpr file]- either print (const $ return ()) result- Options {optTestOnly = False} -> do- result <- evalEgisonTopExprs env [LoadFile isSExpr file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))]- either print (const $ return ()) result+import Options.Applicative -data Options = Options {- optShowVersion :: Bool,- optShowHelp :: Bool,- optEvalString :: Maybe String,- optExecuteString :: Maybe String,- optSubstituteString :: Maybe String,- optFieldInfo :: [(String, String)],- optLoadLibs :: [String],- optLoadFiles :: [String],- optTsvOutput :: Bool,- optNoIO :: Bool,- optShowBanner :: Bool,- optTestOnly :: Bool,- optPrompt :: String,- optMathExpr :: Maybe String,- optSExpr :: Bool- } -defaultOptions :: Options-defaultOptions = Options {- optShowVersion = False,- optShowHelp = False,- optEvalString = Nothing,- optExecuteString = Nothing,- optSubstituteString = Nothing,- optFieldInfo = [],- optLoadLibs = [],- optLoadFiles = [],- optTsvOutput = False,- optNoIO = False,- optShowBanner = True,- optTestOnly = False,- optPrompt = "> ",- optMathExpr = Nothing,- optSExpr = True- }+main :: IO ()+main = execParser parserInfo >>= runWithOptions -options :: [OptDescr (Options -> Options)]-options = [- Option ['h', '?'] ["help"]- (NoArg (\opts -> opts {optShowHelp = True}))- "show usage information",- Option ['v', 'V'] ["version"]- (NoArg (\opts -> opts {optShowVersion = True}))- "show version number",- Option ['L'] ["load-library"]- (ReqArg (\d opts -> opts {optLoadLibs = optLoadLibs opts ++ [d]})- "[String]")- "load library",- Option ['l'] ["load-file"]- (ReqArg (\d opts -> opts {optLoadFiles = optLoadFiles opts ++ [d]})- "[String]")- "load file",- Option [] ["no-io"]- (NoArg (\opts -> opts {optNoIO = True}))- "prohibit all io primitives",- Option ['p'] ["prompt"]- (ReqArg (\prompt opts -> opts {optPrompt = prompt})- "String")- "set prompt string",- Option [] ["no-banner"]- (NoArg (\opts -> opts {optShowBanner = False}))- "do not display banner",- Option ['t'] ["test"]- (NoArg (\opts -> opts {optTestOnly = True}))- "execute only test expressions",- Option ['e'] ["eval"]- (ReqArg (\expr opts -> opts {optEvalString = Just expr})- "String")- "eval the argument string",- Option ['c'] ["command"]- (ReqArg (\expr opts -> opts {optExecuteString = Just expr})- "String")- "execute the argument string",- Option ['s'] ["substitute"]- (ReqArg (\expr opts -> opts {optSubstituteString = Just expr})- "String")- "substitute strings",- Option ['m'] ["map"]- (ReqArg (\expr opts -> opts {optSubstituteString = Just ("(map " ++ expr ++ " $)")})- "String")- "filter strings",- Option ['f'] ["filter"]- (ReqArg (\expr opts -> opts {optSubstituteString = Just ("(filter " ++ expr ++ " $)")})- "String")- "filter strings",- Option ['T'] ["tsv"]- (NoArg (\opts -> opts {optTsvOutput = True}))- "output in tsv format",- Option ['F'] ["--field"]- (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [readFieldOption d]})- "String")- "field information",- Option ['M'] ["math"]- (ReqArg (\lang opts -> opts {optMathExpr = Just lang})- "String")- "output in AsciiMath, Latex, Mathematica, or Maxima format",- Option ['N'] ["new-syntax"]- (NoArg (\opts -> opts {optSExpr = False}))- "parse by new syntax"- ]+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 "Use non-S-expressoin syntax")+ <*> flag False True+ (long "happy"+ <> help "[experimental] Use new lexer and parser") readFieldOption :: String -> (String, String) readFieldOption str =@@ -196,50 +135,55 @@ ['s', 'c'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}") ['c', 's'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}") -printHelp :: IO ()-printHelp = do- putStrLn "Usage: egison [options]"- putStrLn " egison [options] file"- putStrLn " egison [options] expr"- putStrLn ""- putStrLn "Global Options:"- putStrLn " --help, -h Display this information"- putStrLn " --version, -v Display egison version information"- putStrLn ""- putStrLn " --load-library, -L file Load the argument library"- putStrLn " --load-file, -l file Load the argument file"- putStrLn " --no-io Prohibit all IO primitives"- putStrLn ""- putStrLn "Options as an interactive interpreter:"- putStrLn " --prompt string Set prompt of the interpreter"- putStrLn " --no-banner Don't show banner"- putStrLn ""- putStrLn "Options to handle Egison program file:"- putStrLn " --test, -t file Run only test expressions"- putStrLn ""- putStrLn "Options as a shell command:"- putStrLn " --eval, -e expr Evaluate the argument expression"- putStrLn " --command, -c expr Execute the argument expression"- putStrLn ""- putStrLn " --substitute, -s expr Substitute input using the argument expression"- putStrLn " --map, -m expr Substitute each line of input using the argument expression"- putStrLn " --filter, -f expr Filter each line of input using the argument predicate"- putStrLn ""- putStrLn "Options to change input or output format:"- putStrLn " --tsv, -T Input and output in tsv format"- putStrLn " --field, -F field Specify a field type of input tsv"- putStrLn " --math, -M (asciimath|latex|mathematica|maxima)"- putStrLn " Output in AsciiMath, LaTeX, or Mathematica format (only for interpreter)"- exitSuccess--printVersionNumber :: IO ()-printVersionNumber = do- putStrLn $ showVersion version- exitSuccess+runWithOptions :: EgisonOpts -> IO ()+runWithOptions opts+ | optShowVersion opts = putStrLn (showVersion version) >> exitSuccess+ | isInValidMathOption opts = hPrint stderr (Default "this output lang is not supported") >> exitFailure+ | otherwise = do+ coreEnv <- initialEnv opts+ mEnv <- evalEgisonTopExprs opts coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts)+ case mEnv of+ Left err -> print err+ Right env ->+ case optEvalString opts of+ Just expr ->+ if optTsvOutput opts+ then f opts env $ "(execute (each (compose show-tsv print) " ++ expr ++ "))"+ else do ret <- runEgisonExpr opts env expr+ case ret of+ Left err -> hPrint stderr err >> exitFailure+ Right val -> print val >> exitSuccess+ Nothing ->+ case optExecuteString opts of+ Just cmd -> f opts env $ "(execute " ++ cmd ++ ")"+ Nothing ->+ case optSubstituteString opts of+ Just sub -> f opts env $ "(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if optTsvOutput opts then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ unwords (map fst $ optFieldInfo opts) ++ "} {" ++ unwords (map snd $ optFieldInfo opts) ++ "})]} (" ++ sub ++ " SH.input))))"+ Nothing ->+ case optExecFile opts of+ Nothing -> when (optShowBanner opts) showBanner >> repl opts env >> when (optShowBanner opts) showByebyeMessage >> exitSuccess+ Just (file, args) ->+ if optTestOnly opts then do+ result <- if optNoIO opts+ then do input <- readFile file+ runEgisonTopExprs opts env input+ else evalEgisonTopExprs opts env [LoadFile file]+ either print (const $ return ()) result+ else do+ result <- evalEgisonTopExprs opts env [LoadFile file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))]+ either print (const $ return ()) result+ where+ isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = notElem lang ["asciimath", "latex", "mathematica", "maxima"]+ isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False+ f opts env expr = do+ cmdRet <- runEgisonTopExpr opts env expr+ case cmdRet of+ Left err -> hPrint stderr err >> exitFailure+ _ -> exitSuccess showBanner :: IO () showBanner = do- putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2018 Satoshi Egi"+ putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2019 Satoshi Egi" putStrLn $ "https://www.egison.org" putStrLn $ "Welcome to Egison Interpreter!" -- putStrLn $ "** Information **"@@ -250,41 +194,34 @@ showByebyeMessage :: IO () showByebyeMessage = putStrLn "Leaving Egison Interpreter." -repl :: Bool -> Bool -> Maybe String -> Env -> String -> IO ()-repl noIOFlag isSExpr mathExprLang env prompt =+repl :: EgisonOpts -> Env -> IO ()+repl opts env = loop $ StateT (\defines -> (, defines) <$> recursiveBind env defines) where settings :: MonadIO m => FilePath -> Settings m- settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history") }+ settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history"), autoAddHistory = False } loop :: StateT [(Var, EgisonExpr)] EgisonM Env -> IO () loop st = (do home <- getHomeDirectory- input <- liftIO $ runInputT (settings home) $ getEgisonExpr isSExpr prompt- case (noIOFlag, input) of+ input <- liftIO $ runInputT (settings home) $ getEgisonExpr opts+ case (optNoIO opts, input) of (_, Nothing) -> return ()- (True, Just (_, LoadFile _ _)) -> do+ (True, Just (_, LoadFile _)) -> do putStrLn "error: No IO support" loop st- (True, Just (_, Load _ _)) -> do+ (True, Just (_, Load _)) -> do putStrLn "error: No IO support" loop st (_, Just (topExpr, _)) -> do- result <- liftIO $ runEgisonTopExpr' isSExpr st topExpr+ result <- liftIO $ runEgisonTopExpr' opts st topExpr case result of- Left err -> do- liftIO $ print err- loop st+ Left err -> liftIO (print err) >> loop st Right (Nothing, st') -> loop st' Right (Just output, st') ->- case mathExprLang of- Nothing -> putStrLn output >> loop st'- (Just "haskell") -> putStrLn (mathExprToHaskell output) >> loop st'- (Just "asciimath") -> putStrLn (mathExprToAsciiMath output) >> loop st'- (Just "latex") -> putStrLn (mathExprToLatex output) >> loop st'- (Just "mathematica") -> putStrLn (mathExprToMathematica output) >> loop st'- (Just "maxima") -> putStrLn (mathExprToMaxima output) >> loop st'- _ -> putStrLn "error: this output lang is not supported"+ case optMathExpr opts of+ Nothing -> putStrLn output >> loop st'+ Just lang -> putStrLn (changeOutputInLang lang output) >> loop st' ) `catch` (\case
hs-src/Language/Egison.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TupleSections #-}+ {- | Module : Language.Egison Copyright : Satoshi Egi@@ -10,31 +12,32 @@ ( module Language.Egison.Types , module Language.Egison.Primitives -- * Eval Egison expressions+ , evalTopExprs+ , evalTopExpr , evalEgisonExpr , evalEgisonTopExpr , evalEgisonTopExprs- , evalEgisonTopExprsTestOnly , runEgisonExpr , runEgisonTopExpr , runEgisonTopExpr' , runEgisonTopExprs- , runEgisonTopExprsNoIO -- * Load Egison files , loadEgisonLibrary , loadEgisonFile -- * Environment , initialEnv- , initialEnvNoIO -- * Information , version- ) where+ ) where import Data.Version-import qualified Paths_egison as P+import qualified Paths_egison as P import Language.Egison.Core-import Language.Egison.Parser as Parser-import Language.Egison.ParserNonS as ParserNonS+import Language.Egison.MathOutput (changeOutputInLang)+import Language.Egison.Parser as Parser+import Language.Egison.ParserNonS as ParserNonS+import Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Primitives import Language.Egison.Types @@ -44,71 +47,77 @@ version :: Version version = P.version +evalTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> EgisonM Env+evalTopExprs opts env exprs = do+ (bindings, rest) <- collectDefs opts exprs [] []+ env <- recursiveBind env bindings+ forM_ rest $ evalTopExpr opts env+ return env++evalTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> EgisonM Env+evalTopExpr opts env topExpr = do+ ret <- evalTopExpr' opts (StateT $ \defines -> (, defines) <$> recursiveBind env defines) topExpr+ case fst ret of+ Nothing -> return ()+ Just output -> liftIO $+ case optMathExpr opts of+ Nothing -> putStrLn output+ Just lang -> putStrLn $ changeOutputInLang lang output+ evalStateT (snd ret) []+ -- |eval an Egison expression evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue) evalEgisonExpr env expr = fromEgisonM $ evalExprDeep env expr -- |eval an Egison top expression-evalEgisonTopExpr :: Env -> EgisonTopExpr -> IO (Either EgisonError Env)-evalEgisonTopExpr env exprs = fromEgisonM $ evalTopExpr env exprs+evalEgisonTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> IO (Either EgisonError Env)+evalEgisonTopExpr opts env exprs = fromEgisonM $ evalTopExpr opts env exprs -- |eval Egison top expressions-evalEgisonTopExprs :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)-evalEgisonTopExprs env exprs = fromEgisonM $ evalTopExprs env exprs---- |eval Egison top expressions and execute test expressions-evalEgisonTopExprsTestOnly :: Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)-evalEgisonTopExprsTestOnly env exprs = fromEgisonM $ evalTopExprsTestOnly env exprs+evalEgisonTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> IO (Either EgisonError Env)+evalEgisonTopExprs opts env exprs = fromEgisonM $ evalTopExprs opts env exprs -- |eval an Egison expression. Input is a Haskell string.-runEgisonExpr :: Bool -> Env -> String -> IO (Either EgisonError EgisonValue)-runEgisonExpr True env input = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env-runEgisonExpr False env input = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env+runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue)+runEgisonExpr opts env input+ | optUseHappy opts = fromEgisonM $ ParserNonS2.readExpr input >>= evalExprDeep env+ | optSExpr opts = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env+ | otherwise = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env -- |eval an Egison top expression. Input is a Haskell string.-runEgisonTopExpr :: Bool -> Env -> String -> IO (Either EgisonError Env)-runEgisonTopExpr True env input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr env-runEgisonTopExpr False env input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr env+runEgisonTopExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env)+runEgisonTopExpr opts env input+ | optUseHappy opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr opts env+ | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr opts env+ | otherwise = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr opts env -- |eval an Egison top expression. Input is a Haskell string.-runEgisonTopExpr' :: Bool -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env))-runEgisonTopExpr' True st input = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' st-runEgisonTopExpr' False st input = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' st+runEgisonTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env))+runEgisonTopExpr' opts st input+ | optUseHappy opts = fromEgisonM $ ParserNonS2.readTopExpr input >>= evalTopExpr' opts st+ | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' opts st+ | otherwise = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' opts st -- |eval Egison top expressions. Input is a Haskell string.-runEgisonTopExprs :: Bool -> Env -> String -> IO (Either EgisonError Env)-runEgisonTopExprs True env input = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs env-runEgisonTopExprs False env input = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs env---- |eval Egison top expressions without IO. Input is a Haskell string.-runEgisonTopExprsNoIO :: Bool -> Env -> String -> IO (Either EgisonError Env)-runEgisonTopExprsNoIO True env input = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprsNoIO env-runEgisonTopExprsNoIO False env input = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprsNoIO env+runEgisonTopExprs :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env)+runEgisonTopExprs opts env input+ | optUseHappy opts = fromEgisonM $ ParserNonS2.readTopExprs input >>= evalTopExprs opts env+ | optSExpr opts = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs opts env+ | otherwise = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs opts env -- |load an Egison file-loadEgisonFile :: Bool -> Env -> FilePath -> IO (Either EgisonError Env)-loadEgisonFile isSExpr env path = evalEgisonTopExpr env (LoadFile isSExpr path)+loadEgisonFile :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env)+loadEgisonFile opts env path = evalEgisonTopExpr opts env (LoadFile path) -- |load an Egison library-loadEgisonLibrary :: Bool -> Env -> FilePath -> IO (Either EgisonError Env)-loadEgisonLibrary isSExpr env path = evalEgisonTopExpr env (Load isSExpr path)+loadEgisonLibrary :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env)+loadEgisonLibrary opts env path = evalEgisonTopExpr opts env (Load path) -- |Environment that contains core libraries-initialEnv :: IO Env-initialEnv = do- env <- primitiveEnv- ret <- evalEgisonTopExprs env $ map (Load True) coreLibraries- case ret of- Left err -> do- print . show $ err- return env- Right env' -> return env'---- |Environment that contains core libraries without IO primitives-initialEnvNoIO :: IO Env-initialEnvNoIO = do- env <- primitiveEnvNoIO- ret <- evalEgisonTopExprs env $ map (Load True) coreLibraries+initialEnv :: EgisonOpts -> IO Env+initialEnv opts = do+ env <- if optNoIO opts then primitiveEnvNoIO else primitiveEnv+ ret <- evalEgisonTopExprs defaultOption env $ map Load coreLibraries case ret of Left err -> do print . show $ err
hs-src/Language/Egison/Core.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -14,10 +13,7 @@ module Language.Egison.Core ( -- * Egison code evaluation- evalTopExprs- , evalTopExprsTestOnly- , evalTopExprsNoIO- , evalTopExpr+ collectDefs , evalTopExpr' , evalExpr , evalExprDeep@@ -43,133 +39,88 @@ , packStringValue ) where -import Prelude hiding (mapM, mappend, mconcat)+import Prelude hiding (mapM, mappend, mconcat) import Control.Applicative import Control.Arrow-import Control.Lens (makeLenses, (%~), (&), (.~), (^.))-import Control.Monad (when)-import Control.Monad.Except hiding (mapM)-import Control.Monad.State hiding (mapM)+import Control.Monad (when)+import Control.Monad.Except hiding (mapM)+import Control.Monad.State hiding (mapM) import Control.Monad.Trans.Maybe-import Control.Monad.Trans.State (evalStateT, withStateT)+import Control.Monad.Trans.State (evalStateT, withStateT) -import Data.Foldable (toList)+import Data.Foldable (toList) import Data.IORef-import Data.List (any, drop, last, nub, partition)-import Data.List.Split (oneOf, split)+import Data.List (any, drop, last, nub, partition)+import Data.List.Split (oneOf, split) import Data.Maybe import Data.Ratio-import Data.Sequence (Seq, ViewL (..), ViewR (..), (><))-import qualified Data.Sequence as Sq-import Data.Traversable (mapM)+import Data.Sequence (Seq, ViewL (..), ViewR (..), (><))+import qualified Data.Sequence as Sq+import Data.Traversable (mapM) -import Data.Array ((!))-import qualified Data.Array as Array-import qualified Data.HashMap.Lazy as HL-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Map (Map, assocs, empty, singleton,- unionWith, unionsWith, (!))-import qualified Data.Map as M-import qualified Data.Vector as V+import Data.Array ((!))+import qualified Data.Array as Array+import qualified Data.HashMap.Lazy as HL+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map, assocs, empty, singleton,+ unionWith, unionsWith, (!))+import qualified Data.Map as M+import qualified Data.Vector as V -import Data.Text (Text)-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as T -import Language.Egison.Parser as Parser-import Language.Egison.ParserNonS as ParserNonS+import Language.Egison.MathOutput+import Language.Egison.Parser as Parser+import Language.Egison.ParserNonS as ParserNonS+import Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Types -- -- Evaluator -- -evalTopExprs :: Env -> [EgisonTopExpr] -> EgisonM Env-evalTopExprs env exprs = do- (bindings, rest) <- collectDefs exprs [] []- env <- recursiveBind env bindings- forM_ rest $ evalTopExpr env- return env--collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])-collectDefs (expr:exprs) bindings rest =+collectDefs :: EgisonOpts -> [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])+collectDefs opts (expr:exprs) bindings rest = case expr of- Define name expr -> collectDefs exprs ((name, expr) : bindings) rest- Load b file -> do- exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file- collectDefs (exprs' ++ exprs) bindings rest- LoadFile b file -> do- exprs' <- if b then Parser.loadFile file else ParserNonS.loadFile file- collectDefs (exprs' ++ exprs) bindings rest- Execute _ -> collectDefs exprs bindings (expr : rest)- _ -> collectDefs exprs bindings rest-collectDefs [] bindings rest = return (bindings, reverse rest)--evalTopExprsTestOnly :: Env -> [EgisonTopExpr] -> EgisonM Env-evalTopExprsTestOnly env exprs = do- (bindings, rest) <- collectDefs exprs [] []- env <- recursiveBind env bindings- forM_ rest $ evalTopExpr env- return env- where- collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])- collectDefs (expr:exprs) bindings rest =- case expr of- Define name expr -> collectDefs exprs ((name, expr) : bindings) rest- Load b file -> do- exprs' <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file- collectDefs (exprs' ++ exprs) bindings rest- LoadFile b file -> do- exprs' <- if b then Parser.loadFile file else ParserNonS.loadFile file- collectDefs (exprs' ++ exprs) bindings rest- Test _ -> collectDefs exprs bindings (expr : rest)- Redefine _ _ -> collectDefs exprs bindings (expr : rest)- _ -> collectDefs exprs bindings rest- collectDefs [] bindings rest = return (bindings, reverse rest)--evalTopExprsNoIO :: Env -> [EgisonTopExpr] -> EgisonM Env-evalTopExprsNoIO env exprs = do- (bindings, rest) <- collectDefs exprs [] []- env <- recursiveBind env bindings- forM_ rest $ evalTopExpr env- return env- where- collectDefs :: [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(Var, EgisonExpr)], [EgisonTopExpr])- collectDefs (expr:exprs) bindings rest =- case expr of- Define name expr -> collectDefs exprs ((name, expr) : bindings) rest- Load _ _ -> throwError $ Default "No IO support"- LoadFile _ _ -> throwError $ Default "No IO support"- _ -> collectDefs exprs bindings (expr : rest)- collectDefs [] bindings rest = return (bindings, reverse rest)--evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env-evalTopExpr env topExpr = do- ret <- evalTopExpr' (StateT $ \defines -> (, defines) <$> recursiveBind env defines) topExpr- case fst ret of- Nothing -> return ()- Just output -> liftIO $ putStrLn output- evalStateT (snd ret) []+ Define name expr -> collectDefs opts exprs ((name, expr) : bindings) rest+ Redefine _ _ -> collectDefs opts exprs bindings $ if optTestOnly opts then expr : rest else rest+ Test _ -> collectDefs opts exprs bindings $ if optTestOnly opts then expr : rest else rest+ Execute _ -> collectDefs opts exprs bindings $ if optTestOnly opts then rest else expr : rest+ LoadFile file ->+ if optNoIO opts+ then throwError $ Default "No IO support"+ else do exprs' <- if optUseHappy opts then ParserNonS2.loadFile file else 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 optUseHappy opts then ParserNonS2.loadLibraryFile file else 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' :: 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' :: 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+ pushFuncName "<stdin>" val <- evalStateT st [] >>= flip evalExprDeep expr return (Just (show val), st)-evalTopExpr' st (Execute expr) = do+evalTopExpr' _ st (Execute expr) = do+ pushFuncName "<stdin>" io <- evalStateT st [] >>= flip evalExpr expr case io of Value (IOFunc m) -> m >> return (Nothing, st)- _ -> throwError $ TypeMismatch "io" io-evalTopExpr' st (Load b file) = do- exprs <- if b then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file- (bindings, _) <- collectDefs exprs [] []+ _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack+evalTopExpr' opts st (Load file) = do+ exprs <- if optSExpr opts then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file+ (bindings, _) <- collectDefs opts exprs [] [] return (Nothing, withStateT (\defines -> bindings ++ defines) st)-evalTopExpr' st (LoadFile b file) = do- exprs <- if b then Parser.loadFile file else ParserNonS.loadFile file- (bindings, _) <- collectDefs exprs [] []+evalTopExpr' opts st (LoadFile file) = do+ exprs <- if optSExpr opts then Parser.loadFile file else ParserNonS.loadFile file+ (bindings, _) <- collectDefs opts exprs [] [] return (Nothing, withStateT (\defines -> bindings ++ defines) st) evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData@@ -183,13 +134,13 @@ whnf <- evalExpr env expr case whnf of Value (ScalarData s) -> return . Value $ ScalarData $ Div (Plus [Term 1 [(Quote s, 1)]]) (Plus [Term 1 []])- _ -> throwError $ TypeMismatch "scalar in quote" whnf+ _ -> throwError =<< TypeMismatch "scalar in quote" whnf <$> getFuncNameStack evalExpr env (QuoteSymbolExpr expr) = do whnf <- evalExpr env expr case whnf of Value val -> return . Value $ QuotedFunc val- _ -> throwError $ TypeMismatch "value in quote-function" whnf+ _ -> throwError =<< TypeMismatch "value in quote-function" whnf <$> getFuncNameStack evalExpr env (VarExpr name) = do x <- refVar' env name >>= evalRef@@ -257,7 +208,7 @@ sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar' if product ns == toInteger (length xs) then fromTensor (initTensor ns xs sup sub)- else throwError InconsistentTensorSize+ else throwError =<< InconsistentTensorSize <$> getFuncNameStack evalExpr env (HashExpr assocs) = do let (keyExprs, exprs) = unzip assocs@@ -286,8 +237,8 @@ ScalarData _ -> IntKey <$> fromEgison val Char c -> return (CharKey c) String str -> return (StrKey str)- _ -> throwError $ TypeMismatch "integer or string" $ Value val- makeHashKey whnf = throwError $ TypeMismatch "integer or string" whnf+ _ -> throwError =<< TypeMismatch "integer or string" (Value val) <$> getFuncNameStack+ makeHashKey whnf = throwError =<< TypeMismatch "integer or string" whnf <$> getFuncNameStack evalExpr env (IndexedExpr bool expr indices) = do tensor <- case expr of@@ -375,7 +326,7 @@ (Intermediate (ITensor (Tensor ns xs is))) -> if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor- _ -> throwError $ NotImplemented "subrefs"+ _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack where f :: Index a -> Index () f (Superscript _) = Superscript ()@@ -401,7 +352,7 @@ (Intermediate (ITensor (Tensor ns xs is))) -> if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor- _ -> throwError $ NotImplemented "suprefs"+ _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack where f :: Index a -> Index () f (Superscript _) = Superscript ()@@ -415,12 +366,12 @@ case val of (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []]))) (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args (is ++ js), 1)]]) (Plus [Term 1 []])))- _ -> throwError $ NotImplemented "user-refs"+ _ -> throwError =<< NotImplemented "user-refs" <$> getFuncNameStack evalExpr env (LambdaExpr names expr) = do names' <- mapM (\case (TensorArg name') -> return name'- (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names+ (ScalarArg _) -> throwError =<< EgisonBug "scalar-arg remained" <$> getFuncNameStack) names return . Value $ Func Nothing env names' expr evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr@@ -519,18 +470,10 @@ _ -> return whnf where isTmpSymbol :: String -> Index EgisonValue -> Bool- isTmpSymbol symId (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []]))))- | symId == id = True- | otherwise = False- isTmpSymbol symId (Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []]))))- | symId == id = True- | otherwise = False- isTmpSymbol symId (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []]))))- | symId == id = True- | otherwise = False- isTmpSymbol symId (Userscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []]))))- | symId == id = True- | otherwise = False+ isTmpSymbol symId (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id+ isTmpSymbol symId (Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id+ isTmpSymbol symId (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id+ isTmpSymbol symId (Userscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id removeTmpscripts :: String -> WHNFData -> EgisonM WHNFData removeTmpscripts symId (Intermediate (ITensor (Tensor s xs is))) = do let (ds, js) = partition (isTmpSymbol symId) is@@ -558,7 +501,7 @@ val <- m >>= evalWHNF case val of Tuple [_, val'] -> return $ Value val'- _ -> throwError $ TypeMismatch "io" io+ _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack evalExpr env (MatchAllExpr target matcher clauses) = do target <- evalExpr env target@@ -607,8 +550,25 @@ case result of MCons bindings _ -> evalExpr (extendEnv env bindings) expr MNil -> cont- foldr tryMatchClause (throwError $ Default "failed pattern match") clauses+ currentFuncName <- topFuncName+ callstack <- getFuncNameStack+ foldr tryMatchClause (throwError $ MatchFailure currentFuncName callstack) clauses +evalExpr env (MatchDFSExpr 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+ 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 (SeqExpr expr1 expr2) = do evalExprDeep env expr1 evalExpr env expr2@@ -693,7 +653,7 @@ retRef <- newEvaluatedObjectRef (Value ret) liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))- _ -> throwError $ TypeMismatch "memoized-function" (Value x'))+ _ -> throwError =<< TypeMismatch "memoized-function" (Value x') <$> getFuncNameStack) memoizeFrame evalExpr env expr @@ -788,22 +748,10 @@ yRef <- newEvaluatedObjectRef y applyFunc env fn (Intermediate (ITuple [xRef, yRef])) -evalExpr env (ParExpr expr1 expr2) = undefined-evalExpr env (PseqExpr expr1 expr2) = undefined -evalExpr env (PmapExpr fnExpr cExpr) = do- fn <- evalExpr env fnExpr- xs <- evalExpr env cExpr >>= collectionToList- ys <- parallelMapM (applyFunc' env fn) xs- return $ Value $ Collection (Sq.fromList ys)- where- applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue- applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF-- evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined-evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr)+evalExpr _ expr = throwError =<< NotImplemented ("evalExpr for " ++ show expr) <$> getFuncNameStack evalExprDeep :: Env -> EgisonExpr -> EgisonM EgisonValue evalExprDeep env expr = evalExpr env expr >>= evalWHNF@@ -864,7 +812,7 @@ applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData applyFunc env (Value (TensorData (Tensor s1 t1 i1))) tds = do tds <- fromTupleWHNF tds- if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> (length s - length i == 1)) tds+ if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> length s - length i == 1) tds then do symId <- fresh let argnum = length tds@@ -876,7 +824,7 @@ applyFunc env (Intermediate (ITensor (Tensor s1 t1 i1))) tds = do tds <- fromTupleWHNF tds- if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> (length s - length i == 1)) tds+ if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> length s - length i == 1) tds then do symId <- fresh let argnum = length tds@@ -890,15 +838,29 @@ refs <- fromTuple arg if n == fromIntegral (length refs) then evalExpr (extendEnv env $ makeBindings (map (\n -> stringToVar $ "::" ++ show n) [1..n]) refs) body- else throwError $ ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs)+ else throwError =<< ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs) <$> getFuncNameStack+applyFunc _ (Value (Func (Just (Var [funcname] _)) env [name] body)) arg = do+ pushFuncName funcname+ ref <- newEvaluatedObjectRef arg+ result <- evalExpr (extendEnv env $ makeBindings' [name] [ref]) body+ popFuncName+ return result applyFunc _ (Value (Func _ env [name] body)) arg = do ref <- newEvaluatedObjectRef arg evalExpr (extendEnv env $ makeBindings' [name] [ref]) body+applyFunc _ (Value (Func (Just (Var [funcname] _)) env names body)) arg = do+ pushFuncName funcname+ refs <- fromTuple arg+ result <- if length names == length refs+ then evalExpr (extendEnv env $ makeBindings' names refs) body+ else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack+ popFuncName+ return result applyFunc _ (Value (Func _ env names body)) arg = do refs <- fromTuple arg if length names == length refs then evalExpr (extendEnv env $ makeBindings' names refs) body- else throwError $ ArgumentsNumWithNames names (length names) (length refs)+ else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack applyFunc _ (Value (Proc _ env [name] body)) arg = do ref <- newEvaluatedObjectRef arg evalExpr (extendEnv env $ makeBindings' [name] [ref]) body@@ -906,14 +868,14 @@ refs <- fromTuple arg if length names == length refs then evalExpr (extendEnv env $ makeBindings' names refs) body- else throwError $ ArgumentsNumWithNames names (length names) (length refs)+ else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack applyFunc _ (Value (CFunc _ env name body)) arg = do refs <- fromTuple arg seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs) col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection seqRef if not (null refs) then evalExpr (extendEnv env $ makeBindings' [name] [col]) body- else throwError $ ArgumentsNumWithNames [name] 1 0+ else throwError =<< ArgumentsNumWithNames [name] 1 0 <$> getFuncNameStack applyFunc env (Value (Macro [name] body)) arg = do ref <- newEvaluatedObjectRef arg evalExpr (extendEnv env $ makeBindings' [name] [ref]) body@@ -921,12 +883,12 @@ refs <- fromTuple arg if length names == length refs then evalExpr (extendEnv env $ makeBindings' names refs) body- else throwError $ ArgumentsNumWithNames names (length names) (length refs)+ else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack applyFunc _ (Value (PrimitiveFunc _ func)) arg = func arg applyFunc _ (Value (IOFunc m)) arg = case arg of Value World -> m- _ -> throwError $ TypeMismatch "world" arg+ _ -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack applyFunc _ (Value (QuotedFunc fn)) arg = do args <- tupleToList arg mExprs <- mapM extractScalar args@@ -935,9 +897,9 @@ args <- tupleToList arg mExprs <- mapM (\arg -> case arg of ScalarData _ -> extractScalar arg- _ -> throwError $ EgisonBug "to use undefined functions, you have to use ScalarData args") args+ _ -> throwError =<< EgisonBug "to use undefined functions, you have to use ScalarData args" <$> getFuncNameStack) args return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []]))))-applyFunc _ whnf _ = throwError $ TypeMismatch "function" whnf+applyFunc _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData refArray val [] = return val@@ -953,7 +915,7 @@ elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array) elmRefs <- mapM newEvaluatedObjectRef elms return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs- _ -> throwError $ TypeMismatch "integer or symbol" (Value index)+ _ -> throwError =<< TypeMismatch "integer or symbol" (Value index) <$> getFuncNameStack refArray (Intermediate (IArray array)) (index:indices) = if isInteger index then do i <- (fmap fromInteger . fromEgison) index@@ -969,7 +931,7 @@ elms <- mapM (`refArray` indices) arrs elmRefs <- mapM newEvaluatedObjectRef elms return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs- _ -> throwError $ TypeMismatch "integer or symbol" (Value index)+ _ -> throwError =<< TypeMismatch "integer or symbol" (Value index) <$> getFuncNameStack refArray (Value (IntHash hash)) (index:indices) = do key <- fromEgison index case HL.lookup key hash of@@ -1000,7 +962,7 @@ case HL.lookup key hash of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined-refArray val _ = throwError $ TypeMismatch "array or hash" val+refArray val _ = throwError =<< TypeMismatch "array or hash" val <$> getFuncNameStack arrayBounds :: WHNFData -> EgisonM WHNFData arrayBounds val = Value <$> arrayBounds' val@@ -1008,7 +970,7 @@ arrayBounds' :: WHNFData -> EgisonM EgisonValue arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))] arrayBounds' (Value (Array arr)) = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))]-arrayBounds' val = throwError $ TypeMismatch "array" val+arrayBounds' val = throwError =<< TypeMismatch "array" val <$> getFuncNameStack newThunk :: Env -> EgisonExpr -> Object newThunk env expr = Thunk $ evalExpr env expr@@ -1059,7 +1021,7 @@ recursiveRebind :: Env -> (Var, EgisonExpr) -> EgisonM Env recursiveRebind env (name, expr) = do case refVar env name of- Nothing -> throwError $ UnboundVariable $ show name+ Nothing -> throwError =<< UnboundVariable (show name) <$> getFuncNameStack Just ref -> case expr of MemoizedLambdaExpr names body -> do hashRef <- liftIO $ newIORef HL.empty@@ -1079,7 +1041,7 @@ -- Pattern Match -- -patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) patternMatch mode env pattern target matcher = processMStates mode [msingleton $ MState env [] [] [] [MAtom pattern target matcher]] processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)@@ -1107,13 +1069,13 @@ extractMatches' (xs ++ [bindings], ys ++ [states']) rest extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest -processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]+processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState] processMStatesBFS (MCons state stream) = do newStream <- processMState state newStream' <- stream return [newStream, newStream'] -processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)]+processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState] processMStatesDFS (MCons state stream) = do stream' <- processMState state newStream <- mappend stream' stream@@ -1152,23 +1114,23 @@ in MState env loops seqs bindings (MNode penv state'':trees) processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState' (MState _ _ [] _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)"+processMState' (MState _ _ [] _ []) = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack -processMState' (MState env loops (SeqPatContext stack SeqNilPat [] []:seqs) bindings []) = return $ msingleton $ (MState env loops seqs bindings stack)+processMState' (MState env loops (SeqPatContext stack SeqNilPat [] []:seqs) bindings []) = return $ msingleton $ MState env loops seqs bindings stack processMState' (MState env loops (SeqPatContext stack seqPat mats tgts:seqs) bindings []) = do let mat' = makeTuple mats tgt' <- makeITuple tgts return $ msingleton $ MState env loops seqs bindings (MAtom seqPat tgt' mat' : stack) -processMState' (MState _ _ _ _ (MNode _ (MState _ _ _ [] []):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)"+processMState' (MState _ _ _ _ (MNode _ (MState _ _ _ [] []):_)) = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack -processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = do+processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = case lookup name penv of Just pattern -> case trees' of [] -> return $ msingleton $ MState env loops seqs bindings ((MAtom pattern target matcher):trees) _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees)- Nothing -> throwError $ UnboundVariable name+ Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' (MAtom (IndexedPat (VarPat name) indices) target matcher:trees')):trees)) = case lookup name penv of@@ -1179,7 +1141,7 @@ case trees' of [] -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:trees) _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees)- Nothing -> throwError $ UnboundVariable name+ Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack processMState' (MState env loops seqs bindings (MNode penv state:trees)) = processMState' state >>= mmap (\state' -> case state' of@@ -1189,7 +1151,7 @@ processMState' (MState env loops seqs bindings (MAtom pattern target matcher:trees)) = let env' = extendEnvForNonLinearPatterns env bindings loops in case pattern of- NotPat _ -> throwError $ EgisonBug "should not reach here (not pattern)"+ NotPat _ -> throwError =<< EgisonBug "should not reach here (not pattern)" <$> getFuncNameStack VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern LetPat bindings' pattern' ->@@ -1213,7 +1175,7 @@ Value (PatternFunc env'' names expr) -> let penv = zip names args in return $ msingleton $ MState env loops seqs bindings (MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees)- _ -> throwError $ TypeMismatch "pattern constructor" func'+ _ -> throwError =<< TypeMismatch "pattern constructor" func' <$> getFuncNameStack DApplyPat func args -> return $ msingleton $ MState env loops seqs bindings (MAtom (InductivePat "apply" [func, toListPat args]) target matcher:trees)@@ -1253,7 +1215,7 @@ then return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees)] else return $ fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees), MState env (LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)] else return $ fromList [MState env (LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]- SeqNilPat -> throwError $ EgisonBug "should not reach here (seq nil pattern)"+ SeqNilPat -> throwError =<< EgisonBug "should not reach here (seq nil pattern)" <$> getFuncNameStack SeqConsPat pattern pattern' -> return $ msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher] LaterPatVar -> case seqs of@@ -1270,8 +1232,8 @@ case matcher of UserMatcher{} -> do (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher- case (length patterns, length matchers) of- (1,1) ->+ case length patterns of+ 1 -> mfor targetss $ \ref -> do targets <- evalRef ref >>= (\x -> return [x]) let trees' = zipWith3 MAtom patterns targets matchers ++ trees@@ -1290,8 +1252,8 @@ IndexedPat _ _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees) TuplePat patterns -> do targets <- fromTupleWHNF target- when (length patterns /= length targets) $ throwError $ ArgumentsNum (length patterns) (length targets)- when (length patterns /= length matchers) $ throwError $ ArgumentsNum (length patterns) (length matchers)+ when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack+ when (length patterns /= length matchers) $ throwError =<< TupleLength (length patterns) (length matchers) <$> getFuncNameStack let trees' = zipWith3 MAtom patterns targets matchers ++ trees return $ msingleton $ MState env loops seqs bindings trees' _ -> throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern@@ -1338,11 +1300,11 @@ IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern) TuplePat patterns -> do targets <- fromTupleWHNF target- when (length patterns /= length targets) $ throwError $ ArgumentsNum (length patterns) (length targets)+ 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 $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern+ _ -> throwError =<< EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern) <$> getFuncNameStack inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher])@@ -1352,25 +1314,28 @@ tryPPMatchClause (pat, matchers, clauses) cont = do result <- runMaybeT $ primitivePatPatternMatch env pat pattern case result of+ Just ([pattern], bindings) -> do+ targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses+ matcher <- evalExpr matcherEnv matchers >>= evalMatcherWHNF+ return ([pattern], targetss, [matcher]) Just (patterns, bindings) -> do- targetss <- foldr tryPDMatchClause failPDPatternMatch clauses+ targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses matchers <- fromTupleValue <$> (evalExpr matcherEnv matchers >>= evalMatcherWHNF) return (patterns, targetss, matchers)- where- tryPDMatchClause (pat, expr) cont = do- result <- runMaybeT $ primitiveDataPatternMatch pat target- case result of- Just bindings' -> do- let env = extendEnv matcherEnv $ bindings ++ bindings'- evalExpr env expr >>= fromCollection- _ -> cont _ -> cont+ tryPDMatchClause bindings (pat, expr) cont = do+ result <- runMaybeT $ primitiveDataPatternMatch pat target+ case result of+ Just bindings' -> do+ let env = extendEnv matcherEnv $ bindings ++ bindings'+ evalExpr env expr >>= fromCollection+ _ -> cont failPPPatternMatch = throwError $ Default "failed primitive pattern pattern match" failPDPatternMatch = throwError $ Default "failed primitive data pattern match" primitivePatPatternMatch :: Env -> PrimitivePatPattern -> EgisonPattern -> MatchM ([EgisonPattern], [Binding])-primitivePatPatternMatch _ PPWildCard _ = return ([], [])+primitivePatPatternMatch _ PPWildCard WildCard = return ([], []) primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], []) primitivePatPatternMatch env (PPValuePat name) (ValuePat expr) = do ref <- lift $ newObjectRef env expr@@ -1379,6 +1344,10 @@ | name == name' && length patterns == length exprs = (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs | otherwise = matchFail+primitivePatPatternMatch env (PPTuplePat patterns) (TuplePat exprs)+ | length patterns == length exprs =+ (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs+ | otherwise = matchFail primitivePatPatternMatch _ _ _ = matchFail primitiveDataPatternMatch :: PrimitiveDataPattern -> WHNFData -> MatchM [Binding]@@ -1420,7 +1389,7 @@ (++) <$> primitiveDataPatternMatch pattern init' <*> primitiveDataPatternMatch pattern' last' primitiveDataPatternMatch (PDConstantPat expr) whnf = do- target <- (either (const matchFail) return . extractPrimitiveValue) whnf+ target <- (either (const matchFail) return) $ extractPrimitiveValue whnf isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target if isEqual then return [] else matchFail @@ -1428,7 +1397,7 @@ expandCollection (Value (Collection vals)) = mapM (fmap IElement . newEvaluatedObjectRef . Value) vals expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef-expandCollection val = throwError $ TypeMismatch "collection" val+expandCollection val = throwError =<< TypeMismatch "collection" val <$> getFuncNameStack isEmptyCollection :: WHNFData -> EgisonM Bool isEmptyCollection (Value (Collection col)) = return $ Sq.null col@@ -1494,7 +1463,7 @@ whnfs <- mapM evalRef refs ms <- mapM evalMatcherWHNF whnfs return $ Tuple ms-evalMatcherWHNF whnf = throwError $ TypeMismatch "matcher" whnf+evalMatcherWHNF whnf = throwError =<< TypeMismatch "matcher" whnf <$> getFuncNameStack -- -- Util@@ -1529,7 +1498,7 @@ (head, tail) <- fromJust <$> runMaybeT (unconsCollection whnf) tail' <- evalRef tail return $ MCons head (fromCollection tail')-fromCollection whnf = throwError $ TypeMismatch "collection" whnf+fromCollection whnf = throwError =<< TypeMismatch "collection" whnf <$> getFuncNameStack tupleToList :: WHNFData -> EgisonM [EgisonValue] tupleToList whnf = do@@ -1546,7 +1515,7 @@ where collectionToList' :: EgisonValue -> EgisonM [EgisonValue] collectionToList' (Collection sq) = return $ toList sq- collectionToList' val = throwError $ TypeMismatch "collection" (Value val)+ collectionToList' val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack makeTuple :: [EgisonValue] -> EgisonValue makeTuple [] = Tuple []@@ -1566,11 +1535,11 @@ let ls = toList seq str <- mapM (\val -> case val of Char c -> return c- _ -> throwError $ TypeMismatch "char" (Value val))+ _ -> throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack) ls return $ T.pack str packStringValue (Tuple [val]) = packStringValue val-packStringValue val = throwError $ TypeMismatch "string" (Value val)+packStringValue val = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack -- -- Util@@ -1580,12 +1549,14 @@ | CharKey Char | StrKey Text -extractPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue+extractPrimitiveValue :: WHNFData -> Either ([String] -> EgisonError) EgisonValue extractPrimitiveValue (Value val@(Char _)) = return val extractPrimitiveValue (Value val@(Bool _)) = return val extractPrimitiveValue (Value val@(ScalarData _)) = return val extractPrimitiveValue (Value val@(Float _ _)) = return val-extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf+extractPrimitiveValue whnf =+ -- we don't need to extract call stack since detailed error information is not used+ throwError $ TypeMismatch "primitive value" whnf isPrimitiveValue :: WHNFData -> Bool isPrimitiveValue (Value (Char _)) = True
hs-src/Language/Egison/Desugar.hs view
@@ -39,7 +39,7 @@ deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst) instance MonadFail DesugarM where- fail = throwError . EgisonBug+ fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack runDesugarM :: DesugarM a -> Fresh (Either EgisonError a) runDesugarM = runExceptT . flip runReaderT [] . unDesugarM@@ -306,6 +306,12 @@ clauses' <- desugarMatchClauses clauses return $ MatchExpr expr0' expr1' clauses' +desugar (MatchDFSExpr expr0 expr1 clauses) = do+ expr0' <- desugar expr0+ expr1' <- desugar expr1+ clauses' <- desugarMatchClauses clauses+ return $ MatchDFSExpr expr0' expr1' clauses'+ desugar (MatchAllExpr expr0 expr1 clauses) = do expr0' <- desugar expr0 expr1' <- desugar expr1@@ -367,21 +373,6 @@ desugar (FlipIndicesExpr expr) = do expr' <- desugar expr return $ FlipIndicesExpr expr'--desugar (ParExpr expr1 expr2) = do- expr1' <- desugar expr1- expr2' <- desugar expr2- return $ ParExpr expr1' expr2'--desugar (PseqExpr expr1 expr2) = do- expr1' <- desugar expr1- expr2' <- desugar expr2- return $ PseqExpr expr1' expr2'--desugar (PmapExpr expr1 expr2) = do- expr1' <- desugar expr1- expr2' <- desugar expr2- return $ PmapExpr expr1' expr2' desugar (ApplyExpr expr0 expr1) = do expr0' <- desugar expr0
+ hs-src/Language/Egison/Lexer.x view
@@ -0,0 +1,122 @@+{+{-# OPTIONS -w #-}+module Language.Egison.Lexer+ ( Token(..)+ , AlexPosn(..)+ , TokenClass(..)+ , Alex(..)+ , runAlex'+ , alexMonadScan'+ , alexError'+ ) where+import Prelude hiding (lex)+import Control.Monad (liftM)+}+%wrapper "monadUserState"+$digit = 0-9+$alpha = [A-Za-z]+tokens :-+ $white+ ;+ $digit+ { lex (TokenInt . read) }+ $alpha [$alpha $digit \_ \']* { lex TokenVar }+ \= { lex' TokenEq }+ \< { lex' TokenLT }+ \> { lex' TokenGT }+ \<\= { lex' TokenLE }+ \>\= { lex' TokenGE }+ \+ { lex' TokenPlus }+ \- { lex' TokenMinus }+ \* { lex' TokenAsterisk }+ \/ { lex' TokenDiv }+ \( { lex' TokenLParen }+ \) { lex' TokenRParen }+ \[ { lex' TokenLBracket }+ \] { lex' TokenRBracket }++{+-- To improve error messages, We keep the path of the file we are+-- lexing in our own state.+data AlexUserState = AlexUserState { filePath :: FilePath }+alexInitUserState :: AlexUserState+alexInitUserState = AlexUserState "<unknown>"+getFilePath :: Alex FilePath+getFilePath = liftM filePath alexGetUserState+setFilePath :: FilePath -> Alex ()+setFilePath = alexSetUserState . AlexUserState+-- The token type, consisting of the source code position and a token class.+data Token = Token AlexPosn TokenClass+ deriving ( Show )+data TokenClass+ = TokenInt Integer+ | TokenVar String+ | TokenEq+ | TokenLT+ | TokenGT+ | TokenLE+ | TokenGE+ | TokenPlus+ | TokenMinus+ | TokenAsterisk+ | TokenDiv+ | TokenLParen+ | TokenRParen+ | TokenLBracket+ | TokenRBracket+ | TokenEOF++-- For nice parser error messages.+instance Show TokenClass where+ show (TokenInt i) = show i+ show (TokenVar s) = show s+ show TokenEq = "="+ show TokenLT = "<"+ show TokenGT = ">"+ show TokenLE = "<="+ show TokenGE = ">="+ show TokenPlus = "+"+ show TokenMinus = "-"+ show TokenAsterisk = "*"+ show TokenDiv = "/"+ show TokenLParen = "("+ show TokenRParen = ")"+ show TokenLBracket = "["+ show TokenRBracket = "]"+ show TokenEOF = "<EOF>"++alexEOF :: Alex Token+alexEOF = do+ (p,_,_,_) <- alexGetInput+ return $ Token p TokenEOF+-- Unfortunately, we have to extract the matching bit of string+-- ourselves...+lex :: (String -> TokenClass) -> AlexAction Token+lex f = \(p,_,_,s) i -> return $ Token p (f (take i s))+-- For constructing tokens that do not depend on+-- the input+lex' :: TokenClass -> AlexAction Token+lex' = lex . const+-- We rewrite alexMonadScan' to delegate to alexError' when lexing fails+-- (the default implementation just returns an error message).+alexMonadScan' :: Alex Token+alexMonadScan' = do+ inp <- alexGetInput+ sc <- alexGetStartCode+ case alexScan inp sc of+ AlexEOF -> alexEOF+ AlexError (p, _, _, s) ->+ alexError' p ("lexical error at character '" ++ take 1 s ++ "'")+ AlexSkip inp' len -> do+ alexSetInput inp'+ alexMonadScan'+ AlexToken inp' len action -> do+ alexSetInput inp'+ action (ignorePendingBytes inp) len+-- Signal an error, including a commonly accepted source code position.+alexError' :: AlexPosn -> String -> Alex a+alexError' (AlexPn _ l c) msg = do+ fp <- getFilePath+ alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)+-- A variant of runAlex, keeping track of the path of the file we are lexing.+runAlex' :: Alex a -> String -> Either String a+runAlex' a input = runAlex input (setFilePath "<stdin>" >> a)+}
hs-src/Language/Egison/MathOutput.hs view
@@ -6,12 +6,21 @@ This module provides utility functions. -} -module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex, mathExprToMathematica, mathExprToMaxima) where+module Language.Egison.MathOutput ( changeOutputInLang ) where import Control.Monad import System.Environment import Text.ParserCombinators.Parsec hiding (spaces) ++changeOutputInLang :: String -> String -> String+changeOutputInLang "haskell" input = mathExprToHaskell input+changeOutputInLang "asciimath" input = mathExprToAsciiMath input+changeOutputInLang "latex" input = mathExprToLatex input+changeOutputInLang "mathematica" input = mathExprToMathematica input+changeOutputInLang "maxima" input = mathExprToMaxima input+changeOutputInLang _ input = input+ mathExprToHaskell :: String -> String mathExprToHaskell input = case parse parseExpr "math-expr" input of Left err -> input@@ -197,7 +206,7 @@ showMathExprMathematica :: MathExpr -> String showMathExprMathematica (Atom a []) = a-showMathExprMathematica (Partial f xs) = showMathExprMathematica f ++ "_" ++ (showMathExprsMathematica "_" xs)+showMathExprMathematica (Partial f xs) = showMathExprMathematica f ++ "_" ++ showMathExprsMathematica "_" xs showMathExprMathematica (NegativeAtom a) = "-" ++ a showMathExprMathematica (Plus []) = "" showMathExprMathematica (Plus (x:xs)) = showMathExprMathematica x ++ showMathExprMathematicaForPlus xs
hs-src/Language/Egison/Parser.hs view
@@ -107,9 +107,9 @@ exprs <- readTopExprs $ shebang input concat <$> mapM recursiveLoad exprs where- recursiveLoad (Load _ file) = loadLibraryFile file- recursiveLoad (LoadFile _ file) = loadFile file- recursiveLoad expr = return [expr]+ recursiveLoad (Load file) = loadLibraryFile file+ recursiveLoad (LoadFile file) = loadFile file+ recursiveLoad expr = return [expr] shebang :: String -> String shebang ('#':'!':cs) = ';':'#':'!':cs shebang cs = cs@@ -164,10 +164,10 @@ executeExpr = keywordExecute >> Execute <$> expr loadFileExpr :: Parser EgisonTopExpr-loadFileExpr = keywordLoadFile >> LoadFile True <$> stringLiteral+loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral loadExpr :: Parser EgisonTopExpr-loadExpr = keywordLoad >> Load True <$> stringLiteral+loadExpr = keywordLoad >> Load <$> stringLiteral exprs :: Parser [EgisonExpr] exprs = endBy expr whiteSpace@@ -229,6 +229,7 @@ <|> matchAllExpr <|> matchAllDFSExpr <|> matchExpr+ <|> matchDFSExpr <|> matchAllLambdaExpr <|> matchLambdaExpr <|> matcherExpr@@ -246,9 +247,6 @@ <|> tensorMapExpr <|> tensorMap2Expr <|> transposeExpr- <|> parExpr- <|> pseqExpr- <|> pmapExpr <|> subrefsExpr <|> suprefsExpr <|> userrefsExpr@@ -322,6 +320,9 @@ matchExpr :: Parser EgisonExpr matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses +matchDFSExpr :: Parser EgisonExpr+matchDFSExpr = keywordMatchDFS >> MatchDFSExpr <$> expr <*> expr <*> matchClauses+ matchAllLambdaExpr :: Parser EgisonExpr matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses) @@ -354,6 +355,7 @@ <|> ppPatVar <|> ppValuePat <|> ppInductivePat+ <|> ppTuplePat <?> "primitive-pattren-pattern") ppWildCard :: Parser PrimitivePatPattern@@ -368,6 +370,9 @@ ppInductivePat :: Parser PrimitivePatPattern ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace) +ppTuplePat :: Parser PrimitivePatPattern+ppTuplePat = brackets $ PPTuplePat <$> sepEndBy ppPattern whiteSpace+ pdPattern :: Parser PrimitiveDataPattern pdPattern = P.lexeme lexer pdPattern' @@ -550,15 +555,6 @@ transposeExpr :: Parser EgisonExpr transposeExpr = keywordTranspose >> TransposeExpr <$> expr <*> expr -parExpr :: Parser EgisonExpr-parExpr = keywordPar >> ParExpr <$> expr <*> expr--pseqExpr :: Parser EgisonExpr-pseqExpr = keywordPseq >> PseqExpr <$> expr <*> expr--pmapExpr :: Parser EgisonExpr-pmapExpr = keywordPmap >> PmapExpr <$> expr <*> expr- subrefsExpr :: Parser EgisonExpr subrefsExpr = (keywordSubrefs >> SubrefsExpr False <$> expr <*> expr) <|> (keywordSubrefsNew >> SubrefsExpr True <$> expr <*> expr)@@ -798,6 +794,8 @@ , "loop" , "match-all" , "match"+ , "match-all-dfs"+ , "match-dfs" , "match-all-lambda" , "match-lambda" , "matcher"@@ -813,9 +811,6 @@ , "tensor-map" , "tensor-map2" , "transpose"- , "par"- , "pseq"- , "pmap" , "subrefs" , "subrefs!" , "suprefs"@@ -882,6 +877,7 @@ keywordMatchAllDFS = reserved "match-all-dfs" keywordMatchAllLambda = reserved "match-all-lambda" keywordMatch = reserved "match"+keywordMatchDFS = reserved "match-dfs" keywordMatchLambda = reserved "match-lambda" keywordMatcher = reserved "matcher" keywordDo = reserved "do"@@ -898,9 +894,6 @@ keywordTensorMap = reserved "tensor-map" keywordTensorMap2 = reserved "tensor-map2" keywordTranspose = reserved "transpose"-keywordPar = reserved "par"-keywordPseq = reserved "pseq"-keywordPmap = reserved "pmap" keywordSubrefs = reserved "subrefs" keywordSubrefsNew = reserved "subrefs!" keywordSuprefs = reserved "suprefs"
hs-src/Language/Egison/ParserNonS.hs view
@@ -109,9 +109,9 @@ exprs <- readTopExprs $ shebang input concat <$> mapM recursiveLoad exprs where- recursiveLoad (Load _ file) = loadLibraryFile file- recursiveLoad (LoadFile _ file) = loadFile file- recursiveLoad expr = return [expr]+ recursiveLoad (Load file) = loadLibraryFile file+ recursiveLoad (LoadFile file) = loadFile file+ recursiveLoad expr = return [expr] shebang :: String -> String shebang ('#':'!':cs) = ';':'#':'!':cs shebang cs = cs@@ -166,10 +166,10 @@ testExpr = keywordTest >> Test <$> parens expr loadFileExpr :: Parser EgisonTopExpr-loadFileExpr = keywordLoadFile >> LoadFile False <$> parens stringLiteral+loadFileExpr = keywordLoadFile >> LoadFile <$> parens stringLiteral loadExpr :: Parser EgisonTopExpr-loadExpr = keywordLoad >> Load False <$> parens stringLiteral+loadExpr = keywordLoad >> Load <$> parens stringLiteral exprs :: Parser [EgisonExpr] exprs = endBy expr whiteSpace
+ hs-src/Language/Egison/ParserNonS2.y view
@@ -0,0 +1,96 @@+{+{-# OPTIONS -w #-}+module Language.Egison.ParserNonS2+ (+ -- * Parse a string+ readTopExprs+ , readTopExpr+ , readExprs+ , readExpr+ , parseTopExprs+ , parseTopExpr+ , parseExprs+ , parseExpr+ -- * Parse a file+ , loadFile+ , loadLibraryFile+ ) where++import Language.Egison.Lexer+import Language.Egison.Types++}++%name parse+%tokentype { Token }+%monad { Alex }+%lexer { lexwrap } { Token _ TokenEOF }+-- Without this we get a type error+%error { happyError }++%right let in+%left '<' '>' '=' "<=" ">="+%left '+' '-'+%left '*' '/'++%token+ int { Token _ (TokenInt $$) }+ var { Token _ (TokenVar $$) }+ '=' { Token _ TokenEq }+ '<' { Token _ TokenLT }+ '>' { Token _ TokenGT }+ "<=" { Token _ TokenLE }+ ">=" { Token _ TokenGE }+ '+' { Token _ TokenPlus }+ '-' { Token _ TokenMinus }+ '*' { Token _ TokenAsterisk }+ '/' { Token _ TokenDiv }+ '(' { Token _ TokenLParen }+ ')' { Token _ TokenRParen }+ '[' { Token _ TokenLBracket }+ ']' { Token _ TokenRBracket }++%%++EgisonExpr :+ int { IntegerExpr $1 }++{+lexwrap :: (Token -> Alex a) -> Alex a+lexwrap = (alexMonadScan' >>=)++happyError :: Token -> Alex a+happyError (Token p t) =+ alexError' p ("parse error at token '" ++ show t ++ "'")++readTopExprs :: String -> EgisonM [EgisonTopExpr]+readTopExprs = undefined++readTopExpr :: String -> EgisonM EgisonTopExpr+readTopExpr = undefined++readExprs :: String -> EgisonM [EgisonExpr]+readExprs = undefined++readExpr :: String -> EgisonM EgisonExpr+readExpr = undefined++parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = undefined++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = undefined++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = undefined++parseExpr :: String -> Either EgisonError EgisonExpr+parseExpr = undefined+-- parseExpr = runAlex' parse++loadFile :: FilePath -> EgisonM [EgisonTopExpr]+loadFile = undefined++loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]+loadLibraryFile = undefined+}
hs-src/Language/Egison/Primitives.hs view
@@ -63,7 +63,7 @@ args' <- tupleToList args case args' of [] -> Value <$> f- _ -> throwError $ ArgumentsNumPrimitive 0 $ length args'+ _ -> throwError =<< ArgumentsNumPrimitive 0 (length args') <$> getFuncNameStack {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc@@ -94,7 +94,7 @@ ds' <- V.mapM (f val) ds Value <$> fromTensor (Tensor ns ds' js) [val, val'] -> Value <$> f val val'- _ -> throwError $ ArgumentsNumPrimitive 2 $ length args'+ _ -> throwError =<< ArgumentsNumPrimitive 2 (length args') <$> getFuncNameStack {-# INLINE twoArgs' #-} twoArgs' :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc@@ -102,7 +102,7 @@ args' <- tupleToList args case args' of [val, val'] -> Value <$> f val val'- _ -> throwError $ ArgumentsNumPrimitive 2 $ length args'+ _ -> throwError =<< ArgumentsNumPrimitive 2 (length args') <$> getFuncNameStack {-# INLINE threeArgs' #-} threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc@@ -110,7 +110,7 @@ args' <- tupleToList args case args' of [val, val', val''] -> Value <$> f val val' val''- _ -> throwError $ ArgumentsNumPrimitive 3 $ length args'+ _ -> throwError =<< ArgumentsNumPrimitive 3 (length args') <$> getFuncNameStack -- -- Constants@@ -265,12 +265,12 @@ floatUnaryOp :: (Double -> Double) -> PrimitiveFunc floatUnaryOp op = oneArg $ \val -> case val of (Float f 0) -> return $ Float (op f) 0- _ -> throwError $ TypeMismatch "float" (Value val)+ _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc floatBinaryOp op = twoArgs $ \val val' -> case (val, val') of (Float f 0, Float f' 0) -> return $ Float (op f f') 0- _ -> throwError $ TypeMismatch "float" (Value val)+ _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc floatBinaryPred pred = twoArgs $ \val val' -> do@@ -281,22 +281,22 @@ floatPlus :: PrimitiveFunc floatPlus = twoArgs $ \val val' -> case (val, val') of (Float x y, Float x' y') -> return $ Float (x + x') (y + y')- _ -> throwError $ TypeMismatch "float" (Value val)+ _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatMinus :: PrimitiveFunc floatMinus = twoArgs $ \val val' -> case (val, val') of (Float x y, Float x' y') -> return $ Float (x - x') (y - y')- _ -> throwError $ TypeMismatch "float" (Value val)+ _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatMult :: PrimitiveFunc floatMult = twoArgs $ \val val' -> case (val, val') of (Float x y, Float x' y') -> return $ Float (x * x' - y * y') (x * y' + x' * y)- _ -> throwError $ TypeMismatch "float" (Value val)+ _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack floatDivide :: PrimitiveFunc floatDivide = twoArgs $ \val val' -> case (val, val') of (Float x y, Float x' y') -> return $ Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y'))- _ -> throwError $ TypeMismatch "float" (Value val)+ _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack --@@ -307,8 +307,8 @@ scalarBinaryOp mOp = twoArgs $ \val val' -> scalarBinaryOp' val val' where scalarBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData . mathNormalize') (mOp m1 m2)- scalarBinaryOp' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val)- scalarBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)+ scalarBinaryOp' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+ scalarBinaryOp' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack plus :: PrimitiveFunc plus = scalarBinaryOp mathPlus@@ -326,19 +326,19 @@ numerator' = oneArg numerator'' where numerator'' (ScalarData m) = return $ ScalarData (mathNumerator m)- numerator'' val = throwError $ TypeMismatch "rational" (Value val)+ numerator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack denominator' :: PrimitiveFunc denominator' = oneArg denominator'' where denominator'' (ScalarData m) = return $ ScalarData (mathDenominator m)- denominator'' val = throwError $ TypeMismatch "rational" (Value val)+ denominator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack fromScalarData :: PrimitiveFunc fromScalarData = oneArg fromScalarData' where fromScalarData' (ScalarData m) = return $ mathExprToEgison m- fromScalarData' val = throwError $ TypeMismatch "number" (Value val)+ fromScalarData' val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack toScalarData :: PrimitiveFunc toScalarData = oneArg toScalarData'@@ -360,9 +360,9 @@ r' <- fromEgison n :: EgisonM Rational return $ Bool $ (<) r r' scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<) f f'- scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val)- scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)+ scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+ scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+ scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack lte :: PrimitiveFunc lte = twoArgs' $ \val val' -> scalarBinaryPred' val val'@@ -372,9 +372,9 @@ r' <- fromEgison n :: EgisonM Rational return $ Bool $ (<=) r r' scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<=) f f'- scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val)- scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)+ scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+ scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+ scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack gt :: PrimitiveFunc gt = twoArgs' $ \val val' -> scalarBinaryPred' val val'@@ -384,9 +384,9 @@ r' <- fromEgison n :: EgisonM Rational return $ Bool $ (>) r r' scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>) f f'- scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val)- scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)+ scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+ scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+ scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack gte :: PrimitiveFunc gte = twoArgs' $ \val val' -> scalarBinaryPred' val val'@@ -396,9 +396,9 @@ r' <- fromEgison n :: EgisonM Rational return $ Bool $ (>=) r r' scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>=) f f'- scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val)- scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)+ scalarBinaryPred' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+ scalarBinaryPred' (Float _ _) val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+ scalarBinaryPred' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val@@ -406,19 +406,19 @@ numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer) numberUnaryOp' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return $ toEgison (quot x y) numberUnaryOp' (Float x _) = return $ toEgison (truncate x :: Integer)- numberUnaryOp' val = throwError $ TypeMismatch "rational or float" (Value val)+ numberUnaryOp' val = throwError =<< TypeMismatch "rational or float" (Value val) <$> getFuncNameStack realPart :: PrimitiveFunc realPart = oneArg realPart' where realPart' (Float x y) = return $ Float x 0- realPart' val = throwError $ TypeMismatch "float" (Value val)+ realPart' val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack imaginaryPart :: PrimitiveFunc imaginaryPart = oneArg imaginaryPart' where imaginaryPart' (Float _ y) = return $ Float y 0- imaginaryPart' val = throwError $ TypeMismatch "float" (Value val)+ imaginaryPart' val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack -- -- Tensor@@ -457,21 +457,21 @@ case val of (ScalarData (Div (Plus []) _)) -> return $ numberToFloat' val (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []]))) -> return $ numberToFloat' val- _ -> throwError $ TypeMismatch "integer or rational number" (Value val)+ _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack charToInteger :: PrimitiveFunc charToInteger = oneArg $ \val -> case val of Char c -> do let i = fromIntegral $ ord c :: Integer return $ toEgison i- _ -> throwError $ TypeMismatch "character" (Value val)+ _ -> throwError =<< TypeMismatch "character" (Value val) <$> getFuncNameStack integerToChar :: PrimitiveFunc integerToChar = oneArg $ \val -> case val of (ScalarData _) -> do i <- fromEgison val :: EgisonM Integer return $ Char $ chr $ fromIntegral i- _ -> throwError $ TypeMismatch "integer" (Value val)+ _ -> throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc floatToIntegerOp op = oneArg $ \val -> do@@ -489,31 +489,31 @@ unpack :: PrimitiveFunc unpack = oneArg $ \val -> case val of String str -> return $ toEgison (T.unpack str)- _ -> throwError $ TypeMismatch "string" (Value val)+ _ -> throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack unconsString :: PrimitiveFunc unconsString = oneArg $ \val -> case val of String str -> case T.uncons str of Just (c, rest) -> return $ Tuple [Char c, String rest] Nothing -> throwError $ Default "Tried to unsnoc empty string"- _ -> throwError $ TypeMismatch "string" (Value val)+ _ -> throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack lengthString :: PrimitiveFunc lengthString = oneArg $ \val -> case val of String str -> return . toEgison . toInteger $ T.length str- _ -> throwError $ TypeMismatch "string" (Value val)+ _ -> throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack appendString :: PrimitiveFunc appendString = twoArgs $ \val1 val2 -> case (val1, val2) of (String str1, String str2) -> return . String $ T.append str1 str2- (String _, _) -> throwError $ TypeMismatch "string" (Value val2)- (_, _) -> throwError $ TypeMismatch "string" (Value val1)+ (String _, _) -> throwError =<< TypeMismatch "string" (Value val2) <$> getFuncNameStack+ (_, _) -> throwError =<< TypeMismatch "string" (Value val1) <$> getFuncNameStack splitString :: PrimitiveFunc splitString = twoArgs $ \pat src -> case (pat, src) of (String patStr, String srcStr) -> return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr- (String _, _) -> throwError $ TypeMismatch "string" (Value src)- (_, _) -> throwError $ TypeMismatch "string" (Value pat)+ (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack+ (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack regexString :: PrimitiveFunc regexString = twoArgs $ \pat src -> case (pat, src) of@@ -522,8 +522,8 @@ if b == "" then return . Collection . Sq.fromList $ [] else return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]]- (String _, _) -> throwError $ TypeMismatch "string" (Value src)- (_, _) -> throwError $ TypeMismatch "string" (Value pat)+ (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack+ (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack regexStringCaptureGroup :: PrimitiveFunc regexStringCaptureGroup = twoArgs $ \pat src -> case (pat, src) of@@ -533,20 +533,20 @@ [] -> return . Collection . Sq.fromList $ [] ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]]- (String _, _) -> throwError $ TypeMismatch "string" (Value src)- (_, _) -> throwError $ TypeMismatch "string" (Value pat)+ (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack+ (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack --regexStringMatch :: PrimitiveFunc --regexStringMatch = twoArgs $ \pat src -> do -- case (pat, src) of -- (String patStr, String srcStr) -> return . Bool $ (((T.unpack srcStr) =~ (T.unpack patStr)) :: Bool)--- (String _, _) -> throwError $ TypeMismatch "string" (Value src)--- (_, _) -> throwError $ TypeMismatch "string" (Value pat)+-- (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack+-- (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack addPrime :: PrimitiveFunc addPrime = oneArg $ \sym -> case sym of ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id (name ++ "'") is, 1)]]) (Plus [Term 1 []])))- _ -> throwError $ TypeMismatch "symbol" (Value sym)+ _ -> throwError =<< TypeMismatch "symbol" (Value sym) <$> getFuncNameStack addSubscript :: PrimitiveFunc addSubscript = twoArgs $ \fn sub -> case (fn, sub) of@@ -555,8 +555,8 @@ (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []]))) (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),- _) -> throwError $ TypeMismatch "symbol or integer" (Value sub)- _ -> throwError $ TypeMismatch "symbol or integer" (Value fn)+ _) -> throwError =<< TypeMismatch "symbol or integer" (Value sub) <$> getFuncNameStack+ _ -> throwError =<< TypeMismatch "symbol or integer" (Value fn) <$> getFuncNameStack addSuperscript :: PrimitiveFunc addSuperscript = twoArgs $ \fn sub -> case (fn, sub) of@@ -565,8 +565,8 @@ (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []]))) (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),- _) -> throwError $ TypeMismatch "symbol" (Value sub)- _ -> throwError $ TypeMismatch "symbol" (Value fn)+ _) -> throwError =<< TypeMismatch "symbol" (Value sub) <$> getFuncNameStack+ _ -> throwError =<< TypeMismatch "symbol" (Value fn) <$> getFuncNameStack readProcess' :: PrimitiveFunc readProcess' = threeArgs' $ \cmd args input -> case (cmd, args, input) of@@ -575,7 +575,7 @@ String argStr -> T.unpack argStr) (toList argStrs)) (T.unpack inputStr) return (String (T.pack outputStr))- (_, _, _) -> throwError $ TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input]))+ (_, _, _) -> throwError =<< TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) <$> getFuncNameStack read' :: PrimitiveFunc read'= oneArg' $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv@@ -623,13 +623,13 @@ test <- fromEgison test if test then return $ Bool True- else throwError $ Assertion $ show label+ else throwError =<< Assertion (show label) <$> getFuncNameStack assertEqual :: PrimitiveFunc assertEqual = threeArgs' $ \label actual expected -> if actual == expected then return $ Bool True- else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++- "\n but found: " ++ show actual+ else throwError =<< Assertion+ (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual) <$> getFuncNameStack -- -- IO Primitives
hs-src/Language/Egison/Types.hs view
@@ -4,8 +4,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}@@ -114,7 +112,6 @@ , liftError -- * Monads , EgisonM (..)- , parallelMapM , runEgisonM , liftEgisonM , fromEgisonM@@ -158,13 +155,13 @@ , readUTF8File , stringToVar , varToVarWithIndices+ , EgisonOpts (..)+ , defaultOption ) where import Prelude hiding (foldr, mappend, mconcat) import Control.Exception-import Control.Lens (makeLenses)-import Control.Parallel import Data.Typeable import Control.Applicative@@ -215,8 +212,8 @@ | Test EgisonExpr | Execute EgisonExpr -- temporary : we will replace load to import and export- | LoadFile Bool String- | Load Bool String+ | LoadFile String+ | Load String deriving (Show, Eq) data EgisonExpr =@@ -255,6 +252,7 @@ | WithSymbolsExpr [String] EgisonExpr | MatchExpr EgisonExpr EgisonExpr [MatchClause]+ | MatchDFSExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllDFSExpr EgisonExpr EgisonExpr [MatchClause] | MatchLambdaExpr EgisonExpr [MatchClause]@@ -283,10 +281,6 @@ | ArrayBoundsExpr EgisonExpr | ArrayRefExpr EgisonExpr EgisonExpr - | ParExpr EgisonExpr EgisonExpr- | PseqExpr EgisonExpr EgisonExpr- | PmapExpr EgisonExpr EgisonExpr- | GenerateTensorExpr EgisonExpr EgisonExpr | TensorExpr EgisonExpr EgisonExpr EgisonExpr EgisonExpr | TensorContractExpr EgisonExpr EgisonExpr@@ -355,16 +349,17 @@ | PlusPat [EgisonPattern] | MultPat [EgisonPattern] | PowerPat EgisonPattern EgisonPattern- deriving (Show, Eq)+ deriving Eq data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern- deriving (Show, Eq)+ deriving Eq data PrimitivePatPattern = PPWildCard | PPPatVar | PPValuePat String | PPInductivePat String [PrimitivePatPattern]+ | PPTuplePat [PrimitivePatPattern] deriving (Show, Eq) data PrimitiveDataPattern =@@ -560,15 +555,15 @@ egisonToScalarData s1@(InductiveData "Function" _) = do s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)]) return $ Div (Plus [Term 1 [s1']]) (Plus [Term 1 []])-egisonToScalarData val = liftError $ throwError $ TypeMismatch "math expression" (Value val)+egisonToScalarData val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack egisonToPolyExpr :: EgisonValue -> EgisonM PolyExpr egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts)-egisonToPolyExpr val = liftError $ throwError $ TypeMismatch "math poly expression" (Value val)+egisonToPolyExpr val = throwError =<< TypeMismatch "math poly expression" (Value val) <$> getFuncNameStack egisonToTermExpr :: EgisonValue -> EgisonM TermExpr egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts)-egisonToTermExpr val = liftError $ throwError $ TypeMismatch "math term expression" (Value val)+egisonToTermExpr val = throwError =<< TypeMismatch "math term expression" (Value val) <$> getFuncNameStack egisonToSymbolExpr :: EgisonValue -> EgisonM (SymbolExpr, Integer) egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do@@ -577,7 +572,7 @@ InductiveData "Sup" [ScalarData k] -> return (Superscript k) InductiveData "Sub" [ScalarData k] -> return (Subscript k) InductiveData "User" [ScalarData k] -> return (Userscript k)- _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j)+ _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack ) js n' <- fromEgison n case x of@@ -597,14 +592,14 @@ InductiveData "Sup" [ScalarData k] -> return (Superscript k) InductiveData "Sub" [ScalarData k] -> return (Subscript k) InductiveData "User" [ScalarData k] -> return (Userscript k)- _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j)+ _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack ) js n' <- fromEgison n let name' = case getSymName name of "" -> Nothing s -> Just name return (FunctionData name' (toList argnames) (toList args) js', n')-egisonToSymbolExpr val = liftError $ throwError $ TypeMismatch "math symbol expression" (Value val)+egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack mathNormalize' :: ScalarData -> ScalarData mathNormalize' mExpr = mathDivide (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr)))@@ -650,7 +645,7 @@ f :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Integer, [(SymbolExpr, Integer)]) f sgn xs [] = (sgn, xs) f sgn xs ((y, n):ys) =- let (sgns, zs) = unzip (map (\(x, m) -> (g (x, m) (y, n))) xs) in+ let (sgns, zs) = unzip (map (\(x, m) -> g (x, m) (y, n)) xs) in f (sgn * product sgns) zs ys g :: (SymbolExpr, Integer) -> (SymbolExpr, Integer) -> (Integer, (SymbolExpr, Integer)) g (Quote x, n) (Quote y, m)@@ -714,7 +709,7 @@ f' :: [TermExpr] -> [TermExpr] -> [TermExpr] f' ret [] = ret f' ret (Term a xs:ts) =- if any (\(Term _ ys) -> (fst (p 1 xs ys))) ret+ if any (\(Term _ ys) -> fst (p 1 xs ys)) ret then f' (map (g (Term a xs)) ret) ts else f' (ret ++ [Term a xs]) ts g :: TermExpr -> TermExpr -> TermExpr@@ -760,13 +755,13 @@ mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr mathMultPoly (Plus []) (Plus _) = Plus [] mathMultPoly (Plus _) (Plus []) = Plus []-mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> (Plus (map (\(Term b ys) -> (Term (a * b) (xs ++ ys))) ts2))) ts1)+mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1) mathNegate :: ScalarData -> ScalarData mathNegate (Div m n) = Div (mathNegate' m) n mathNegate' :: PolyExpr -> PolyExpr-mathNegate' (Plus ts) = Plus (map (\(Term a xs) -> (Term (negate a) xs)) ts)+mathNegate' (Plus ts) = Plus (map (\(Term a xs) -> Term (negate a) xs) ts) mathNumerator :: ScalarData -> ScalarData mathNumerator (Div m _) = Div m (Plus [Term 1 []])@@ -780,11 +775,11 @@ extractScalar :: EgisonValue -> EgisonM ScalarData extractScalar (ScalarData mExpr) = return mExpr-extractScalar val = throwError $ TypeMismatch "math expression" (Value val)+extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack extractScalar' :: WHNFData -> EgisonM ScalarData extractScalar' (Value (ScalarData x)) = return x-extractScalar' val = throwError $ TypeMismatch "integer or string" val+extractScalar' val = throwError =<< TypeMismatch "integer or string" val <$> getFuncNameStack -- -- Tensors@@ -813,26 +808,26 @@ tIntRef' i (Tensor [n] xs _) = if (0 < i) && (i <= n) then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1)- else throwError $ TensorIndexOutOfBounds i n+ else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack tIntRef' i (Tensor (n:ns) xs js) = if (0 < i) && (i <= n) then let w = fromIntegral (product ns) in let ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in fromTensor $ Tensor ns ys (cdr js)- else throwError $ TensorIndexOutOfBounds i n+ else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack tIntRef' i _ = throwError $ Default "More indices than the order of the tensor" tIntRef :: HasTensor a => [Integer] -> Tensor a -> EgisonM (Tensor a) tIntRef [] (Tensor [] xs _) | V.length xs == 1 = return $ Scalar (xs V.! 0)- | otherwise = throwError $ EgisonBug "sevaral elements in scalar tensor"+ | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack tIntRef [] t = return t tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM a tref [] (Tensor [] xs _) | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0)- | otherwise = throwError $ EgisonBug "sevaral elements in scalar tensor"+ | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack tref [] t = fromTensor t tref (Subscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms tref (Subscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms@@ -878,7 +873,7 @@ enumTensorIndices :: [Integer] -> [[Integer]] enumTensorIndices [] = [[]]-enumTensorIndices (n:ns) = concatMap (\i -> (map (\is -> i:is) (enumTensorIndices ns))) [1..n]+enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n] changeIndexList :: [Index String] -> [EgisonValue] -> [Index String] changeIndexList idxlist ms = map (\(i, m) -> case i of@@ -890,11 +885,11 @@ transIndex (j1:js1) js2 is = do let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2 if null tjs2- then throwError InconsistentTensorIndex+ then throwError =<< InconsistentTensorIndex <$> getFuncNameStack else do let n = length hjs2 + 1 rs <- transIndex js1 (hjs2 ++ tail tjs2) (take (n - 1) is ++ drop n is) return (nth (fromIntegral n) is:rs)-transIndex _ _ _ = throwError InconsistentTensorSize+transIndex _ _ _ = throwError =<< InconsistentTensorSize <$> getFuncNameStack tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a) tTranspose is t@(Tensor ns xs js) = do@@ -914,7 +909,7 @@ g :: [EgisonValue] -> [Index EgisonValue] -> EgisonM [Index EgisonValue] g [] js = return [] g (i:is) js = case find (\j -> i == f j) js of- Nothing -> throwError InconsistentTensorIndex+ Nothing -> throwError =<< InconsistentTensorIndex <$> getFuncNameStack (Just j') -> do js' <- g is js return $ j':js' @@ -1045,7 +1040,7 @@ (Tensor ns2 xs2 _) | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2) return (Tensor ns1 ys js1)- | otherwise -> throwError InconsistentTensorSize+ | otherwise -> throwError =<< InconsistentTensorSize <$> getFuncNameStack tProduct :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a) tProduct f t1''@(Tensor ns1 xs1 js1') t2''@(Tensor ns2 xs2 js2') = do@@ -1333,6 +1328,45 @@ (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 --@@ -1342,47 +1376,56 @@ instance EgisonData Char where toEgison = Char- fromEgison = liftError . fromCharValue+ fromEgison (Char c) = return c+ fromEgison val = throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack instance EgisonData Text where toEgison = String- fromEgison = liftError . fromStringValue+ fromEgison (String str) = return str+ fromEgison val = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack instance EgisonData Bool where toEgison = Bool- fromEgison = liftError . fromBoolValue+ fromEgison (Bool b) = return b+ fromEgison val = throwError =<< TypeMismatch "bool" (Value val) <$> getFuncNameStack instance EgisonData Integer where toEgison 0 = ScalarData $ mathNormalize' (Div (Plus []) (Plus [Term 1 []])) toEgison i = ScalarData $ mathNormalize' (Div (Plus [Term i []]) (Plus [Term 1 []]))- fromEgison = liftError . fromIntegerValue+ fromEgison (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0+ fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term 1 []]))) = return x+ fromEgison val = throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack instance EgisonData Rational where toEgison r = ScalarData $ mathNormalize' (Div (Plus [Term (numerator r) []]) (Plus [Term (denominator r) []]))- fromEgison = liftError . fromRationalValue+ fromEgison (ScalarData (Div (Plus []) _)) = return 0+ fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return (x % y)+ fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack instance EgisonData Double where toEgison f = Float f 0- fromEgison = liftError . fromFloatValue+ fromEgison (Float f 0) = return f+ fromEgison val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack instance EgisonData Handle where toEgison = Port- fromEgison = liftError . fromPortValue+ fromEgison (Port h) = return h+ fromEgison val = throwError =<< TypeMismatch "port" (Value val) <$> getFuncNameStack instance (EgisonData a) => EgisonData [a] where toEgison xs = Collection $ Sq.fromList (map toEgison xs) fromEgison (Collection seq) = mapM fromEgison (toList seq)- fromEgison val = liftError $ throwError $ TypeMismatch "collection" (Value val)+ fromEgison val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack instance EgisonData () where toEgison () = Tuple [] fromEgison (Tuple []) = return ()- fromEgison val = liftError $ throwError $ TypeMismatch "zero element tuple" (Value val)+ fromEgison val = throwError =<< TypeMismatch "zero element tuple" (Value val) <$> getFuncNameStack instance (EgisonData a, EgisonData b) => EgisonData (a, b) where toEgison (x, y) = Tuple [toEgison x, toEgison y] fromEgison (Tuple [x, y]) = liftM2 (,) (fromEgison x) (fromEgison y)- fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val)+ fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack instance (EgisonData a, EgisonData b, EgisonData c) => EgisonData (a, b, c) where toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z]@@ -1391,7 +1434,7 @@ y' <- fromEgison y z' <- fromEgison z return (x', y', z')- fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val)+ fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack instance (EgisonData a, EgisonData b, EgisonData c, EgisonData d) => EgisonData (a, b, c, d) where toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w]@@ -1401,37 +1444,7 @@ z' <- fromEgison z w' <- fromEgison w return (x', y', z', w')- fromEgison val = liftError $ throwError $ TypeMismatch "two elements tuple" (Value val)--fromCharValue :: EgisonValue -> Either EgisonError Char-fromCharValue (Char c) = return c-fromCharValue val = throwError $ TypeMismatch "char" (Value val)--fromStringValue :: EgisonValue -> Either EgisonError Text-fromStringValue (String str) = return str-fromStringValue val = throwError $ TypeMismatch "string" (Value val)--fromBoolValue :: EgisonValue -> Either EgisonError Bool-fromBoolValue (Bool b) = return b-fromBoolValue val = throwError $ TypeMismatch "bool" (Value val)--fromIntegerValue :: EgisonValue -> Either EgisonError Integer-fromIntegerValue (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0-fromIntegerValue (ScalarData (Div (Plus [Term x []]) (Plus [Term 1 []]))) = return x-fromIntegerValue val = throwError $ TypeMismatch "integer" (Value val)--fromRationalValue :: EgisonValue -> Either EgisonError Rational-fromRationalValue (ScalarData (Div (Plus []) _)) = return 0-fromRationalValue (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return (x % y)-fromRationalValue val = throwError $ TypeMismatch "rational" (Value val)--fromFloatValue :: EgisonValue -> Either EgisonError Double-fromFloatValue (Float f 0) = return f-fromFloatValue val = throwError $ TypeMismatch "float" (Value val)--fromPortValue :: EgisonValue -> Either EgisonError Handle-fromPortValue (Port h) = return h-fromPortValue val = throwError $ TypeMismatch "port" (Value val)+ fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack -- -- Internal Data@@ -1490,47 +1503,29 @@ toWHNF = Value . toEgison instance EgisonWHNF Char where- fromWHNF = liftError . fromCharWHNF+ fromWHNF (Value (Char c)) = return c+ fromWHNF whnf = throwError =<< TypeMismatch "char" whnf <$> getFuncNameStack instance EgisonWHNF Text where- fromWHNF = liftError . fromStringWHNF+ fromWHNF (Value (String str)) = return str+ fromWHNF whnf = throwError =<< TypeMismatch "string" whnf <$> getFuncNameStack instance EgisonWHNF Bool where- fromWHNF = liftError . fromBoolWHNF+ fromWHNF (Value (Bool b)) = return b+ fromWHNF whnf = throwError =<< TypeMismatch "bool" whnf <$> getFuncNameStack instance EgisonWHNF Integer where- fromWHNF = liftError . fromIntegerWHNF+ fromWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0+ fromWHNF (Value (ScalarData (Div (Plus [Term x []]) (Plus [Term 1 []])))) = return x+ fromWHNF whnf = throwError =<< TypeMismatch "integer" whnf <$> getFuncNameStack instance EgisonWHNF Double where- fromWHNF = liftError . fromFloatWHNF+ fromWHNF (Value (Float f 0)) = return f+ fromWHNF whnf = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack instance EgisonWHNF Handle where- fromWHNF = liftError . fromPortWHNF--fromCharWHNF :: WHNFData -> Either EgisonError Char-fromCharWHNF (Value (Char c)) = return c-fromCharWHNF whnf = throwError $ TypeMismatch "char" whnf--fromStringWHNF :: WHNFData -> Either EgisonError Text-fromStringWHNF (Value (String str)) = return str-fromStringWHNF whnf = throwError $ TypeMismatch "string" whnf--fromBoolWHNF :: WHNFData -> Either EgisonError Bool-fromBoolWHNF (Value (Bool b)) = return b-fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf--fromIntegerWHNF :: WHNFData -> Either EgisonError Integer-fromIntegerWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0-fromIntegerWHNF (Value (ScalarData (Div (Plus [Term x []]) (Plus [Term 1 []])))) = return x-fromIntegerWHNF whnf = throwError $ TypeMismatch "integer" whnf--fromFloatWHNF :: WHNFData -> Either EgisonError Double-fromFloatWHNF (Value (Float f 0)) = return f-fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf--fromPortWHNF :: WHNFData -> Either EgisonError Handle-fromPortWHNF (Value (Port h)) = return h-fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf+ fromWHNF (Value (Port h)) = return h+ fromWHNF whnf = throwError =<< TypeMismatch "port" whnf <$> getFuncNameStack class (EgisonWHNF a) => EgisonObject a where toObject :: a -> Object@@ -1643,44 +1638,49 @@ -- Errors -- +type CallStack = [String]+ data EgisonError =- UnboundVariable String- | TypeMismatch String WHNFData- | ArgumentsNumWithNames [String] Int Int- | ArgumentsNumPrimitive Int Int- | ArgumentsNum Int Int- | InconsistentTensorSize- | InconsistentTensorIndex- | TensorIndexOutOfBounds Integer Integer- | NotImplemented String- | Assertion String- | Match String+ UnboundVariable String CallStack+ | TypeMismatch String WHNFData CallStack+ | ArgumentsNumWithNames [String] Int Int CallStack+ | ArgumentsNumPrimitive Int Int CallStack+ | TupleLength Int Int CallStack+ | InconsistentTensorSize CallStack+ | InconsistentTensorIndex CallStack+ | TensorIndexOutOfBounds Integer Integer CallStack+ | NotImplemented String CallStack+ | Assertion String CallStack | Parser String- | Desugar String- | EgisonBug String+ | EgisonBug String CallStack+ | MatchFailure String CallStack | Default String deriving Typeable instance Show EgisonError where+ show (UnboundVariable var stack) =+ "Unbound variable: " ++ show var ++ showTrace stack+ show (TypeMismatch expected found stack) =+ "Expected " ++ expected ++ ", but found: " ++ show found ++ showTrace stack+ show (ArgumentsNumWithNames names expected got stack) =+ "Wrong number of arguments: " ++ show names ++ ": expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack+ show (ArgumentsNumPrimitive expected got stack) =+ "Wrong number of arguments for a primitive function: expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack+ show (TupleLength expected got stack) =+ "Inconsistent tuple lengths: expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack+ show (InconsistentTensorSize stack) = "Inconsistent tensor size" ++ showTrace stack+ show (InconsistentTensorIndex stack) = "Inconsistent tensor index" ++ showTrace stack+ show (TensorIndexOutOfBounds m n stack) = "Tensor index out of bounds: " ++ show m ++ ", " ++ show n ++ showTrace stack+ 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 (UnboundVariable var) = "Unbound variable: " ++ show var- show (TypeMismatch expected found) = "Expected " ++ expected ++- ", but found: " ++ show found- show (ArgumentsNumWithNames names expected got) = "Wrong number of arguments: " ++ show names ++ ": expected " ++- show expected ++ ", but got " ++ show got- show (ArgumentsNumPrimitive expected got) = "Wrong number of arguments for a primitive function: expected " ++- show expected ++ ", but got " ++ show got- show (ArgumentsNum expected got) = "Wrong number of arguments: expected " ++- show expected ++ ", but got " ++ show got- show InconsistentTensorSize = "Inconsistent tensor size"- show InconsistentTensorIndex = "Inconsistent tensor index"- show (TensorIndexOutOfBounds m n) = "Tensor index out of bounds: " ++ show m ++ ", " ++ show n- show (NotImplemented message) = "Not implemented: " ++ message- show (Assertion message) = "Assertion failed: " ++ message- show (Desugar message) = "Error: " ++ message- show (EgisonBug message) = "Egison Error: " ++ message+ show (EgisonBug message stack) = "Egison Error: " ++ message ++ showTrace stack+ show (MatchFailure currentFunc stack) = "Failed pattern match at: " ++ currentFunc ++ showTrace stack show (Default message) = "Error: " ++ message +showTrace :: CallStack -> String+showTrace stack = "\n stack trace: " ++ intercalate ", " stack+ instance Exception EgisonError liftError :: (MonadError e m) => Either e a -> m a@@ -1695,23 +1695,7 @@ } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh) instance MonadFail EgisonM where- fail = throwError . EgisonBug--parallelMapM :: (a -> EgisonM b) -> [a] -> EgisonM [b]-parallelMapM f [] = return []-parallelMapM f (x:xs) = do- let y = unsafePerformEgison (0,1) $ f x- let ys = unsafePerformEgison (0,1) $ parallelMapM f xs- y `par` (ys `pseq` return (y:ys))--unsafePerformEgison :: (Int, Int) -> EgisonM a -> a-unsafePerformEgison (x, y) ma =- let (Right ret, _) = unsafePerformIO $ runFreshT (x, y + 1) $ runEgisonM ma in- ret--- f' :: (Either EgisonError a) -> (Either EgisonError b) -> EgisonM c--- f' (Right x) (Right y) = f x y--- f' (Left e) _ = liftError (Left e)--- f' _ (Left e) = liftError (Left e)+ fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a) runEgisonM = runExceptT . unEgisonM@@ -1727,36 +1711,60 @@ fromEgisonM = modifyCounter . runEgisonM {-# NOINLINE counter #-}-counter :: IORef (Int, Int)-counter = unsafePerformIO (newIORef (0, 0))+counter :: IORef Int+counter = unsafePerformIO $ newIORef 0 -readCounter :: IO (Int, Int)+readCounter :: IO Int readCounter = readIORef counter -updateCounter :: (Int, Int) -> IO ()+updateCounter :: Int -> IO () updateCounter = writeIORef counter modifyCounter :: FreshT IO a -> IO a modifyCounter m = do- seed <- readCounter- (result, seed) <- runFreshT seed m- updateCounter seed+ x <- readCounter+ (result, st) <- runFreshT (RuntimeState { indexCounter = x, funcNameStack = [] }) m+ updateCounter $ indexCounter st return result -newtype FreshT m a = FreshT { unFreshT :: StateT (Int, Int) m a }- deriving (Functor, Applicative, Monad, MonadState (Int, Int), MonadTrans)+data RuntimeState = RuntimeState+ -- | index counter for generating fresh variable+ { indexCounter :: Int+ -- | names of called functions for improved error message+ , funcNameStack :: [String]+ } +newtype FreshT m a = FreshT { unFreshT :: StateT RuntimeState m a }+ deriving (Functor, Applicative, Monad, MonadState RuntimeState, MonadTrans)+ type Fresh = FreshT Identity class (Applicative m, Monad m) => MonadFresh m where fresh :: m String freshV :: m Var+ pushFuncName :: String -> m ()+ topFuncName :: m String+ popFuncName :: m ()+ getFuncNameStack :: m [String] instance (Applicative m, Monad m) => MonadFresh (FreshT m) where- fresh = FreshT $ do (x, y) <- get; modify (\(x,y) -> (x + 1, y))- return $ "$_" ++ show x ++ show y- freshV = FreshT $ do (x, y) <- get; modify (\(x,y) -> (x + 1, y))- return $ Var ["$_" ++ show x ++ show y] []+ fresh = FreshT $ do+ st <- get; modify (\st -> st { indexCounter = indexCounter st + 1 })+ return $ "$_" ++ show (indexCounter st)+ freshV = FreshT $ do+ st <- get; modify (\st -> st {indexCounter = indexCounter st + 1 })+ return $ Var ["$_" ++ show (indexCounter st)] []+ pushFuncName name = FreshT $ do+ st <- get+ put $ st { funcNameStack = name : funcNameStack st }+ return ()+ topFuncName = FreshT $ head . funcNameStack <$> get+ popFuncName = FreshT $ do+ st <- get+ put $ st { funcNameStack = tail $ funcNameStack st }+ return ()+ getFuncNameStack = FreshT $ funcNameStack <$> get+ instance (MonadError e m) => MonadError e (FreshT m) where throwError = lift . throwError catchError m h = FreshT $ catchError (unFreshT m) (unFreshT . h)@@ -1768,26 +1776,42 @@ instance (MonadFresh m) => MonadFresh (StateT s m) where fresh = lift fresh freshV = lift freshV+ pushFuncName name = lift $ pushFuncName name+ topFuncName = lift topFuncName+ popFuncName = lift popFuncName+ getFuncNameStack = lift getFuncNameStack instance (MonadFresh m) => MonadFresh (ExceptT e m) where fresh = lift fresh freshV = lift freshV+ pushFuncName name = lift $ pushFuncName name+ topFuncName = lift topFuncName+ popFuncName = lift popFuncName+ getFuncNameStack = lift getFuncNameStack instance (MonadFresh m, Monoid e) => MonadFresh (ReaderT e m) where fresh = lift fresh freshV = lift freshV+ pushFuncName name = lift $ pushFuncName name+ topFuncName = lift topFuncName+ popFuncName = lift popFuncName+ getFuncNameStack = lift getFuncNameStack instance (MonadFresh m, Monoid e) => MonadFresh (WriterT e m) where fresh = lift fresh freshV = lift freshV+ pushFuncName name = lift $ pushFuncName name+ topFuncName = lift topFuncName+ popFuncName = lift popFuncName+ getFuncNameStack = lift getFuncNameStack instance MonadIO (FreshT IO) where liftIO = lift -runFreshT :: Monad m => (Int, Int) -> FreshT m a -> m (a, (Int, Int))+runFreshT :: Monad m => RuntimeState -> FreshT m a -> m (a, RuntimeState) runFreshT = flip (runStateT . unFreshT) -runFresh :: (Int, Int) -> Fresh a -> (a, (Int, Int))+runFresh :: RuntimeState -> Fresh a -> (a, RuntimeState) runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m @@ -1936,3 +1960,31 @@ 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,+ optUseHappy :: Bool+ }++defaultOption :: EgisonOpts+defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True False
hs-src/Language/Egison/Util.hs view
@@ -8,60 +8,66 @@ module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgison) where -import Control.Monad.Except (liftIO)+import Control.Monad.Except (liftIO) import Data.List-import System.Console.Haskeline hiding (catch, handle, throwTo)+import System.Console.Haskeline hiding (catch, handle, throwTo)+import System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe) import Text.Regex.TDFA -import Language.Egison.Parser as Parser-import Language.Egison.ParserNonS as ParserNonS+import Language.Egison.Parser as Parser+import Language.Egison.ParserNonS as ParserNonS+import Language.Egison.ParserNonS2 as ParserNonS2 import Language.Egison.Types -- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExpr :: Bool -> String -> InputT IO (Maybe (String, EgisonTopExpr))-getEgisonExpr isSExpr prompt = getEgisonExpr' isSExpr prompt ""+getEgisonExpr :: EgisonOpts -> InputT IO (Maybe (String, EgisonTopExpr))+getEgisonExpr opts = getEgisonExpr' opts "" -getEgisonExpr' :: Bool -> String -> String -> InputT IO (Maybe (String, EgisonTopExpr))-getEgisonExpr' isSExpr prompt prev = do+getEgisonExpr' :: EgisonOpts -> String -> InputT IO (Maybe (String, EgisonTopExpr))+getEgisonExpr' opts prev = do mLine <- case prev of- "" -> getInputLine prompt- _ -> getInputLine $ replicate (length prompt) ' '+ "" -> getInputLine $ optPrompt opts+ _ -> getInputLine $ replicate (length $ optPrompt opts) ' ' case mLine of Nothing -> return Nothing Just [] -> if null prev- then getEgisonExpr isSExpr prompt- else getEgisonExpr' isSExpr prompt prev+ then getEgisonExpr opts+ else getEgisonExpr' opts prev Just line -> do+ history <- getHistory+ putHistory $ addHistoryUnlessConsecutiveDupe line history let input = prev ++ line- case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of+ let parsedExpr = (if optUseHappy opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input+ case parsedExpr of Left err | show err =~ "unexpected end of input" ->- getEgisonExpr' isSExpr prompt $ input ++ "\n"+ getEgisonExpr' opts $ input ++ "\n" Left err -> do liftIO $ print err- getEgisonExpr isSExpr prompt+ getEgisonExpr opts Right topExpr -> return $ Just (input, topExpr) -- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExprOrNewLine :: Bool -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))-getEgisonExprOrNewLine isSExpr prompt = getEgisonExprOrNewLine' isSExpr prompt ""+getEgisonExprOrNewLine :: EgisonOpts -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))+getEgisonExprOrNewLine opts = getEgisonExprOrNewLine' opts "" -getEgisonExprOrNewLine' :: Bool -> String -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))-getEgisonExprOrNewLine' isSExpr prompt prev = do+getEgisonExprOrNewLine' :: EgisonOpts -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))+getEgisonExprOrNewLine' opts prev = do mLine <- case prev of- "" -> getInputLine prompt- _ -> getInputLine $ replicate (length prompt) ' '+ "" -> getInputLine $ optPrompt opts+ _ -> getInputLine $ replicate (length $ optPrompt opts) ' ' case mLine of Nothing -> return $ Left Nothing Just [] -> return $ Left $ Just "" Just line -> do let input = prev ++ line- case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of+ let parsedExpr = (if optUseHappy opts then ParserNonS2.parseTopExpr else if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input+ case parsedExpr of Left err | show err =~ "unexpected end of input" ->- getEgisonExprOrNewLine' isSExpr prompt $ input ++ "\n"+ getEgisonExprOrNewLine' opts $ input ++ "\n" Left err -> do liftIO $ print err- getEgisonExprOrNewLine isSExpr prompt+ getEgisonExprOrNewLine opts Right topExpr -> return $ Right (input, topExpr) -- |Complete Egison keywords
lib/core/assoc.egi view
@@ -99,9 +99,9 @@ (define $AC.intersect (lambda [$xs $ys] (match-all [xs ys] [(assoc-multiset something) (assoc-multiset something)]- [[<ncons $x $m _> <ncons ,x $n _>] [x (min m n)]])))+ [[<ncons $x $m _> <ncons ,x $n _>] [x (min {m n})]]))) (define $AC.intersect/m (lambda [$a $xs $ys] (match-all [xs ys] [(assoc-multiset a) (assoc-multiset a)]- [[<ncons $x $m _> <ncons ,x $n _>] [x (min m n)]])))+ [[<ncons $x $m _> <ncons ,x $n _>] [x (min {m n})]])))
lib/core/base.egi view
@@ -75,3 +75,16 @@ (match b bool {[,#t #f] [,#f #t]})))++;;+;; Unordered Pair+;;++(define $unordered-pair+ (lambda [$m]+ (matcher+ {[[$ $] [m m]+ {[[$x $y] {[x y] [y x]}]}]+ [$ [eq]+ {[$tgt {tgt}]}]+ })))
lib/core/collection.egi view
@@ -19,6 +19,9 @@ [<snoc $ $> [a (list a)] {[{@$xs $x} {[x xs]}] [_ {}]}]+ [<join _ $> [(list a)]+ {[$tgt (match-all tgt (list a)+ [(loop $i [1 _] <cons _ ...> $rs) rs])]}] [<join $ $> [(list a) (list a)] {[$tgt (match-all tgt (list a) [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [%i %r] {xa_i @r}) {} (between 1 n))@@ -378,13 +381,17 @@ {[<nil> [] {[{} {[]}] [_ {}]}]+ [<cons $ _> [a]+ {[$tgt tgt]}] [<cons $ $> [a (multiset a)] {[$tgt (match-all tgt (list a) [<join $hs <cons $x $ts>> [x {@hs @ts}]])]}] [<join ,$pxs $> [(multiset a)] {[$tgt (match [pxs tgt] [(list a) (multiset a)]- {[[(loop $i [1 $n] <cons $x_i ...> <nil>)- (loop $i [1 n] <cons ,x_i ...> $rs)]+ {[(loop $i [1 (length pxs)]+ {[<cons $x_i #> <cons ,x_i #>]+ @...}+ [<nil> $rs]) {rs}] [_ {}]})]}] [<join $ $> [(multiset a) (multiset a)]
lib/core/io.egi view
@@ -20,11 +20,16 @@ [(write-to-port port "\n")] }))) -(define $display (compose show print))+(define $display+ (procedure [$x]+ (do {[(write x)]+ [(flush)]+ }))) (define $display-to-port (procedure [$port $x]- (print-to-port port $ (show x))))+ (do {[(write-to-port port x)]+ }))) (define $each-line (procedure [$proc]@@ -71,4 +76,10 @@ (define $debug (macro [$expr] (io (do {[(print (show expr))]}+ (return expr)))))++(define $debug2+ (macro [$msg $expr]+ (io (do {[(display msg)]+ [(print (show expr))]} (return expr)))))
lib/core/order.egi view
@@ -43,8 +43,8 @@ (lambda [$f $xs] (foldl 2#(if (eq? (f %1 %2) <Greater>) %1 %2) (car xs) (cdr xs)))) -(define $min (cambda $xs (foldl b.min (car xs) (cdr xs))))-(define $max (cambda $xs (foldl b.max (car xs) (cdr xs))))+(define $min (lambda [$xs] (foldl b.min (car xs) (cdr xs))))+(define $max (lambda [$xs] (foldl b.max (car xs) (cdr xs)))) (define $split-by-ordering (split-by-ordering/fn compare $ $))
lib/math/algebra/matrix.egi view
@@ -76,8 +76,8 @@ [$c1 (nth 1 cs)] [$c2 (nth 2 cs)] [$ds (tensor-size D)] [$d1 (nth 1 ds)] [$d2 (nth 2 ds)]- [$m1 (max a1 b1)] [$m2 (max a2 c2)]- [$n1 (max c1 d1)] [$n2 (max b2 d2)]+ [$m1 (max {a1 b1})] [$m2 (max {a2 c2})]+ [$n1 (max {c1 d1})] [$n2 (max {b2 d2})] } (generate-tensor 2#(match [%1 %2] [integer integer]
lib/math/expression.egi view
@@ -360,8 +360,8 @@ ;;; (define $coefficients (lambda [$f $x]- (let {[$m (capply max {0 @(match-all f math-expr- [<div <poly <cons <term $a <ncons ,x $k $ts>> _>> _> k])})]}+ (let {[$m (max {0 @(match-all f math-expr+ [<div <poly <cons <term $a <ncons ,x $k $ts>> _>> _> k])})]} (map (coefficient f x $) (between 0 m))))) (define $coefficient
− sample/dp.egi
@@ -1,43 +0,0 @@-(define $delete-literals- (lambda [$ls $cnf]- (map (lambda [$c] (match-all [c ls] [(multiset integer) (multiset integer)]- [[<cons $l _> !<cons ,l _>] l]))- cnf)))--(define $delete-clauses-with- (lambda [$ls $cnf]- (match-all [ls cnf] [(multiset integer) (multiset (multiset integer))]- [{[# <cons (& # $c) _>]- ![<cons $l _> <cons ,l _>]}- c])))--(define $assign-true- (lambda [$l $cnf]- (delete-literals {(neg l)} (delete-clauses-with {l} cnf))))--(define $resolve-on- (lambda [$v $cnf]- (match-all cnf (multiset (multiset integer))- [{<cons <cons ,v (& # $xs)>- <cons <cons ,(neg v) (and # $ys)>- _>>- ![<cons $l _> <cons ,(neg l) _>]}- (unique {@xs @ys})])))--(define $dp- (lambda [$vars $cnf]- (match [vars cnf] [(multiset integer) (multiset (multiset integer))]- {[[_ <nil>] #t]- [[_ <cons <nil> _>] #f]- [[_ <cons <cons $l <nil>> _>] (dp (delete (abs l) vars) (assign-true l cnf))]- [[<cons $v $vs> !<cons <cons ,(neg v) _> _>] (dp vs (assign-true v cnf))]- [[<cons $v $vs> !<cons <cons ,v _> _>] (dp vs (assign-true (neg v) cnf))]- [[<cons $v $vs> _] (dp vs {@(resolve-on v cnf) @(delete-clauses-with {v (neg v)} cnf)})]})))--(dp {1} {{1}}) ; #t-(dp {1} {{1} {-1}}) ; #f-(dp {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f-(dp {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #t-(dp {1 2} {{-1 -2} {1}}) ; #t
− sample/order.egi
@@ -1,23 +0,0 @@-(define $lexical-compare- (lambda [$xs $ys]- (match [xs ys] [(list ordering) (list ordering)]- {[[<nil> <nil>] <Equal>]- [[<nil> _] <Less>]- [[_ <nil>] <Greater>]- [[<cons $x $xs'> <cons ,x $ys'>] (lexical-compare xs' ys')]- [[<cons $x _> <cons $y _>] (compare x y)]})))---(define $lexical-compare- (lambda [$xs $ys]- (match [xs ys] [(list ordering) (list ordering)]- {[(loop $i [1 _]- {[<cons $x_i #> <cons ,x_i #>]- @...}- (& ![<cons $y _> <cons ,y _>]- [$xs' $ys']))- (match [xs' ys'] [(list ordering) (list ordering)]- {[[<nil> <nil>] <Equal>]- [[<nil> _] <Less>]- [[_ <nil>] <Greater>]- [[<cons $x _> <cons $y _>] (compare x y)]})]})))
+ sample/unify.egi view
@@ -0,0 +1,145 @@+;;+;; Unification+;; - Main program is originally written by Yuichi Nishiwaki+;; - Utity functions are originally written by Momoko Hattori+;;++(define $term+ (matcher+ {[<var $> integer+ {[<Var $i> {i}]+ [_ {}]}]+ [<compound $ $> [string (list term)]+ {[<Compound $s $l> {[s l]}]+ [_ {}]}]+ [<unify ,$t $> something+ {[$s (match (unify t s) (maybe something)+ {[(just $σ) {σ}]+ [(nothing) {}]})]}]+ [<subterm $ $> [term something]+ {[$s (subterm s)]}]+ [$ something+ {[$tgt {tgt}]}]}))++(define $var (lambda [$n] <Var n>))++(define $app+ (cambda $xs+ (match xs (list something)+ {[<cons $x $xs> <Compound x xs>]})))++(define $occur+ (pattern-function [$v]+ (| <var v>+ <compound _ <join _ <cons (occur v) _>>>)))++(define $fv+ (match-all-lambda [term]+ {[(occur $v) v]}))++(define $tsubst+ (match-lambda [something term]+ {[[$σ <var $n>]+ (match σ (multiset [integer term])+ {[<cons [,n $t] _> t]+ [_ <Var n>]})]+ [[$σ <compound $f $xs>]+ <Compound f (map (tsubst σ $) xs)>]}))++(define $unify+ (match-lambda (unordered-pair term)+ {[[<var $x> <var ,x>]+ (Just {})]+ [[<var $x> (& $t !(occur ,x))]+ (Just {[x t]})]+ [[<compound $f <nil>> <compound ,f <nil>>]+ (Just {})]+ [[<compound $f $xs> <compound ,f $ys>]+ (unify-list xs ys)]+ [_ Nothing]}))++(define $unify-list+ (match-lambda [(list term) (list term)]+ {[[<nil> <nil>] (Just {})]+ [[<cons $x $xs> <cons $y $ys>]+ (match (unify x y) (maybe something)+ {[(nothing) Nothing]+ [(just $σ1)+ (match (unify-list (map (tsubst σ1 $) xs) (map (tsubst σ1 $) ys)) (maybe something)+ {[(nothing) Nothing]+ [(just $σ2) (Just {@σ1 @σ2})]})]})]+ [_ Nothing]}))++;;+;; Utility for tests+;;++; variables+(define $x (var 0))+(define $y (var 1))+(define $z (var 2))+(define $w (var 3))++; constants+(define $a (app "a"))+(define $b (app "b"))+(define $c (app "c"))+(define $d (app "d"))++; function+(define $f "f")+(define $g "g")+(define $h "h")++(define $show-σ+ (lambda [$σ]+ (S.concat {"{" (show-σ' σ) "}"})))++(define $show-σ'+ (match-lambda (list [something something])+ {[<nil> ""]+ [<cons [$v $t] <nil>>+ (S.concat {"[" (show-var v) ", " (show-term t) "]"})]+ [<cons [$v $t] $σ>+ (S.concat {"[" (show-var v) ", " (show-term t) "], " (show-σ' σ)})]}))++(define $show-var+ (match-lambda integer+ {[,0 "x"]+ [,1 "y"]+ [,2 "z"]+ [,3 "w"]+ }))++(define $show-term+ (match-lambda term+ {[<var ,0> "x"]+ [<var ,1> "y"]+ [<var ,2> "z"]+ [<var ,3> "w"]+ [<var $x> (S.concat {"x" (show x)})]+ [<compound $f ,{}> f]+ [<compound ,"+" <cons (& <compound ,"+" _> $x) <cons $y <nil>>>>+ (S.concat {"(" (show-term x) ") + " (show-term y)})]+ [<compound ,"+" <cons $x <cons $y <nil>>>>+ (S.concat {(show-term x) " + " (show-term y)})]+ [<compound ,"*" <cons (& <compound ,"*" _> $x) <cons $y <nil>>>>+ (S.concat {"(" (show-term x) ") * " (show-term y)})]+ [<compound ,"*" <cons $x <cons $y <nil>>>>+ (S.concat {(show-term x) " * " (show-term y)})]+ [<compound $f $xs>+ (S.concat {f "(" (S.intercalate ", " (map show-term xs)) ")"})]+ }))++;;+;; Test+;;++(show-σ (car (unify (app "+" a b) x)))+; "{[x, a + b]}"++(show-σ (car (unify x (app "+" y z))))+; "{[x, y + z]}"++(show-σ (car (unify (app f x (app g y z) (app h x)) (app f a w y))))+; "{[x, a], [w, g(y, z)], [y, h(a)]}"
test/Test.hs view
@@ -1,22 +1,23 @@ module Main where -import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import Data.IORef-import Data.List+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Data.IORef+import Data.List -import Test.Framework (defaultMain)-import Test.Framework.Providers.HUnit (hUnitTestToTests)-import Test.HUnit-import System.FilePath.Glob (glob)-import System.FilePath (takeDirectory, replaceDirectory, splitPath)+import System.FilePath (replaceDirectory, splitPath,+ takeDirectory)+import System.FilePath.Glob (glob)+import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import Test.HUnit -import Language.Egison.Types-import Language.Egison.Core-import Language.Egison.Primitives-import Language.Egison.Parser-import Language.Egison+import Language.Egison+import Language.Egison.Core+import Language.Egison.Parser+import Language.Egison.Primitives+import Language.Egison.Types main = do (sampleTestCases, unitTestCases) <- partition (isSubsequenceOf "answer" . show) <$> glob "test/**/*.egi"@@ -24,7 +25,7 @@ runUnitTestCase :: FilePath -> Test runUnitTestCase file = TestLabel file . TestCase $ do- env <- initialEnv+ env <- initialEnv defaultOption assertEgisonM $ do exprs <- loadFile file let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs@@ -42,7 +43,7 @@ runSampleTestCase :: FilePath -> Test runSampleTestCase file = TestLabel file . TestCase $ do- env <- initialEnv+ env <- initialEnv defaultOption let directory_path = takeDirectory file answers <- readFile file assertEgisonM (lines answers) $ do