diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,5 @@ +#!/usr/bin/env runhaskell + import Distribution.Simple + main = defaultMain diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,11 +1,23 @@ Name: egison -Version: 3.2.14 +Version: 3.2.15 Synopsis: Programming language with non-linear pattern-matching against unfree data types -Description: An interpreter for Egison, the programming langugage that realized non-linear pattern-matching with unfree data types. - With Egison, you can represent pattern-matching with unfree data types intuitively, - especially for collection data, such as lists, multisets, sets. - You can find Egison programs in "lib/" and "sample/" directories. - This package also include Emacs Lisp file "egison-mode.el" in "elisp/" directory. +Description: + An interpreter for Egison, the programming langugage that realized non-linear pattern-matching against unfree data types. + With Egison, you can represent pattern-matching against unfree data types intuitively, + especially for collection data, such as lists, multisets, sets. + We can find Egison programs in @lib@ and @sample@ directories. + This package also include Emacs Lisp file @egison-mode.el@ in @elisp@ directory. + . + The following code is the program that determins poker-hands written in Egison. + All hands are expressed in a single pattern. + We can run this code online at . + . + <> + . + The pattern-matching of Egison is very powerful. + We can use it for pattern-matching against graphs, too. + Egison is not popular at all now. + Please help us to make Egison popular. Homepage: http://www.egison.org License: MIT License-file: LICENSE @@ -28,8 +40,6 @@ Library Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, bytestring, text --- , direct-sqlite -- for 'egison-sqlite' --- , mysql -- for 'egison-mysql' Hs-Source-Dirs: hs-src Exposed-Modules: Language.Egison 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 @@ -39,16 +39,16 @@ Options {optPrompt = prompt, optShowBanner = bannerFlag} -> do case nonOpts of [] -> do - env <- primitiveEnv >>= loadCoreLibraries + env <- initialEnv when bannerFlag showBanner >> repl env prompt >> when bannerFlag showByebyeMessage (file:args) -> do case opts of Options {optLoadOnly = True} -> do - env <- primitiveEnvNoIO >>= loadCoreLibraries + env <- initialEnvNoIO result <- evalEgisonTopExprs env [LoadFile file] either print (const $ return ()) result Options {optLoadOnly = False} -> do - env <- primitiveEnv >>= loadCoreLibraries + env <- initialEnv result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))] either print (const $ return ()) result 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 @@ -18,9 +18,11 @@ , runEgisonTopExpr , runEgisonTopExprs -- * Load Egison files - , loadCoreLibraries , loadEgisonLibrary , loadEgisonFile + -- * Environment + , initialEnv + , initialEnvNoIO -- * Information , version ) where @@ -65,29 +67,44 @@ runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env) runEgisonTopExprs env input = fromEgisonM $ readTopExprs input >>= evalTopExprs env -loadCoreLibraries :: Env -> IO Env -loadCoreLibraries env = do - ret <- evalEgisonTopExprs env $ map Load libraries +-- |load an Egison file +loadEgisonFile :: Env -> FilePath -> IO (Either EgisonError Env) +loadEgisonFile env path = evalEgisonTopExpr env (LoadFile path) + +-- |load an Egison library +loadEgisonLibrary :: Env -> FilePath -> IO (Either EgisonError Env) +loadEgisonLibrary env path = evalEgisonTopExpr env (Load path) + +-- |Environment that contains core libraries +initialEnv :: IO Env +initialEnv = do + env <- primitiveEnv + ret <- evalEgisonTopExprs env $ map Load coreLibraries case ret of Left err -> do print . show $ err return env Right env' -> return env' - where - libraries :: [String] - libraries = [ "lib/core/base.egi" - , "lib/core/collection.egi" - , "lib/core/order.egi" - , "lib/core/number.egi" - , "lib/core/natural-number.egi" - , "lib/core/string.egi" - , "lib/core/database.egi" - , "lib/core/io.egi" - ] -loadEgisonFile :: Env -> FilePath -> IO (Either EgisonError Env) -loadEgisonFile env path = evalEgisonTopExpr env (LoadFile path) - -loadEgisonLibrary :: Env -> FilePath -> IO (Either EgisonError Env) -loadEgisonLibrary env path = evalEgisonTopExpr env (Load path) +-- |Environment that contains core libraries without IO primitives +initialEnvNoIO :: IO Env +initialEnvNoIO = do + env <- primitiveEnvNoIO + ret <- evalEgisonTopExprs env $ map Load coreLibraries + case ret of + Left err -> do + print . show $ err + return env + Right env' -> return env' +coreLibraries :: [String] +coreLibraries = + [ "lib/core/base.egi" + , "lib/core/collection.egi" + , "lib/core/order.egi" + , "lib/core/number.egi" + , "lib/core/natural-number.egi" + , "lib/core/string.egi" + , "lib/core/database.egi" + , "lib/core/io.egi" + ] 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 @@ -47,6 +47,7 @@ import qualified Data.HashMap.Lazy as HL +import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 () import qualified Data.ByteString.Lazy.Char8 as B @@ -359,9 +360,7 @@ if length names == length refs then evalExpr (extendEnv env $ makeBindings names refs) body else throwError $ ArgumentsNum (length names) (length refs) -applyFunc (Value (PrimitiveFunc func)) arg = do - arg' <- evalWHNF arg - liftM Value . func $ arg' +applyFunc (Value (PrimitiveFunc func)) arg = func arg applyFunc (Value (IOFunc m)) arg = do case arg of Value World -> m @@ -381,7 +380,7 @@ bindEnv :: Env -> String -> Integer -> EgisonM Env bindEnv env name i = do - ref <- liftIO $ newIORef (WHNF . Value . Integer $ i) + ref <- newEvaluatedThunk (Value . Integer $ i) return $ extendEnv env [(name, ref)] newThunk :: Env -> EgisonExpr -> EgisonM ObjectRef @@ -478,14 +477,14 @@ then do return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) else do - startNumRef <- liftIO . newIORef . WHNF $ Value $ Integer startNum + startNumRef <- newEvaluatedThunk $ Value $ Integer startNum let loops' = LoopContextConstant (name, startNumRef) endNum pat pat' : loops return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) LoopPat name (LoopRangeVariable start lastNumPat) pat pat' -> do startNum' <- evalExpr env' start startNum <- fromWHNF startNum' - startNumRef <- liftIO . newIORef . WHNF $ Value $ Integer startNum - lastNumRef <- liftIO . newIORef . WHNF $ Value $ Integer (startNum - 1) + startNumRef <- newEvaluatedThunk $ Value $ Integer startNum + lastNumRef <- newEvaluatedThunk $ Value $ Integer (startNum - 1) return $ fromList [MState env loops bindings (MAtom lastNumPat lastNumRef (Value Something) : MAtom pat' target matcher : trees), MState env (LoopContextVariable (name, startNumRef) lastNumPat pat pat' : loops) bindings (MAtom pat target matcher : trees)] ContPat -> @@ -498,14 +497,14 @@ if nextNum > endNum then return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) else do - nextNumRef <- liftIO . newIORef . WHNF $ Value $ Integer nextNum + nextNumRef <- newEvaluatedThunk $ Value $ Integer nextNum let loops' = LoopContextConstant (name, nextNumRef) endNum pat pat' : loops return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) LoopContextVariable (name, startNumRef) lastNumPat pat pat' : loops -> do startNum' <- evalRef startNumRef startNum <- fromWHNF startNum' let nextNum = startNum + 1 - nextNumRef <- liftIO . newIORef . WHNF $ Value $ Integer nextNum + nextNumRef <- newEvaluatedThunk $ Value $ Integer nextNum let loops' = LoopContextVariable (name, nextNumRef) lastNumPat pat pat' : loops return $ fromList [MState env loops bindings (MAtom lastNumPat startNumRef (Value Something) : MAtom pat' target matcher : trees), MState env loops' bindings (MAtom pat target matcher : trees)] @@ -677,7 +676,7 @@ (++) <$> primitiveDataPatternMatch pattern init <*> primitiveDataPatternMatch pattern' last primitiveDataPatternMatch (PDConstantPat expr) ref = do - target <- lift (evalRef ref) >>= either (const matchFail) return . fromBuiltinWHNF + target <- lift (evalRef ref) >>= either (const matchFail) return . extractPrimitiveValue isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target if isEqual then return [] else matchFail @@ -794,3 +793,18 @@ ls fromStringValue (Tuple [val]) = fromStringValue val fromStringValue val = throwError $ TypeMismatch "string" (Value val) + +-- +-- Util +-- +data EgisonHashKey = + IntKey Integer + | StrKey ByteString + +extractPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue +extractPrimitiveValue (Value val@(Char _)) = return val +extractPrimitiveValue (Value val@(Bool _)) = return val +extractPrimitiveValue (Value val@(Integer _)) = return val +extractPrimitiveValue (Value val@(Float _)) = return val +extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf + 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 @@ -122,12 +122,11 @@ clauses' <- desugarMatchClauses clauses return $ LambdaExpr [name] (MatchExpr (VarExpr name) matcher' clauses') -desugar (ArrayRefExpr (VarExpr name) (TupleExpr nums)) = - desugar $ IndexedExpr (VarExpr name) nums - desugar (ArrayRefExpr expr nums) = - desugar $ ArrayRefExpr expr (TupleExpr [nums]) - + case nums of + (TupleExpr nums') -> desugar $ IndexedExpr expr nums' + _ -> desugar $ IndexedExpr expr [nums] + desugar (IndexedExpr expr indices) = IndexedExpr <$> desugar expr <*> (mapM desugar indices) 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 @@ -483,6 +483,9 @@ , "do" , "io" , "algebraic-data-matcher" +-- , "empty?" +-- , "uncons" +-- , "unsnoc" , "generate-array" , "array-size" , "array-ref" @@ -497,6 +500,7 @@ , "|" , "^" , "," + , "." , "@" , "..."] @@ -521,6 +525,7 @@ keywordLet = reserved "let" keywordLoop = reserved "loop" keywordMatchAll = reserved "match-all" +keywordMatchAllLambda = reserved "match-all-lambda" keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda" keywordMatcher = reserved "matcher" @@ -529,6 +534,9 @@ keywordSomething = reserved "something" keywordUndefined = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher" +--keywordisEmpty = reserved "empty?" +--keywordUnCons = reserved "uncons" +--keywordUnSnoc = reserved "unsnoc" keywordGenerateArray = reserved "generate-array" keywordArraySize = reserved "array-size" keywordArrayRef = reserved "array-ref" diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -29,6 +29,8 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.Text as T +import Control.Monad + {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite --} -- for 'egison-sqlite' @@ -37,8 +39,6 @@ import qualified Database.MySQL.Base as MySQL --} -- for 'egison-mysql' -import Control.Monad - import Language.Egison.Types import Language.Egison.Parser import Language.Egison.Core @@ -60,36 +60,42 @@ return $ extendEnv nullEnv bindings {-# INLINE noArg #-} -noArg :: EgisonM EgisonValue -> - EgisonValue -> EgisonM EgisonValue -noArg f = \args -> case tupleToList args of - [] -> f - vals -> throwError $ ArgumentsNum 0 $ length vals +noArg :: EgisonM EgisonValue -> PrimitiveFunc +noArg f = \args -> do + args' <- tupleToList args + case args' of + [] -> f >>= return . Value + _ -> throwError $ ArgumentsNum 0 $ length args' {-# INLINE oneArg #-} -oneArg :: (EgisonValue -> EgisonM EgisonValue) -> - EgisonValue -> EgisonM EgisonValue -oneArg f = \args -> case args of - (Tuple [val]) -> f val - _ -> f args +oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc +oneArg f = \args -> do + args' <- evalWHNF args + f args' >>= return . Value {-# INLINE twoArgs #-} -twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> - EgisonValue -> EgisonM EgisonValue -twoArgs f = \args -> case tupleToList args of - [val, val'] -> f val val' - vals -> throwError $ ArgumentsNum 2 $ length vals +twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc +twoArgs f = \args -> do + args' <- tupleToList args + case args' of + [val, val'] -> f val val' >>= return . Value + _ -> throwError $ ArgumentsNum 2 $ length args' {-# INLINE threeArgs #-} -threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> - EgisonValue -> EgisonM EgisonValue -threeArgs f = \args -> case tupleToList args of - [val, val', val''] -> f val val' val'' - vals -> throwError $ ArgumentsNum 3 $ length vals +threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc +threeArgs f = \args -> do + args' <- tupleToList args + case args' of + [val, val', val''] -> f val val' val'' >>= return . Value + _ -> throwError $ ArgumentsNum 3 $ length args' -tupleToList :: EgisonValue -> [EgisonValue] -tupleToList (Tuple vals) = vals -tupleToList val = [val] +tupleToList :: WHNFData -> EgisonM [EgisonValue] +tupleToList whnf = do + val <- evalWHNF whnf + return $ tupleToList' val + where + tupleToList' (Tuple vals) = vals + tupleToList' val = [val] -- -- Constants @@ -107,7 +113,8 @@ , ("-", minus) , ("*", multiply) , ("/", divide) - , ("/-inverse", divideInverse) + , ("numerator", numerator') + , ("denominator", denominator') , ("modulo", integerBinaryOp mod) , ("quotient", integerBinaryOp quot) @@ -146,9 +153,17 @@ , ("rtof", rationalToFloat) , ("stoi", stringToInteger) - + , ("read", read') , ("show", show') + +{-- + , ("empty?", isEmpty') + , ("car", car') + , ("cdr", cdr') + , ("rac", rac') + , ("rdc", rdc') +--} , ("assert", assert) , ("assert-equal", assertEqual) @@ -270,15 +285,24 @@ numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) -divideInverse :: PrimitiveFunc -divideInverse = oneArg $ divideInverse' +numerator' :: PrimitiveFunc +numerator' = oneArg $ numerator'' where - divideInverse' (Rational rat) = do - return $ Tuple [Integer (numerator rat), Integer (denominator rat)] - divideInverse' (Integer x) = do - return $ Tuple [Integer x, Integer 1] - divideInverse' val = throwError $ TypeMismatch "rational" (Value val) + numerator'' (Rational rat) = do + return $ Integer (numerator rat) + numerator'' (Integer x) = do + return $ Integer x + numerator'' val = throwError $ TypeMismatch "rational" (Value val) +denominator' :: PrimitiveFunc +denominator' = oneArg $ denominator'' + where + denominator'' (Rational rat) = do + return $ Integer (denominator rat) + denominator'' (Integer x) = do + return $ Integer 1 + denominator'' val = throwError $ TypeMismatch "rational" (Value val) + -- -- Pred -- @@ -360,17 +384,33 @@ f <- fromEgison val return $ Integer $ op f +stringToInteger :: PrimitiveFunc +stringToInteger = oneArg $ \val -> do + numStr <- fromEgison val + return $ Integer (read numStr :: Integer) + read' :: PrimitiveFunc read'= oneArg $ \val -> fromStringValue val >>= readExpr >>= evalExprDeep nullEnv show' :: PrimitiveFunc show'= oneArg $ \val -> return $ toEgison $ show val -stringToInteger :: PrimitiveFunc -stringToInteger = oneArg $ \val -> do - numStr <- fromEgison val - return $ Integer (read numStr :: Integer) +{-- +isEmpty' :: PrimitiveFunc +isEmpty' = undefined +car' :: PrimitiveFunc +car' = undefined + +cdr' :: PrimitiveFunc +cdr' = undefined + +rac' :: PrimitiveFunc +rac' = undefined + +rdc' :: PrimitiveFunc +rdc' = undefined +--} assert :: PrimitiveFunc assert = twoArgs $ \label test -> do 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 @@ -26,7 +26,6 @@ , EgisonValue (..) , Matcher (..) , PrimitiveFunc (..) - , EgisonHashKey (..) -- TODO ? , Egison (..) , fromMatcherValue -- * Internal data @@ -36,7 +35,6 @@ , Intermediate (..) , Inner (..) , EgisonWHNF (..) - , fromBuiltinWHNF -- TODO ? -- * Environment , Env (..) , Var (..) @@ -242,11 +240,7 @@ | EOF type Matcher = (Env, MatcherInfo) -type PrimitiveFunc = EgisonValue -> EgisonM EgisonValue - -data EgisonHashKey = - IntKey Integer - | StrKey ByteString +type PrimitiveFunc = WHNFData -> EgisonM WHNFData instance Show EgisonValue where show (Char c) = "'" ++ [c] ++ "'" @@ -475,16 +469,6 @@ fromMatcherWHNF :: WHNFData -> Either EgisonError Matcher fromMatcherWHNF (Value (Matcher matcher)) = return matcher fromMatcherWHNF whnf = throwError $ TypeMismatch "matcher" whnf - --- --- --- -fromBuiltinWHNF :: WHNFData -> Either EgisonError EgisonValue -fromBuiltinWHNF (Value val@(Char _)) = return val -fromBuiltinWHNF (Value val@(Bool _)) = return val -fromBuiltinWHNF (Value val@(Integer _)) = return val -fromBuiltinWHNF (Value val@(Float _)) = return val -fromBuiltinWHNF whnf = throwError $ TypeMismatch "primitive value" whnf -- -- Environment diff --git a/hs-src/Language/Egison/Util.hs b/hs-src/Language/Egison/Util.hs --- a/hs-src/Language/Egison/Util.hs +++ b/hs-src/Language/Egison/Util.hs @@ -1,4 +1,3 @@ - {- | Module : Language.Egison.Util Copyright : Satoshi Egi @@ -27,7 +26,7 @@ completeEgison arg@(_, _) = (completeWord Nothing " \t[]{}$," completeEgisonKeyword) arg completeAfterOpenParen :: Monad m => String -> m [Completion] -completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenParen +completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) $ egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen completeAfterOpenCons :: Monad m => String -> m [Completion] completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons @@ -38,12 +37,13 @@ completeEgisonKeyword :: Monad m => String -> m [Completion] completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords +egisonPrimitivesAfterOpenParen = map ((:) '(') $ ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "assert", "assert-equal"] egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"] ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "empty?", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "qsort", "intersperse", "intercalate", "split", "split/m"] egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"] egisonKeywordsInNeutral = ["something"] ++ ["bool", "string", "integer", "nats", "primes"] -egisonKeywords = egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral +egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral completeParen :: Monad m => CompletionFunc m completeParen (lstr, _) = case (closeParen lstr) of diff --git a/test/UnitTest.hs b/test/UnitTest.hs --- a/test/UnitTest.hs +++ b/test/UnitTest.hs @@ -20,7 +20,7 @@ runTestCase :: FilePath -> Test runTestCase file = TestLabel file . TestCase $ do - env <- primitiveEnv >>= loadCoreLibraries + env <- initialEnv assertEgisonM $ do exprs <- loadFile file let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs