diff --git a/benchmark/Benchmark-Collection.hs b/benchmark/Benchmark-Collection.hs deleted file mode 100644 --- a/benchmark/Benchmark-Collection.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# 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 Text.Parsec -import Text.Parsec.ByteString - -import Language.Egison - -runEgisonFile :: String -> IO (Either EgisonError Env) -runEgisonFile path = do - env <- loadPrimitives nullEnv >>= loadLibraries - evalEgisonTopExpr env $ LoadFile path - -config :: Config -config = defaultConfig { cfgSamples = ljust 3 - , cfgPerformGC = ljust True } - -main :: IO () -main = defaultMainWith config (return ()) [ - 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" - ] - ] - diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -6,22 +6,22 @@ import Control.DeepSeq (NFData(rnf)) import Criterion.Main import Criterion.Config -import Text.Parsec -import Text.Parsec.ByteString - import Language.Egison runEgisonFile :: String -> IO (Either EgisonError Env) -runEgisonFile path = do - env <- loadPrimitives nullEnv >>= loadLibraries - evalEgisonTopExpr env $ LoadFile path +runEgisonFile path = loadPrimitives nullEnv >>= loadLibraries >>= flip loadEgisonFile path config :: Config config = defaultConfig { cfgSamples = ljust 3 , cfgPerformGC = ljust True } main :: IO () -main = defaultMainWith config (return ()) [ - bgroup "fact" [ bench "30000" $ runEgisonFile "benchmark/fact-30000.egi" ] - ] +main = defaultMainWith config (return ()) + [ bgroup "fact" [ bench "30000" $ runEgisonFile "benchmark/fact-30000.egi" ] + , 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" + ] + ] diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.0.5 +Version: 3.0.6 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. @@ -46,13 +46,7 @@ Type: exitcode-stdio-1.0 Hs-Source-Dirs: benchmark Main-Is: Benchmark.hs - Build-Depends: egison, base >= 4.0 && < 5, deepseq, criterion >= 0.5, transformers, mtl, parsec >= 3.0 - -Benchmark benchmark-collection - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: benchmark - Main-Is: Benchmark-Collection.hs - Build-Depends: egison, base >= 4.0 && < 5, deepseq, criterion >= 0.5, transformers, mtl, parsec >= 3.0 + Build-Depends: egison, base >= 4.0 && < 5, deepseq, criterion >= 0.5, transformers, mtl Executable egison Main-is: egisoni.hs diff --git a/hs-src/Interpreter/egisoni.hs b/hs-src/Interpreter/egisoni.hs --- a/hs-src/Interpreter/egisoni.hs +++ b/hs-src/Interpreter/egisoni.hs @@ -6,9 +6,6 @@ import Data.Version import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 () -import qualified Data.ByteString.Lazy.Char8 as B -import Text.Parsec -import Text.Parsec.ByteString.Lazy import Text.Regex.Posix import System.Environment @@ -63,7 +60,7 @@ Option ['p'] ["prompt"] (ReqArg (\prompt opts -> opts {optPrompt = prompt}) "String") - "output file to write" + "prompt string" ] printHelp :: IO () @@ -110,10 +107,19 @@ Just "" -> loop env prompt "" Just input' -> do let newInput = rest ++ input' - result <- liftIO $ runEgisonTopExprs env newInput + result <- liftIO $ runEgisonTopExpr env newInput case result of Left err | show err =~ "unexpected end of input" -> do loop env (take (length prompt) (repeat ' ')) $ newInput ++ "\n" + Left err | show err =~ "expecting (top-level|\"define\")" -> do + result <- liftIO $ fromEgisonM (readExpr newInput) >>= either (return . Left) (evalEgisonExpr env) + case result of + Left err -> do + liftIO $ putStrLn $ show err + loop env prompt "" + Right val -> do + liftIO $ putStrLn $ show val + loop env prompt "" Left err -> do liftIO $ putStrLn $ show err loop env prompt "" diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -5,8 +5,11 @@ , module Language.Egison.Primitives , version , counter --danger + , fromEgisonM , loadLibraries , loadPrimitives + , loadEgisonFile + , loadEgisonLibrary , evalEgisonExpr , evalEgisonTopExpr , evalEgisonTopExprs @@ -20,11 +23,6 @@ import System.IO.Unsafe (unsafePerformIO) import Data.IORef import Data.Version -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy.Char8 () -import qualified Data.ByteString.Lazy.Char8 as B -import Text.Parsec -import Text.Parsec.ByteString.Lazy import qualified Paths_egison as P import Language.Egison.Types @@ -69,10 +67,19 @@ , "lib/core/collection.egi" , "lib/core/number.egi" , "lib/core/pattern.egi" ] - + +fromEgisonM :: EgisonM a -> IO (Either EgisonError a) +fromEgisonM = modifyCounter . runEgisonM + loadPrimitives :: Env -> IO Env loadPrimitives env = (++) <$> return env <*> primitiveEnv +loadEgisonFile :: Env -> FilePath -> IO (Either EgisonError Env) +loadEgisonFile env path = modifyCounter $ runEgisonM $ loadFile path >>= evalTopExprs env + +loadEgisonLibrary :: Env -> FilePath -> IO (Either EgisonError Env) +loadEgisonLibrary env path = modifyCounter $ runEgisonM $ loadLibraryFile path >>= evalTopExprs env + evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue) evalEgisonExpr env expr = modifyCounter $ runEgisonM $ evalExpr' env expr @@ -83,10 +90,7 @@ evalEgisonTopExprs env exprs = modifyCounter $ runEgisonM $ evalTopExprs env exprs runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env) -runEgisonTopExpr env input = modifyCounter $ runEgisonM $ liftEgisonM (readTopExpr input) >>= evalTopExpr env +runEgisonTopExpr env input = modifyCounter $ runEgisonM $ readTopExpr input >>= evalTopExpr env runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env) -runEgisonTopExprs env input = modifyCounter $ runEgisonM $ liftEgisonM (readTopExprs input) >>= evalTopExprs env - - - +runEgisonTopExprs env input = modifyCounter $ runEgisonM $ readTopExprs input >>= evalTopExprs env diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -22,7 +22,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Text.Parsec.ByteString.Lazy (parseFromFile) import System.Directory (doesFileExist) import Language.Egison.Types @@ -51,7 +50,7 @@ exprs' <- loadFile file collectDefs (exprs' ++ exprs) bindings rest _ -> collectDefs exprs bindings (expr : rest) - collectDefs [] bindings rest = return (bindings, rest) + collectDefs [] bindings rest = return (bindings, reverse rest) evalTopExpr :: Env -> EgisonTopExpr -> EgisonM Env evalTopExpr env (Define name expr) = recursiveBind env [(name, expr)] @@ -68,21 +67,6 @@ evalTopExpr env (Load file) = loadLibraryFile file >>= evalTopExprs env evalTopExpr env (LoadFile file) = loadFile file >>= evalTopExprs env -loadFile :: FilePath -> EgisonM [EgisonTopExpr] -loadFile file = do - doesExist <- liftIO $ doesFileExist file - unless doesExist $ throwError $ strMsg ("file does not exist: " ++ file) - input <- liftIO $ readFile file - exprs <- liftEgisonM $ readTopExprs input - concat <$> mapM recursiveLoad exprs - where - recursiveLoad (Load file) = loadLibraryFile file - recursiveLoad (LoadFile file) = loadFile file - recursiveLoad expr = return [expr] - -loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] -loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile - evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c) = return . Value $ Char c evalExpr _ (StringExpr s) = return . Value $ String s @@ -389,8 +373,6 @@ processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)) = do let env' = extendEnv env (bindings ++ map (\(LoopContext binding _ _ _) -> binding) loops) case pattern of - WildCard -> return $ msingleton $ MState env loops bindings trees - VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function" ApplyPat func args -> do func <- evalExpr env' func @@ -450,8 +432,8 @@ case matcher of Value Something -> case pattern of - PatVar name -> do - return $ msingleton $ MState env loops ((name, target):bindings) trees + WildCard -> return $ msingleton $ MState env loops bindings trees + PatVar name -> return $ msingleton $ MState env loops ((name, target):bindings) trees IndexedPat (PatVar name) indices -> do indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices case lookup name bindings of diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -16,9 +16,6 @@ newtype DesugarM a = DesugarM { unDesugarM :: ReaderT Subst (ErrorT EgisonError Fresh) a } deriving (Functor, Applicative, Monad, MonadError EgisonError, MonadFresh, MonadReader Subst) -instance MonadFresh (ReaderT Subst (ErrorT EgisonError Fresh)) where - fresh = lift $ lift $ fresh - runDesugarM :: DesugarM a -> Fresh (Either EgisonError a) runDesugarM = runErrorT . flip runReaderT [] . unDesugarM diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -2,22 +2,28 @@ ( readTopExprs , readTopExpr , readExprs - , readExpr + , readExpr + , loadFile + , loadLibraryFile , parseTopExprs , parseTopExpr , parseExprs , parseExpr ) where -import Control.Monad.Identity -import Control.Monad.Error -import Control.Monad.State +import Prelude hiding (mapM) +import Control.Monad.Identity hiding (mapM) +import Control.Monad.Error hiding (mapM) +import Control.Monad.State hiding (mapM) import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) +import System.Directory (doesFileExist) + import qualified Data.Sequence as Sq import Data.Either import Data.Set (Set) import Data.Char (isLower, isUpper) import qualified Data.Set as Set +import Data.Traversable (mapM) import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 () @@ -29,22 +35,41 @@ import Language.Egison.Types import Language.Egison.Desugar +import Paths_egison (getDataFileName) doParse :: Parser a -> String -> Either EgisonError a -doParse p input = either (throwError . Parser) return $ parse p "egison" $ B.pack input +doParse p input = either (throwError . fromParsecError) return $ parse p "egison" $ B.pack input + where + fromParsecError :: ParseError -> EgisonError + fromParsecError = Parser . show -readTopExprs :: String -> Fresh (Either EgisonError [EgisonTopExpr]) -readTopExprs = runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs +readTopExprs :: String -> EgisonM [EgisonTopExpr] +readTopExprs = liftEgisonM . runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs -readTopExpr :: String -> Fresh (Either EgisonError EgisonTopExpr) -readTopExpr = runDesugarM . either throwError desugarTopExpr . parseTopExpr +readTopExpr :: String -> EgisonM EgisonTopExpr +readTopExpr = liftEgisonM . runDesugarM . either throwError desugarTopExpr . parseTopExpr -readExprs :: String -> Fresh (Either EgisonError [EgisonExpr]) -readExprs = runDesugarM . either throwError (mapM desugar) . parseExprs +readExprs :: String -> EgisonM [EgisonExpr] +readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs -readExpr :: String -> Fresh (Either EgisonError EgisonExpr) -readExpr = runDesugarM . either throwError desugar . parseExpr +readExpr :: String -> EgisonM EgisonExpr +readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr +loadFile :: FilePath -> EgisonM [EgisonTopExpr] +loadFile file = do + doesExist <- liftIO $ doesFileExist file + unless doesExist $ throwError $ strMsg ("file does not exist: " ++ file) + input <- liftIO $ readFile file + exprs <- readTopExprs input + concat <$> mapM recursiveLoad exprs + where + recursiveLoad (Load file) = loadLibraryFile file + recursiveLoad (LoadFile file) = loadFile file + recursiveLoad expr = return [expr] + +loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] +loadLibraryFile file = liftIO (getDataFileName file) >>= loadFile + parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] parseTopExprs = doParse $ whiteSpace >> endBy topExpr whiteSpace @@ -63,11 +88,11 @@ topExpr :: Parser EgisonTopExpr topExpr = parens (defineExpr - <|> testExpr - <|> executeExpr - <|> loadFileExpr - <|> loadExpr - "top-level expression") + <|> testExpr + <|> executeExpr + <|> loadFileExpr + <|> loadExpr) + "top-level expression" defineExpr :: Parser EgisonTopExpr defineExpr = keywordDefine >> Define <$> varName <*> expr @@ -113,7 +138,7 @@ <|> generateArrayExpr <|> arraySizeExpr <|> arrayRefExpr) - "expression") + "expression") varExpr :: Parser EgisonExpr varExpr = VarExpr <$> ident diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -7,9 +7,12 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.State +import Control.Monad.Reader (ReaderT) +import Control.Monad.Writer (WriterT) import Control.Monad.Identity import Control.Monad.Trans.Maybe +import Data.Monoid (Monoid) import Data.Foldable (foldr, toList) import qualified Data.Sequence as Sq import Data.Sequence (Seq) @@ -18,8 +21,6 @@ import qualified Data.HashMap.Strict as HashMap import System.IO -import Text.Parsec (ParseError) - import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -288,18 +289,18 @@ -- data EgisonError = - Parser ParseError - | UnboundVariable Var + UnboundVariable Var | TypeMismatch String WHNFData | ArgumentsNum Int Int | NotImplemented String | Assertion String | Match String + | Parser String | Desugar String | Default String instance Show EgisonError where - show (Parser error) = "Parse error at: " ++ show error + show (Parser error) = "Parse error at: " ++ error show (UnboundVariable var) = "Unbound variable: " ++ var show (TypeMismatch expected found) = "Expected " ++ expected ++ ", but found: " ++ show found @@ -340,7 +341,19 @@ instance (MonadState s m) => MonadState s (FreshT m) where get = lift $ get put s = lift $ put s - + +instance (MonadFresh m) => MonadFresh (StateT s m) where + fresh = lift $ fresh + +instance (MonadFresh m, Error e) => MonadFresh (ErrorT e m) where + fresh = lift $ fresh + +instance (MonadFresh m, Monoid e) => MonadFresh (ReaderT e m) where + fresh = lift $ fresh + +instance (MonadFresh m, Monoid e) => MonadFresh (WriterT e m) where + fresh = lift $ fresh + instance MonadIO (FreshT IO) where liftIO = lift @@ -352,7 +365,7 @@ newtype EgisonM a = EgisonM { unEgisonM :: ErrorT EgisonError (FreshT IO) a - } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError) + } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh) runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a) runEgisonM = runErrorT . unEgisonM diff --git a/test/UnitTest.hs b/test/UnitTest.hs --- a/test/UnitTest.hs +++ b/test/UnitTest.hs @@ -19,21 +19,21 @@ defaultMain $ hUnitTestToTests $ test $ map runTestCase testCases runTestCase :: FilePath -> Test -runTestCase file = TestLabel file . TestCase $ do +runTestCase file = TestLabel file . TestCase $ do env <- primitiveEnv >>= loadLibraries - seed <- readIORef counter - (result, seed') <- runFreshT seed $ runEgisonM $ loadFile file >>= evalTopExprs' env - writeIORef counter seed' - assertString $ either show (const "") result - -evalTopExprs' :: Env -> [EgisonTopExpr] -> EgisonM () -evalTopExprs' env exprs = do - let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs - env <- recursiveBind env bindings - forM_ tests $ evalExpr' env - where - collectDefsAndTests (Define name expr) (bindings, tests) = - ((name, expr) : bindings, tests) - collectDefsAndTests (Test expr) (bindings, tests) = - (bindings, expr : tests) - collectDefsAndTests _ r = r + assertEgisonM $ do + exprs <- loadFile file + let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs + env' <- recursiveBind env bindings + forM_ tests $ evalExpr' env' + where + assertEgisonM :: EgisonM a -> Assertion + assertEgisonM m = fromEgisonM m >>= assertString . either show (const "") + + collectDefsAndTests (Define name expr) (bindings, tests) = + ((name, expr) : bindings, tests) + collectDefsAndTests (Test expr) (bindings, tests) = + (bindings, expr : tests) + collectDefsAndTests _ r = r + +