diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -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 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 @@ -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 + ) 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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" 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 @@ -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 _) = "#" show (WHNF whnf) = show whnf + +instance Show ObjectRef where + show _ = "#" -- -- Extract data from WHNF diff --git a/lib/core/natural-number.egi b/lib/core/natural-number.egi --- a/lib/core/natural-number.egi +++ b/lib/core/natural-number.egi @@ -93,3 +93,7 @@ (lambda [$n] (match-all p-fs (list [integer (list integer)]) [ )] _>> [m (map (lambda [$i] p_i) (between 1 n))]]))) + +(define $prime? + (lambda [$n] + (eq? (rac (while (lte? $ n) primes)) n)))