egison 3.2.14 → 3.2.15

raw patch · 11 files changed

+180/−105 lines, 11 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Setup.hs +3/−0
• egison.cabal +18/−8
• hs-src/Interpreter/egisoni.hs +3/−3
• hs-src/Language/Egison.hs +37/−20
• hs-src/Language/Egison/Core.hs +24/−10
• hs-src/Language/Egison/Desugar.hs +4/−5
• hs-src/Language/Egison/Parser.hs +8/−0
• hs-src/Language/Egison/Primitives.hs +78/−38
• hs-src/Language/Egison/Types.hs +1/−17
• hs-src/Language/Egison/Util.hs +3/−3
• test/UnitTest.hs +1/−1

@@ -1,2 +1,5 @@+#!/usr/bin/env runhaskell+ import Distribution.Simple+ main = defaultMain

@@ -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 <http://www.egison.org/demonstrations/poker-hands.html>.+  .+  <<http://www.egison.org/images/poker-hands.png>>+  .+  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

@@ -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 

@@ -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"+  ]

@@ -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+

@@ -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) 

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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