egison 3.2.19 → 3.2.20
raw patch · 8 files changed
+96/−69 lines, 8 filesdep −unix
Dependencies removed: unix
Files
- egison.cabal +2/−2
- hs-src/Interpreter/egisoni.hs +17/−19
- hs-src/Language/Egison.hs +0/−4
- hs-src/Language/Egison/Core.hs +29/−33
- hs-src/Language/Egison/Desugar.hs +4/−4
- hs-src/Language/Egison/Parser.hs +28/−5
- hs-src/Language/Egison/Types.hs +12/−2
- lib/core/natural-number.egi +4/−0
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 3.2.19+Version: 3.2.20 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 against unfree data types.@@ -67,6 +67,6 @@ Executable egison Main-is: egisoni.hs- Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, strict-io, bytestring, unix+ Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, strict-io, bytestring Hs-Source-Dirs: hs-src/Interpreter Other-modules: Paths_egison
hs-src/Interpreter/egisoni.hs view
@@ -1,26 +1,20 @@ module Main where -import Control.Exception (handle)-import Control.Concurrent+import Control.Exception ( AsyncException(..), catch ) import Control.Monad.Error -import qualified Data.Sequence as Sq import Data.ByteString.Lazy.Char8 () import Data.Version -import System.Posix.Signals- import System.Environment import System.Directory (getHomeDirectory) import System.FilePath ((</>)) import System.Console.Haskeline hiding (handle, catch, throwTo) import System.Console.GetOpt import System.Exit (ExitCode (..), exitWith, exitFailure)-import System.IO import Language.Egison-import Language.Egison.Desugar import Language.Egison.Util main :: IO ()@@ -122,36 +116,40 @@ onAbort :: EgisonError -> IO (Either EgisonError a) onAbort e = return $ Left e + repl :: Env -> String -> IO () repl env prompt = do- home <- getHomeDirectory- liftIO $ runInputT (settings home) $ loop env+ loop env where settings :: MonadIO m => FilePath -> Settings m settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home </> ".egison_history") } - loop :: Env -> InputT IO ()- loop env = do- _ <- liftIO $ installHandler keyboardSignal (Catch (do {putStr "^C"; hFlush stdout})) Nothing- input <- getEgisonExpr prompt- tid <- liftIO $ myThreadId- _ <- liftIO $ installHandler keyboardSignal (Catch (throwTo tid UserInterruption)) Nothing+ loop :: Env -> IO ()+ loop env = (do + home <- getHomeDirectory+ input <- liftIO $ runInputT (settings home) $ getEgisonExpr prompt case input of Nothing -> return () Just (Left (topExpr, _)) -> do- result <- liftIO $ handle onAbort $ runEgisonTopExpr env topExpr+ result <- liftIO $ runEgisonTopExpr env topExpr case result of Left err -> do liftIO $ putStrLn $ show err loop env Right env' -> loop env' Just (Right (expr, _)) -> do- result <- liftIO $ handle onAbort $ runEgisonExpr env expr+ result <- liftIO $ runEgisonExpr env expr case result of Left err -> do liftIO $ putStrLn $ show err loop env Right val -> do liftIO $ putStrLn $ show val- loop env-+ loop env)+ `catch`+ (\e -> case e of+ UserInterrupt -> putStrLn "" >> loop env+ StackOverflow -> putStrLn "Stack over flow!" >> loop env+ HeapOverflow -> putStrLn "Heap over flow!" >> loop env+ _ -> putStrLn "error!" >> loop env+ )
hs-src/Language/Egison.hs view
@@ -27,10 +27,6 @@ , version ) where -import Control.Applicative ((<$>), (<*>))-import Control.Monad.Error--import Data.IORef import Data.Version import qualified Paths_egison as P
hs-src/Language/Egison/Core.hs view
@@ -143,15 +143,18 @@ keyWhnfs <- mapM (evalExpr env) keyExprs keys <- mapM makeHashKey keyWhnfs refs <- mapM (newObjectRef env) exprs- case head keys of- IntKey _ -> do- let keys' = map (\key -> case key of- IntKey i -> i) keys+ case keys of+ [] -> do+ let keys' = map (\key -> case key of IntKey i -> i) keys return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs- StrKey _ -> do- let keys' = map (\key -> case key of- StrKey s -> s) keys- return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs+ _ ->+ case head keys of+ IntKey _ -> do+ let keys' = map (\key -> case key of IntKey i -> i) keys+ return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs+ StrKey _ -> do+ let keys' = map (\key -> case key of StrKey s -> s) keys+ return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs where makeHashKey :: WHNFData -> EgisonM EgisonHashKey makeHashKey (Value val) =@@ -202,7 +205,7 @@ case HL.lookup (B.pack key) hash of Just ref -> evalRef ref >>= flip refArray indices Nothing -> return $ Value Undefined- refArray val _ = throwError $ TypeMismatch "array" val+ refArray val _ = throwError $ TypeMismatch "array or hash" val evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern@@ -286,7 +289,7 @@ arg <- evalExpr env arg applyFunc func arg -evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env BFSMode info+evalExpr env (MatcherBFSExpr info) = return $ Value $ UserMatcher env BFSMode info evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info evalExpr env (GenerateArrayExpr (name:[]) (TupleExpr (size:[])) expr) =@@ -588,31 +591,24 @@ indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices case lookup name bindings of Just ref -> do- obj <- evalRef ref >>= flip updateArray indices >>= newEvalutedObjectRef+ obj <- evalRef ref >>= updateHash indices >>= newEvalutedObjectRef return $ msingleton $ MState env loops (subst name obj bindings) trees Nothing -> do- obj <- updateArray (Value $ Array IntMap.empty) indices >>= newEvalutedObjectRef- return $ msingleton $ MState env loops ((name, obj):bindings) trees+ obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvalutedObjectRef+ return $ msingleton $ MState env loops ((name,obj):bindings) trees where- updateArray :: WHNFData -> [Int] -> EgisonM WHNFData- updateArray (Intermediate (IArray ary)) [index] =- return . Intermediate . IArray $ IntMap.insert index target ary- updateArray (Intermediate (IArray ary)) (index:indices) = do- val <- maybe (return $ Value $ Array IntMap.empty) evalRef $ IntMap.lookup index ary- ref <- updateArray val indices >>= newEvalutedObjectRef- return . Intermediate . IArray $ IntMap.insert index ref ary- updateArray (Value (Array ary)) [index] = do- keys <- return $ IntMap.keys ary- vals <- mapM (newEvalutedObjectRef . Value) $ IntMap.elems ary- return . Intermediate . IArray $ IntMap.insert index target (IntMap.fromList $ zip keys vals)- updateArray (Value (Array ary)) (index:indices) = do- let val = Value $ fromMaybe (Array IntMap.empty) $ IntMap.lookup index ary- ref <- updateArray val indices >>= newEvalutedObjectRef- keys <- return $ IntMap.keys ary- vals <- mapM (newEvalutedObjectRef . Value) $ IntMap.elems ary- return . Intermediate . IArray $ IntMap.insert index ref (IntMap.fromList $ zip keys vals)- updateArray _ _ = do- throwError $ strMsg "expected array value"+ updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData+ updateHash [index] (Intermediate (IIntHash hash)) = do+ return . Intermediate . IIntHash $ HL.insert index target hash+ updateHash (index:indices) (Intermediate (IIntHash hash)) = do+ val <- maybe (return $ Intermediate $ IIntHash HL.empty) evalRef $ HL.lookup index hash+ ref <- updateHash indices val >>= newEvalutedObjectRef+ return . Intermediate . IIntHash $ HL.insert index ref hash+ updateHash indices (Value (IntHash hash)) = do+ keys <- return $ HL.keys hash+ vals <- mapM (newEvalutedObjectRef . Value) $ HL.elems hash+ updateHash indices (Intermediate $ IIntHash $ HL.fromList $ zip keys vals)+ updateHash _ v = throwError $ strMsg $ "expected hash value: " ++ show v subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)] subst k nv ((k', v'):xs) | k == k' = (k', nv):(subst k nv xs) | otherwise = (k', v'):(subst k nv xs)@@ -620,7 +616,7 @@ IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) _ -> throwError $ strMsg "something can only match with a pattern variable" -processMState' (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) = return $ msingleton $ MState env loops bindings trees+processMState' (MState env loops bindings ((MNode _ (MState _ _ _ [])):trees)) = return $ msingleton $ MState env loops bindings trees processMState' (MState env loops bindings ((MNode penv state@(MState env' loops' bindings' (tree:trees')):trees))) = do case tree of MAtom pattern target matcher -> do
hs-src/Language/Egison/Desugar.hs view
@@ -61,7 +61,7 @@ body <- mapM genMatcherClause patterns footer <- genSomethingClause clauses <- return $ [main] ++ body ++ [footer]- return $ MatcherExpr clauses+ return $ MatcherDFSExpr clauses genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genMainClause patterns matcher = do@@ -202,7 +202,7 @@ expr' <- desugar expr case expr' of args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "+") args- (TupleExpr args) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "+"), (IntegerExpr 0), (CollectionExpr (map ElementExpr args))])+ (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "+"), x, (CollectionExpr (map ElementExpr args))]) desugar (ApplyExpr (VarExpr "-") expr) = do expr' <- desugar expr@@ -214,7 +214,7 @@ expr' <- desugar expr case expr' of args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "*") args- (TupleExpr args) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "*"), (IntegerExpr 1), (CollectionExpr (map ElementExpr args))])+ (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "*"), x, (CollectionExpr (map ElementExpr args))]) desugar (ApplyExpr expr0 expr1) = do expr0' <- desugar expr0@@ -245,7 +245,7 @@ collectName _ = S.empty makeBinding :: String -> BindingExpr- makeBinding name = ([name], ArrayExpr [])+ makeBinding name = ([name], HashExpr []) desugarPattern' :: EgisonPattern -> DesugarM EgisonPattern desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr
hs-src/Language/Egison/Parser.hs view
@@ -153,7 +153,12 @@ <|> matchExpr <|> matchAllLambdaExpr <|> matchLambdaExpr+ <|> nextMatchAllExpr+ <|> nextMatchExpr+ <|> nextMatchAllLambdaExpr+ <|> nextMatchLambdaExpr <|> matcherExpr+ <|> matcherBFSExpr <|> matcherDFSExpr <|> applyExpr <|> algebraicDataMatcherExpr@@ -204,6 +209,18 @@ matchLambdaExpr :: Parser EgisonExpr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses +nextMatchAllExpr :: Parser EgisonExpr+nextMatchAllExpr = keywordNextMatchAll >> NextMatchAllExpr <$> expr <*> expr <*> matchClause++nextMatchExpr :: Parser EgisonExpr+nextMatchExpr = keywordNextMatch >> NextMatchExpr <$> expr <*> expr <*> matchClauses++nextMatchAllLambdaExpr :: Parser EgisonExpr+nextMatchAllLambdaExpr = keywordNextMatchAllLambda >> NextMatchAllLambdaExpr <$> expr <*> matchClause++nextMatchLambdaExpr :: Parser EgisonExpr+nextMatchLambdaExpr = keywordNextMatchLambda >> NextMatchLambdaExpr <$> expr <*> matchClauses+ matchClauses :: Parser [MatchClause] matchClauses = braces $ sepEndBy matchClause whiteSpace @@ -211,10 +228,13 @@ matchClause = brackets $ (,) <$> pattern <*> expr matcherExpr :: Parser EgisonExpr-matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses+matcherExpr = keywordMatcher >> MatcherBFSExpr <$> ppMatchClauses +matcherBFSExpr :: Parser EgisonExpr+matcherBFSExpr = keywordMatcherBFS >> MatcherBFSExpr <$> ppMatchClauses+ matcherDFSExpr :: Parser EgisonExpr-matcherDFSExpr = keywordMatcher >> MatcherDFSExpr <$> ppMatchClauses+matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses ppMatchClauses :: Parser MatcherInfo ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace@@ -490,13 +510,11 @@ , "match-all-lambda" , "match-lambda" , "matcher"+ , "matcher-bfs" , "matcher-dfs" , "do" , "io" , "algebraic-data-matcher"--- , "empty?"--- , "uncons"--- , "unsnoc" , "generate-array" , "array-size" , "array-ref"@@ -539,7 +557,12 @@ keywordMatchAllLambda = reserved "match-all-lambda" keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda"+keywordNextMatchAll = reserved "next-match-all"+keywordNextMatchAllLambda = reserved "next-match-all-lambda"+keywordNextMatch = reserved "next-match"+keywordNextMatchLambda = reserved "next-match-lambda" keywordMatcher = reserved "matcher"+keywordMatcherBFS = reserved "matcher-bfs" keywordMatcherDFS = reserved "matcher-dfs" keywordDo = reserved "do" keywordIo = reserved "io"
hs-src/Language/Egison/Types.hs view
@@ -147,7 +147,12 @@ | MatchLambdaExpr EgisonExpr [MatchClause] | MatchAllLambdaExpr EgisonExpr MatchClause - | MatcherExpr MatcherInfo+ | NextMatchExpr EgisonExpr EgisonExpr [MatchClause]+ | NextMatchAllExpr EgisonExpr EgisonExpr MatchClause+ | NextMatchLambdaExpr EgisonExpr [MatchClause]+ | NextMatchAllLambdaExpr EgisonExpr MatchClause++ | MatcherBFSExpr MatcherInfo | MatcherDFSExpr MatcherInfo | DoExpr [BindingExpr] EgisonExpr@@ -284,8 +289,10 @@ (Float f) == (Float f') = f == f' (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals' (Tuple vals) == (Tuple vals') = vals == vals'- (Array vals) == (Array vals') = vals == vals' (Collection vals) == (Collection vals') = vals == vals'+ (Array vals) == (Array vals') = vals == vals'+ (IntHash vals) == (IntHash vals') = vals == vals'+ (StrHash vals) == (StrHash vals') = vals == vals' _ == _ = False --@@ -416,6 +423,9 @@ instance Show Object where show (Thunk _) = "#<thunk>" show (WHNF whnf) = show whnf++instance Show ObjectRef where+ show _ = "#<ref>" -- -- Extract data from WHNF
lib/core/natural-number.egi view
@@ -93,3 +93,7 @@ (lambda [$n] (match-all p-fs (list [integer (list integer)]) [<join _ <cons [$m (loop $i [1 ,n] <cons $p_i ...> <nil>)] _>> [m (map (lambda [$i] p_i) (between 1 n))]])))++(define $prime?+ (lambda [$n]+ (eq? (rac (while (lte? $ n) primes)) n)))