diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.18 +Version: 3.2.19 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. @@ -56,15 +56,17 @@ Hs-Source-Dirs: test Main-Is: UnitTest.hs Build-Depends: egison, base >= 4.0 && < 5, transformers, mtl, Glob, HUnit, test-framework, test-framework-hunit + Other-modules: Paths_egison Benchmark benchmark 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 + Other-modules: Paths_egison 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 - Other-modules: Paths_egison 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,17 +1,10 @@ module Main where -import Prelude hiding (catch) -import Control.Exception ( SomeException(..), - AsyncException(..), - catch, handle, throw) +import Control.Exception (handle) import Control.Concurrent -import Control.Applicative ((<$>), (<*>)) import Control.Monad.Error -import Data.List -import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) import qualified Data.Sequence as Sq -import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 () import Data.Version @@ -27,6 +20,7 @@ import System.IO import Language.Egison +import Language.Egison.Desugar import Language.Egison.Util main :: IO () @@ -47,7 +41,7 @@ result <- evalEgisonTopExprs env [LoadFile file] either print (const $ return ()) result Options {optLoadOnly = False} -> do - result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (Sq.fromList (map (ElementExpr . StringExpr) args))))] + result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (map (ElementExpr . StringExpr) args)))] either print (const $ return ()) result data Options = Options { @@ -118,16 +112,15 @@ putStrLn $ "Welcome to Egison Interpreter!" putStrLn $ "** Info **" putStrLn $ "We can use a \'Tab\' key to complete keywords on the interpreter." - putStrLn $ "If we type a \'Tab\' key after after a closed parenthesis, the next closed parenthesis will be completed." + putStrLn $ "If we type a \'Tab\' key after a closed parenthesis, the next closed parenthesis will be completed." showByebyeMessage :: IO () showByebyeMessage = do putStrLn $ "Leaving Egison Interpreter." + exitWith ExitSuccess onAbort :: EgisonError -> IO (Either EgisonError a) -onAbort e = do - let x = show e - return $ Left e +onAbort e = return $ Left e repl :: Env -> String -> IO () repl env prompt = do @@ -145,15 +138,15 @@ _ <- liftIO $ installHandler keyboardSignal (Catch (throwTo tid UserInterruption)) Nothing case input of Nothing -> return () - Just (Left topExpr) -> do - result <- liftIO $ handle onAbort $ evalEgisonTopExpr env topExpr + Just (Left (topExpr, _)) -> do + result <- liftIO $ handle onAbort $ 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 $ evalEgisonExpr env expr + Just (Right (expr, _)) -> do + result <- liftIO $ handle onAbort $ runEgisonExpr env expr case result of Left err -> do liftIO $ putStrLn $ show err @@ -161,5 +154,4 @@ Right val -> do liftIO $ putStrLn $ show val loop 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 @@ -46,25 +46,19 @@ import Data.Foldable (toList) import Data.Traversable (mapM) import Data.IORef -import Data.List import Data.Maybe 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 -import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import System.Directory (doesFileExist) import Language.Egison.Types import Language.Egison.Parser -import Language.Egison.Desugar -import Paths_egison (getDataFileName) -- -- Evaluator @@ -129,16 +123,17 @@ evalExpr env (TupleExpr [expr]) = evalExpr env expr evalExpr env (TupleExpr exprs) = Intermediate . ITuple <$> mapM (newObjectRef env) exprs -evalExpr env (CollectionExpr inners) = - if Sq.null inners then - return . Value $ Collection Sq.empty - else - Intermediate . ICollection <$> (mapM fromInnerExpr inners >>= liftIO . newIORef) - where - fromInnerExpr :: InnerExpr -> EgisonM Inner - fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr - fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr +evalExpr _ (CollectionExpr []) = return . Value $ Collection Sq.empty +evalExpr env (CollectionExpr inners) = do + inners' <- mapM fromInnerExpr inners + innersSeq <- liftIO $ newIORef $ Sq.fromList inners' + return $ Intermediate $ ICollection innersSeq + where + fromInnerExpr :: InnerExpr -> EgisonM Inner + fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr + fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr + evalExpr env (ArrayExpr exprs) = do ref' <- mapM (newObjectRef env) exprs return . Intermediate . IArray $ IntMap.fromList $ zip (enumFromTo 1 (length exprs)) ref' @@ -265,7 +260,7 @@ evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do target <- newObjectRef env target matcher <- evalExpr env matcher >>= evalMatcherWHNF - result <- patternMatch BFSMode env pattern target matcher + result <- patternMatch env pattern target matcher mmap (flip evalExpr expr . extendEnv env) result >>= fromMList where fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData @@ -280,7 +275,7 @@ target <- newObjectRef env target matcher <- evalExpr env matcher >>= evalMatcherWHNF let tryMatchClause (pattern, expr) cont = do - result <- patternMatch BFSMode env pattern target matcher + result <- patternMatch env pattern target matcher case result of MCons bindings _ -> evalExpr (extendEnv env bindings) expr MNil -> cont @@ -291,7 +286,8 @@ arg <- evalExpr env arg applyFunc func arg -evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info +evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env BFSMode info +evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info evalExpr env (GenerateArrayExpr (name:[]) (TupleExpr (size:[])) expr) = generateArray env name size expr @@ -415,34 +411,63 @@ -- Pattern Match -- -patternMatch :: PMMode -> Env -> EgisonPattern -> ObjectRef -> Matcher -> - EgisonM (MList EgisonM [Binding]) -patternMatch mode env pattern target matcher = - processMState mode (MState env [] [] [MAtom pattern target matcher]) >>= (processMStates mode) . (:[]) +patternMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch env pattern target matcher = processMStates [msingleton $ MState env [] [] [MAtom pattern target matcher]] -processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM [Binding]) -processMStates _ [] = return MNil -processMStates BFSMode streams = do - let (bindings, streams') = (catMaybes *** concat) . unzip $ map (processMStates' BFSMode) streams - mappend (fromList bindings) (sequence streams' >>= (processMStates BFSMode)) -processMStates DFSMode (stream:streams) = - case processMStates' DFSMode stream of - (Nothing, streams2) -> do streams' <- sequence streams2 - processMStates DFSMode (streams' ++ streams) - (Just bindings, streams2) -> do streams' <- sequence streams2 - mappend (fromList [bindings]) (processMStates DFSMode (streams' ++ streams)) +processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match) +processMStates [] = return MNil +processMStates streams = do + (matches, streams') <- extractMatches streams + nextStreamss <- mapM processMStates' streams' + let nextStreams = concat nextStreamss + mappend (fromList matches) $ processMStates nextStreams + where + processMStates' :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState] + processMStates' MNil = return [] + processMStates' stream@(MCons state _) = do + case topMAtom state of + Nothing -> processMStatesBFS stream + Just matom -> do + case pmMode (getMatcher matom) of + DFSMode -> processMStatesDFS stream + BFSMode -> processMStatesBFS stream + +processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)] +processMStatesDFS (MCons state stream) = do + stream' <- processMState state + newStream <- mappend stream' stream + return [newStream] + +processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)] +processMStatesBFS (MCons state stream) = do + newStream <- processMState state + newStream' <- stream + return [newStream, newStream'] -processMStates' :: PMMode -> MList EgisonM MatchingState -> (Maybe [Binding], [EgisonM (MList EgisonM MatchingState)]) -processMStates' _ MNil = (Nothing, []) -processMStates' _ (MCons (MState _ _ bindings []) states) = (Just bindings, [states]) -processMStates' mode (MCons state states) = (Nothing, [processMState mode state, states]) +extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState]) +extractMatches = extractMatches' ([], []) + where + extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState]) + extractMatches' (xs, ys) [] = return (xs, ys) + extractMatches' (xs, ys) ((MCons (MState _ _ bindings []) states):rest) = do + states' <- states + extractMatches' (xs ++ [bindings], ys ++ [states']) rest + extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest -processMState :: PMMode -> MatchingState -> EgisonM (MList EgisonM MatchingState) -processMState mode state = +topMAtom :: MatchingState -> Maybe MatchingTree +topMAtom (MState _ _ _ (mAtom@(MAtom _ _ _):_)) = return mAtom +topMAtom (MState _ _ _ ((MNode _ mstate):_)) = topMAtom mstate +topMAtom (MState _ _ _ _) = Nothing + +getMatcher :: MatchingTree -> Matcher +getMatcher (MAtom _ _ matcher) = matcher + +processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) +processMState state = do if isNotPat state then do let (state1, state2) = splitMState state - result <- processMStates mode [msingleton state1] + result <- processMStates [msingleton state1] case result of MNil -> return $ msingleton state2 _ -> return MNil @@ -458,7 +483,7 @@ (MState env loops bindings [MAtom pattern target matcher], MState env loops bindings trees) splitMState (MState env loops bindings ((MNode penv state) : trees)) = let (state1, state2) = splitMState state - in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees)) + in (MState env loops bindings [MNode penv state1], MState env loops bindings (MNode penv state2 : trees)) processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState' state@(MState _ _ _ []) = throwError $ strMsg "should not reach here" @@ -542,7 +567,7 @@ >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern target matcher):trees)) _ -> case matcher of - matcher@(UserMatcher _ _) -> do + matcher@(UserMatcher _ _ _) -> do (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher mfor targetss $ \ref -> do targets <- evalRef ref >>= fromTuple @@ -595,9 +620,7 @@ IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) _ -> throwError $ strMsg "something can only match with a pattern variable" --- _ -> throwError $ TypeMismatch "matcher" matcher -processMState' (MState env loops bindings ((MNode penv (MState _ _ _ [])):trees)) = - return $ msingleton $ MState env loops bindings trees +processMState' (MState env loops bindings ((MNode penv (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 @@ -622,7 +645,7 @@ inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher]) -inductiveMatch env pattern target (UserMatcher matcherEnv clauses) = do +inductiveMatch env pattern target (UserMatcher matcherEnv _ clauses) = do foldr tryPPMatchClause failPPPatternMatch clauses where tryPPMatchClause (pat, matchers, clauses) cont = do @@ -789,7 +812,7 @@ evalMatcherWHNF :: WHNFData -> EgisonM Matcher evalMatcherWHNF (Value matcher@Something) = return matcher -evalMatcherWHNF (Value matcher@(UserMatcher _ _)) = return matcher +evalMatcherWHNF (Value matcher@(UserMatcher _ _ _)) = return matcher evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms evalMatcherWHNF (Intermediate (ITuple refs)) = do whnfs <- mapM evalRef refs @@ -820,4 +843,3 @@ 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 @@ -13,6 +13,7 @@ DesugarM , runDesugarM , desugarTopExpr + , desugarExpr , desugar ) where @@ -24,9 +25,7 @@ import Data.Set (Set) import Data.Char (toUpper) import Control.Monad.Error -import Control.Monad.State import Control.Monad.Reader -import Control.Monad.Identity import Language.Egison.Types type Subst = [(String, EgisonExpr)] @@ -37,15 +36,17 @@ runDesugarM :: DesugarM a -> Fresh (Either EgisonError a) runDesugarM = runErrorT . flip runReaderT [] . unDesugarM -desugarTopExpr :: EgisonTopExpr -> DesugarM EgisonTopExpr +desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr desugarTopExpr (Define name expr) = do - expr' <- desugar expr + expr' <- liftEgisonM $ runDesugarM $ desugar expr return (Define name expr') desugarTopExpr (Test expr) = do - expr' <- desugar expr + expr' <- liftEgisonM $ runDesugarM $ desugar expr return (Test expr') desugarTopExpr expr = return expr +desugarExpr :: EgisonExpr -> EgisonM EgisonExpr +desugarExpr expr = liftEgisonM $ runDesugarM $ desugar expr desugar :: EgisonExpr -> DesugarM EgisonExpr desugar (AlgebraicDataMatcherExpr patterns) = do @@ -89,7 +90,7 @@ genMatcherClause pattern = do (ppat, matchers) <- genPrimitivePatPat pattern (dpat, body) <- genPrimitiveDataPat pattern - return (ppat, TupleExpr matchers, [(dpat, CollectionExpr (Sq.singleton . ElementExpr . TupleExpr $ body)), (PDWildCard, matchingFailure)]) + return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)]) where genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr]) @@ -108,13 +109,13 @@ genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause = - return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr . Sq.singleton $ ElementExpr (VarExpr "tgt"))]) + return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr [ElementExpr (VarExpr "tgt")])]) matchingSuccess :: EgisonExpr - matchingSuccess = CollectionExpr . Sq.singleton. ElementExpr $ TupleExpr [] + matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []] matchingFailure :: EgisonExpr - matchingFailure = CollectionExpr Sq.empty + matchingFailure = CollectionExpr [] desugar (MatchAllLambdaExpr matcher clause) = do name <- fresh @@ -144,18 +145,18 @@ exprs' <- mapM desugar exprs return $ TupleExpr exprs' -desugar expr@(CollectionExpr seq) = - case Sq.viewl seq of - EmptyL -> return expr - ElementExpr seqHead :< seqTail -> do - seqHead' <- desugar seqHead - (CollectionExpr seqTail') <- desugar (CollectionExpr seqTail) - return $ CollectionExpr (ElementExpr seqHead' <| seqTail') - SubCollectionExpr seqHead :< seqTail -> do - seqHead' <- desugar seqHead - (CollectionExpr seqTail') <- desugar (CollectionExpr seqTail) - return $ CollectionExpr (SubCollectionExpr seqHead' <| seqTail') +desugar expr@(CollectionExpr []) = return expr +desugar (CollectionExpr ((ElementExpr elm):inners)) = do + elm' <- desugar elm + (CollectionExpr inners') <- desugar (CollectionExpr inners) + return $ CollectionExpr (ElementExpr elm':inners') + +desugar (CollectionExpr ((SubCollectionExpr sub):inners)) = do + sub' <- desugar sub + (CollectionExpr inners') <- desugar (CollectionExpr inners) + return $ CollectionExpr (SubCollectionExpr sub':inners') + desugar (LambdaExpr names expr) = do expr' <- desugar expr return $ LambdaExpr names expr' @@ -197,6 +198,24 @@ expr' <- desugar expr return $ DoExpr binds' expr' +desugar (ApplyExpr (VarExpr "+") expr) = do + 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))]) + +desugar (ApplyExpr (VarExpr "-") expr) = do + expr' <- desugar expr + case expr' of + args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "-") args + (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "-"), x, (CollectionExpr (map ElementExpr args))]) + +desugar (ApplyExpr (VarExpr "*") expr) = do + 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))]) + desugar (ApplyExpr expr0 expr1) = do expr0' <- desugar expr0 expr1' <- desugar expr1 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 @@ -31,11 +31,9 @@ import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) import System.Directory (doesFileExist) -import System.IO 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) @@ -43,7 +41,6 @@ import Text.Parsec import Text.Parsec.String -import Text.Parsec.Combinator import qualified Text.Parsec.Token as P import Language.Egison.Types @@ -51,10 +48,10 @@ import Paths_egison (getDataFileName) readTopExprs :: String -> EgisonM [EgisonTopExpr] -readTopExprs = liftEgisonM . runDesugarM . either throwError (mapM desugarTopExpr) . parseTopExprs +readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs readTopExpr :: String -> EgisonM EgisonTopExpr -readTopExpr = liftEgisonM . runDesugarM . either throwError desugarTopExpr . parseTopExpr +readTopExpr = either throwError desugarTopExpr . parseTopExpr readExprs :: String -> EgisonM [EgisonExpr] readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs @@ -157,6 +154,7 @@ <|> matchAllLambdaExpr <|> matchLambdaExpr <|> matcherExpr + <|> matcherDFSExpr <|> applyExpr <|> algebraicDataMatcherExpr <|> generateArrayExpr @@ -174,7 +172,7 @@ tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace collectionExpr :: Parser EgisonExpr -collectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy innerExpr whiteSpace +collectionExpr = braces $ CollectionExpr <$> sepEndBy innerExpr whiteSpace where innerExpr :: Parser InnerExpr innerExpr = (char '@' >> SubCollectionExpr <$> expr) @@ -215,6 +213,9 @@ matcherExpr :: Parser EgisonExpr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses +matcherDFSExpr :: Parser EgisonExpr +matcherDFSExpr = keywordMatcher >> MatcherDFSExpr <$> ppMatchClauses + ppMatchClauses :: Parser MatcherInfo ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace @@ -489,6 +490,7 @@ , "match-all-lambda" , "match-lambda" , "matcher" + , "matcher-dfs" , "do" , "io" , "algebraic-data-matcher" @@ -538,14 +540,12 @@ keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda" keywordMatcher = reserved "matcher" +keywordMatcherDFS = reserved "matcher-dfs" keywordDo = reserved "do" keywordIo = reserved "io" 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 @@ -11,12 +11,10 @@ module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where import Control.Arrow -import Control.Applicative import Control.Monad.Error import Control.Monad.Trans.Maybe import Data.IORef -import qualified Data.Array as A import Data.Ratio import System.IO @@ -24,14 +22,7 @@ import qualified Data.Sequence as Sq -import System.IO.Unsafe -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BC import qualified Data.Text as T -import Data.Maybe - -import Control.Monad -- {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite 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 @@ -42,7 +42,9 @@ , extendEnv , refVar -- * Pattern matching + , Match , PMMode (..) + , pmMode , MatchingState (..) , MatchingTree (..) , PatternBinding (..) @@ -95,7 +97,6 @@ import qualified Data.HashMap.Strict as HashMap 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 @@ -130,7 +131,7 @@ | IndexedExpr EgisonExpr [EgisonExpr] | InductiveDataExpr String [EgisonExpr] | TupleExpr [EgisonExpr] - | CollectionExpr (Seq InnerExpr) + | CollectionExpr [InnerExpr] | ArrayExpr [EgisonExpr] | HashExpr [(EgisonExpr, EgisonExpr)] @@ -147,6 +148,7 @@ | MatchAllLambdaExpr EgisonExpr MatchClause | MatcherExpr MatcherInfo + | MatcherDFSExpr MatcherInfo | DoExpr [BindingExpr] EgisonExpr | IoExpr EgisonExpr @@ -228,7 +230,7 @@ | Array (IntMap EgisonValue) | IntHash (HashMap Integer EgisonValue) | StrHash (HashMap ByteString EgisonValue) - | UserMatcher Env MatcherInfo + | UserMatcher Env PMMode MatcherInfo | Func Env [String] EgisonExpr | PatternFunc Env [String] EgisonPattern | PrimitiveFunc PrimitiveFunc @@ -264,7 +266,7 @@ show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]" show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ B.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" - show (UserMatcher _ _) = "#" + show (UserMatcher _ _ _) = "#" show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)" show (PatternFunc _ _ _) = "#" show (PrimitiveFunc _) = "#" @@ -372,20 +374,20 @@ fromFloatValue val = throwError $ TypeMismatch "float" (Value val) fromPortValue :: EgisonValue -> Either EgisonError Handle -fromPortValue (Port handle) = return handle +fromPortValue (Port h) = return h fromPortValue val = throwError $ TypeMismatch "port" (Value val) -- -- Internal Data -- +-- |For memoization +type ObjectRef = IORef Object + data Object = Thunk (EgisonM WHNFData) | WHNF WHNFData --- |For memoization -type ObjectRef = IORef Object - data WHNFData = Intermediate Intermediate | Value EgisonValue @@ -411,11 +413,17 @@ show (Intermediate (IIntHash _)) = "{|...|}" show (Intermediate (IStrHash _)) = "{|...|}" +instance Show Object where + show (Thunk _) = "#" + show (WHNF whnf) = show whnf + -- -- Extract data from WHNF -- -class EgisonWHNF a where +class (Egison a) => EgisonWHNF a where + toWHNF :: a -> WHNFData fromWHNF :: WHNFData -> EgisonM a + toWHNF = Value . toEgison instance EgisonWHNF Char where fromWHNF = liftError . fromCharWHNF @@ -456,9 +464,13 @@ fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf fromPortWHNF :: WHNFData -> Either EgisonError Handle -fromPortWHNF (Value (Port handle)) = return handle +fromPortWHNF (Value (Port h)) = return h fromPortWHNF whnf = throwError $ TypeMismatch "port" whnf +class (EgisonWHNF a) => EgisonObject a where + toObject :: a -> Object + toObject = WHNF . toWHNF + -- -- Environment -- @@ -481,8 +493,15 @@ -- Pattern Match -- +type Match = [Binding] + data PMMode = BFSMode | DFSMode +pmMode :: Matcher -> PMMode +pmMode (UserMatcher _ mode _) = mode +pmMode (Tuple _) = BFSMode +pmMode Something = BFSMode + data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree] data MatchingTree = @@ -513,7 +532,7 @@ deriving Typeable instance Show EgisonError where - show (Parser error) = "Parse error at: " ++ error + show (Parser err) = "Parse error at: " ++ err show (UnboundVariable var) = "Unbound variable: " ++ var show (TypeMismatch expected found) = "Expected " ++ expected ++ ", but found: " ++ show found 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 @@ -16,12 +16,11 @@ import Language.Egison.Types import Language.Egison.Parser - -- |Get Egison expression from the prompt. We can handle multiline input. -getEgisonExpr :: String -> InputT IO (Maybe (Either EgisonTopExpr EgisonExpr)) +getEgisonExpr :: String -> InputT IO (Maybe (Either (String, EgisonTopExpr) (String, EgisonExpr))) getEgisonExpr prompt = getEgisonExpr' "" where - getEgisonExpr' :: String -> InputT IO (Maybe (Either EgisonTopExpr EgisonExpr)) + getEgisonExpr' :: String -> InputT IO (Maybe (Either (String, EgisonTopExpr) (String, EgisonExpr))) getEgisonExpr' prev = do mLine <- case prev of "" -> getInputLine prompt @@ -40,11 +39,11 @@ Left err -> do liftIO $ putStrLn $ show err getEgisonExpr prompt - Right expr -> return $ Just $ Right expr + Right expr -> return $ Just $ Right (input, expr) Left err -> do liftIO $ putStrLn $ show err getEgisonExpr prompt - Right topExpr -> return $ Just $ Left topExpr + Right topExpr -> return $ Just $ Left (input, topExpr) -- |Complete Egison keywords 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 @@ -39,7 +39,7 @@ (define $divisor? (lambda [$n $d] - (eq-i? 0 (remainder n d)))) + (eq? 0 (remainder n d)))) (define $gcd