diff --git a/benchmark/Benchmark-Collection.hs b/benchmark/Benchmark-Collection.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark-Collection.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleInstances #-} +module Main where +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.Error +import Control.Applicative +import Control.DeepSeq (NFData(rnf)) +import Criterion.Main +import Criterion.Config +import Text.Parsec +import Text.Parsec.ByteString + +import Language.Egison + +runEgisonFile :: String -> IO (Either EgisonError Env) +runEgisonFile path = do + env <- loadPrimitives nullEnv >>= loadLibraries + evalEgisonTopExpr env $ LoadFile path + +config :: Config +config = defaultConfig { cfgSamples = ljust 3 + , cfgPerformGC = ljust True } + +main :: IO () +main = defaultMainWith config (return ()) [ + bgroup "collection" [ bench "cons-bench" $ runEgisonFile "benchmark/collection-bench-cons.egi" + , bench "cons-bench-large" $ runEgisonFile "benchmark/collection-bench-cons-large.egi" + , bench "snoc-bench" $ runEgisonFile "benchmark/collection-bench-snoc.egi" + ] + ] + diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,11 +1,11 @@ Name: egison -Version: 3.0.2 +Version: 3.0.3 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. With Egison, you can represent pattern matching for unfree data intuitively, especially for collection data, such as lists, multisets, sets, and so on. - This package include sample Egison program codes "*-test.egi" in "sample/" directory. + This package include sample Egison programs "*-test.egi" in "sample/" directory. This package also include Emacs Lisp file "egison-mode.el" in "elisp/" directory. Homepage: http://egison.pira.jp License: MIT @@ -46,6 +46,12 @@ 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, parsec >= 3.0 + +Benchmark benchmark-collection + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: benchmark + Main-Is: Benchmark-Collection.hs Build-Depends: egison, base >= 4.0 && < 5, deepseq, criterion >= 0.5, transformers, mtl, parsec >= 3.0 Executable egison 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 @@ -1,11 +1,17 @@ +{-# Language TupleSections #-} module Language.Egison.Core where +import Prelude hiding (mapM) + import Control.Arrow import Control.Applicative -import Control.Monad.Error -import Control.Monad.State +import Control.Monad.Error hiding (mapM) +import Control.Monad.State hiding (mapM) import Control.Monad.Trans.Maybe +import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) +import qualified Data.Sequence as Sq +import Data.Traversable (mapM) import Data.IORef import Data.List import Data.Maybe @@ -46,7 +52,7 @@ return env evalTopExpr env (Execute argv) = do main <- refVar env "main" >>= evalRef - io <- applyFunc main $ Value $ Collection $ map String argv + io <- applyFunc main $ Value $ Collection $ Sq.fromList $ map String argv case io of Value (IOFunc m) -> m >> return env _ -> throwError $ TypeMismatch "io" main @@ -86,12 +92,14 @@ evalExpr env (TupleExpr exprs) = Intermediate . ITuple <$> mapM (newThunk env) exprs -evalExpr _ (CollectionExpr []) = return . Value $ Collection [] evalExpr env (CollectionExpr inners) = - Intermediate . ICollection <$> mapM fromInnerExpr inners - where - fromInnerExpr (ElementExpr expr) = IElement <$> newThunk env expr - fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newThunk env expr + if Sq.null inners then + return . Value $ Collection Sq.empty + else + Intermediate . ICollection <$> mapM fromInnerExpr inners + where + fromInnerExpr (ElementExpr expr) = IElement <$> newThunk env expr + fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newThunk env expr evalExpr env (ArrayExpr exprs) = do ref' <- mapM (newThunk env) exprs @@ -166,11 +174,11 @@ mmap (flip evalExpr expr . extendEnv env) result >>= fromMList where fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData - fromMList MNil = return . Value $ Collection [] + fromMList MNil = return . Value $ Collection Sq.empty fromMList (MCons val m) = do head <- IElement <$> newEvaluatedThunk val tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList) - return . Intermediate $ ICollection [head, tail] + return . Intermediate $ ICollection $ Sq.fromList [head, tail] evalExpr env (MatchExpr target matcher clauses) = do target <- newThunk env target @@ -242,7 +250,7 @@ refs' <- mapM evalRef' $ IntMap.elems refs return $ Array $ IntMap.fromList $ zip (enumFromTo 1 (IntMap.size refs)) refs' evalDeep (Intermediate (ITuple refs)) = Tuple <$> mapM evalRef' refs -evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef') +evalDeep coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRef' . Sq.fromList) applyFunc :: WHNFData -> WHNFData -> EgisonM WHNFData applyFunc (Value (Func env [name] body)) arg = do @@ -308,9 +316,9 @@ fromTuple val = return <$> newEvaluatedThunk val fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef) -fromCollection (Value (Collection [])) = return MNil fromCollection (Value (Collection vals)) = - fromList <$> mapM (newEvaluatedThunk . Value) vals + if Sq.null vals then return MNil + else fromSeq <$> mapM (newEvaluatedThunk . Value) vals fromCollection coll@(Intermediate (ICollection _)) = newEvaluatedThunk coll >>= fromCollection' where @@ -330,7 +338,7 @@ patternMatch :: Env -> EgisonPattern -> ObjectRef -> WHNFData -> EgisonM (MList EgisonM [Binding]) patternMatch env pattern target matcher = - processMState (MState env [] [MAtom pattern target matcher]) >>= processMStates . (:[]) + processMState (MState env [] [] [MAtom pattern target matcher]) >>= processMStates . (:[]) processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM [Binding]) processMStates [] = return MNil @@ -341,13 +349,13 @@ processMStates' :: MList EgisonM MatchingState -> (Maybe [Binding], [EgisonM (MList EgisonM MatchingState)]) processMStates' MNil = (Nothing, []) - processMStates' (MCons (MState _ bindings []) states) = (Just bindings, [states]) + processMStates' (MCons (MState _ _ bindings []) states) = (Just bindings, [states]) processMStates' (MCons state states) = (Nothing, [processMState state, states]) processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) -processMState state@(MState env bindings []) = throwError $ strMsg "should not reach here" -processMState (MState env bindings ((MAtom pattern target matcher):trees)) = do - let env' = extendEnv env bindings +processMState state@(MState _ _ _ []) = throwError $ strMsg "should not reach here" +processMState (MState env loops bindings ((MAtom pattern target matcher):trees)) = do + let env' = extendEnv env (bindings ++ map (\(LoopContext binding _ _ _) -> binding) loops) case pattern of VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function" ApplyPat func args -> do @@ -355,27 +363,54 @@ case func of Value (PatternFunc env names expr) -> let penv = zip names args - in return $ msingleton $ MState env bindings (MNode penv (MState env [] [MAtom expr target matcher]) : trees) + in return $ msingleton $ MState env loops bindings (MNode penv (MState env [] [] [MAtom expr target matcher]) : trees) _ -> throwError $ TypeMismatch "pattern constructor" func + + LoopPat name range pat pat' -> do + result <- runMaybeT $ lift (evalExpr env range) >>= unconsCollection' + case result of + Nothing -> return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) + Just (head, tail) -> + let loops' = LoopContext (name, head) tail pat pat' : loops + in return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) + ContPat -> + case loops of + [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern" + LoopContext (name, _) coll pat pat' : loops -> do + result <- runMaybeT $ unconsCollection coll + case result of + Nothing -> return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees) + Just (head, tail) -> + let loops' = LoopContext (name, head) tail pat pat' : loops + in return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees) + IndexedPat (PatVar name) indices -> do indices <- mapM (evalExpr env' >=> liftError . liftM fromInteger . fromIntegerValue) indices - let (index:_) = indices case lookup name bindings of Just ref -> do - val <- evalRef ref - case val of - Intermediate (IArray val) -> do - obj <- newEvaluatedThunk $ Intermediate . IArray $ IntMap.insert index target val - return $ msingleton $ MState env (subst name obj bindings) trees - Value (Array val) -> do - keys' <- return $ IntMap.keys val - vals' <- mapM (newEvaluatedThunk . Value) $ IntMap.elems val - obj <- newEvaluatedThunk $ Intermediate . IArray $ IntMap.insert index target (IntMap.fromList $ zip keys' vals') - return $ msingleton $ MState env (subst name obj bindings) trees + obj <- evalRef ref >>= flip updateArray indices >>= newEvaluatedThunk + return $ msingleton $ MState env loops (subst name obj bindings) trees Nothing -> do - obj <- newEvaluatedThunk $ Intermediate . IArray $ IntMap.singleton index target - return $ msingleton $ MState env ((name, obj):bindings) trees + obj <- updateArray (Value $ Array IntMap.empty) indices >>= newEvaluatedThunk + 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 >>= newEvaluatedThunk + return . Intermediate . IArray $ IntMap.insert index ref ary + updateArray (Value (Array ary)) [index] = do + keys <- return $ IntMap.keys ary + vals <- mapM (newEvaluatedThunk . 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 >>= newEvaluatedThunk + keys <- return $ IntMap.keys ary + vals <- mapM (newEvaluatedThunk . Value) $ IntMap.elems ary + return . Intermediate . IArray $ IntMap.insert index ref (IntMap.fromList $ zip keys vals) 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) @@ -385,62 +420,62 @@ matchers <- fromTuple matcher >>= mapM evalRef targets <- evalRef target >>= fromTuple let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ msingleton $ MState env bindings trees' - WildCard -> return $ msingleton $ MState env bindings trees + return $ msingleton $ MState env loops bindings trees' + WildCard -> return $ msingleton $ MState env loops bindings trees AndPat patterns -> let trees' = map (\pattern -> MAtom pattern target matcher) patterns ++ trees - in return $ msingleton $ MState env bindings trees' + in return $ msingleton $ MState env loops bindings trees' OrPat patterns -> return $ fromList $ flip map patterns $ \pattern -> - MState env bindings (MAtom pattern target matcher : trees) + MState env loops bindings (MAtom pattern target matcher : trees) NotPat pattern -> do - results <- processMState (MState env bindings [MAtom pattern target matcher]) + results <- processMState (MState env loops bindings [MAtom pattern target matcher]) case results of - MNil -> return $ msingleton $ MState env bindings trees + MNil -> return $ msingleton $ MState env loops bindings trees _ -> return $ MNil CutPat pattern -> -- TEMPORARY ignoring cut patterns - return $ msingleton (MState env bindings ((MAtom pattern target matcher):trees)) + return $ msingleton (MState env loops bindings ((MAtom pattern target matcher):trees)) PredPat pred -> do func <- evalExpr env' pred arg <- evalRef target result <- applyFunc func arg >>= liftError . fromBoolValue - if result then return $ msingleton $ (MState env bindings trees) + if result then return $ msingleton $ (MState env loops bindings trees) else return MNil _ -> case matcher of Value Something -> case pattern of PatVar name -> do - return $ msingleton $ MState env ((name, target):bindings) trees + return $ msingleton $ MState env loops ((name, target):bindings) trees _ -> throwError $ strMsg "something can only match with a pattern variable" Value (Matcher matcher) -> do (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher mfor targetss $ \ref -> do targets <- evalRef ref >>= fromTuple let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ MState env bindings trees' + return $ MState env loops bindings trees' _ -> throwError $ TypeMismatch "matcher" matcher -processMState (MState env bindings ((MNode penv (MState _ _ [])):trees)) = - return $ msingleton $ MState env bindings trees -processMState (MState env bindings ((MNode penv state@(MState env' bindings' (tree:trees')):trees))) = do +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 case pattern of VarPat name -> case lookup name penv of Just pattern -> - return $ msingleton $ MState env bindings (MAtom pattern target matcher:MNode penv (MState env' bindings' trees'):trees) + return $ msingleton $ MState env loops bindings (MAtom pattern target matcher:MNode penv (MState env' loops' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name - IndexedPat (VarPat name) (index:_) -> -- cannot use multiple indices + IndexedPat (VarPat name) indices -> -- cannot use multiple indices case lookup name penv of Just pattern -> do - let env'' = extendEnv env' bindings - index <- evalExpr env'' index >>= liftError . fromIntegerValue - let pattern' = IndexedPat pattern [IntegerExpr index] - return $ msingleton $ MState env bindings (MAtom pattern' target matcher:MNode penv (MState env' bindings' trees'):trees) + let env'' = extendEnv env' (bindings' ++ map (\(LoopContext binding _ _ _) -> binding) loops') + indices <- mapM (evalExpr env'' >=> liftError . liftM fromInteger . fromIntegerValue) indices + let pattern' = IndexedPat pattern $ map IntegerExpr indices + return $ msingleton $ MState env loops bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' bindings' trees'):trees) Nothing -> throwError $ UnboundVariable name - _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv) - _ -> processMState state >>= mmap (return . MState env bindings . (: trees) . MNode penv) + _ -> processMState state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv) + _ -> processMState state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv) inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [WHNFData]) @@ -507,7 +542,7 @@ isEqual <- lift $ (==) <$> evalExpr' nullEnv expr <*> pure target if isEqual then return [] else matchFail -expandCollection :: WHNFData -> EgisonM [Inner] +expandCollection :: WHNFData -> EgisonM (Seq Inner) expandCollection (Value (Collection vals)) = mapM (liftM IElement . newEvaluatedThunk . Value) vals expandCollection (Intermediate (ICollection inners)) = return inners @@ -517,47 +552,58 @@ isEmptyCollection ref = evalRef ref >>= isEmptyCollection' where isEmptyCollection' :: WHNFData -> EgisonM Bool - isEmptyCollection' (Value (Collection [])) = return True - isEmptyCollection' (Intermediate (ICollection [])) = return True - isEmptyCollection' (Intermediate (ICollection ((ISubCollection ref'):inners))) = do - inners' <- evalRef ref' >>= expandCollection - let coll = Intermediate (ICollection (inners' ++ inners)) - writeThunk ref coll - isEmptyCollection' coll + isEmptyCollection' (Value (Collection col)) = return $ Sq.null col + isEmptyCollection' (Intermediate (ICollection ic)) = + case Sq.viewl ic of + EmptyL -> return True + (ISubCollection ref') :< inners -> do + inners' <- evalRef ref' >>= expandCollection + let coll = Intermediate (ICollection (inners' >< inners)) + writeThunk ref coll + isEmptyCollection' coll + _ -> return False isEmptyCollection' _ = return False unconsCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef) unconsCollection ref = lift (evalRef ref) >>= unconsCollection' - where - unconsCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef) - unconsCollection' (Value (Collection (val:vals))) = - lift $ (,) <$> newEvaluatedThunk (Value val) - <*> newEvaluatedThunk (Value $ Collection vals) - unconsCollection' (Intermediate (ICollection ((IElement ref'):inners))) = - lift $ (,) ref' <$> newEvaluatedThunk (Intermediate $ ICollection inners) - unconsCollection' (Intermediate (ICollection ((ISubCollection ref'):inners))) = do - inners' <- lift $ evalRef ref' >>= expandCollection - let coll = Intermediate (ICollection (inners' ++ inners)) - lift $ writeThunk ref coll - unconsCollection' coll - unconsCollection' _ = matchFail +unconsCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef) +unconsCollection' (Value (Collection col)) = + case Sq.viewl col of + EmptyL -> matchFail + val :< vals -> + lift $ (,) <$> newEvaluatedThunk (Value val) + <*> newEvaluatedThunk (Value $ Collection vals) +unconsCollection' (Intermediate (ICollection ic)) = + case Sq.viewl ic of + EmptyL -> matchFail + (IElement ref') :< inners -> + lift $ (ref', ) <$> newEvaluatedThunk (Intermediate $ ICollection inners) + (ISubCollection ref') :< inners -> do + inners' <- lift $ evalRef ref' >>= expandCollection + let coll = Intermediate (ICollection (inners' >< inners)) + lift $ writeThunk ref' coll + unconsCollection' coll +unconsCollection' _ = matchFail + unsnocCollection :: ObjectRef -> MatchM (ObjectRef, ObjectRef) unsnocCollection ref = lift (evalRef ref) >>= unsnocCollection' - where - unsnocCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef) - unsnocCollection' (Value (Collection [])) = matchFail - unsnocCollection' (Value (Collection vals)) = - lift $ (,) <$> newEvaluatedThunk (Value . Collection $ init vals) - <*> newEvaluatedThunk (Value $ last vals) - unsnocCollection' (Intermediate (ICollection [])) = matchFail - unsnocCollection' (Intermediate (ICollection inners)) = - case last inners of - IElement ref' -> - lift $ (,) <$> newEvaluatedThunk (Intermediate . ICollection $ init inners) - <*> pure ref' - ISubCollection ref' -> do - inners' <- lift $ evalRef ref' >>= expandCollection - let coll = Intermediate (ICollection (init inners ++ inners')) - lift $ writeThunk ref coll - unsnocCollection' coll + where + unsnocCollection' :: WHNFData -> MatchM (ObjectRef, ObjectRef) + unsnocCollection' (Value (Collection col)) = + case Sq.viewr col of + EmptyR -> matchFail + vals :> val -> + lift $ (,) <$> newEvaluatedThunk (Value $ Collection vals) + <*> newEvaluatedThunk (Value val) + unsnocCollection' (Intermediate (ICollection ic)) = + case Sq.viewr ic of + EmptyR -> matchFail + inners :> (IElement ref') -> + lift $ (, ref') <$> newEvaluatedThunk (Intermediate $ ICollection inners) + inners :> (ISubCollection ref') -> do + inners' <- lift $ evalRef ref' >>= expandCollection + let coll = Intermediate (ICollection (inners >< inners')) + lift $ writeThunk ref coll + unsnocCollection' coll + unsnocCollection' _ = matchFail 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 @@ -2,6 +2,8 @@ module Language.Egison.Desugar where import Control.Applicative (Applicative) import Control.Applicative ((<$>), (<*>), (<*), (*>), pure) +import qualified Data.Sequence as Sq +import Data.Sequence (ViewL(..), (<|)) import Data.Char (toUpper) import Control.Monad.Error import Control.Monad.State @@ -72,7 +74,7 @@ genMatcherClause pattern = do (ppat, matchers) <- genPrimitivePatPat pattern (dpat, body) <- genPrimitiveDataPat pattern - return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)]) + return (ppat, TupleExpr matchers, [(dpat, CollectionExpr (Sq.singleton . ElementExpr . TupleExpr $ body)), (PDWildCard, matchingFailure)]) where genPrimitivePatPat :: (String, [EgisonExpr]) -> DesugarM (PrimitivePatPattern, [EgisonExpr]) @@ -91,13 +93,13 @@ genSomethingClause :: DesugarM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) genSomethingClause = - return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr $ [ElementExpr (VarExpr "tgt")])]) + return (PPPatVar, (TupleExpr [SomethingExpr]), [(PDPatVar "tgt", CollectionExpr . Sq.singleton $ ElementExpr (VarExpr "tgt"))]) matchingSuccess :: EgisonExpr - matchingSuccess = CollectionExpr $ [ElementExpr $ TupleExpr []] + matchingSuccess = CollectionExpr . Sq.singleton. ElementExpr $ TupleExpr [] matchingFailure :: EgisonExpr - matchingFailure = CollectionExpr [] + matchingFailure = CollectionExpr Sq.empty desugar (MatchLambdaExpr matcher clauses) = do name <- fresh @@ -122,17 +124,17 @@ exprs' <- mapM desugar exprs return $ TupleExpr exprs' -desugar (CollectionExpr ((ElementExpr expr):rest)) = do - expr' <- desugar expr - (CollectionExpr rest') <- desugar (CollectionExpr rest) - return $ CollectionExpr ((ElementExpr expr'):rest') - -desugar (CollectionExpr ((SubCollectionExpr expr):rest)) = do - expr' <- desugar expr - (CollectionExpr rest') <- desugar (CollectionExpr rest) - return $ CollectionExpr ((SubCollectionExpr expr'):rest') - -desugar expr@(CollectionExpr []) = return expr +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 (LambdaExpr names expr) = do expr' <- desugar expr @@ -220,6 +222,8 @@ IndexedPat <$> desugarPattern pattern <*> mapM desugar exprs desugarPattern (ApplyPat expr patterns) = ApplyPat <$> desugar expr <*> mapM desugarPattern patterns +desugarPattern (LoopPat name expr pattern1 pattern2) = + LoopPat name <$> desugar expr <*> desugarPattern pattern1 <*> desugarPattern pattern2 desugarPattern pattern = return pattern desugarBinding :: BindingExpr -> DesugarM BindingExpr 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 @@ -9,6 +9,7 @@ import Control.Monad.State import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) +import qualified Data.Sequence as Sq import Data.Either import Data.Set (Set) import Data.Char (isLower, isUpper) @@ -89,7 +90,6 @@ <|> parsePatternFunctionExpr <|> parseLetRecExpr <|> parseLetExpr - <|> parseIndexLoopExpr <|> parseDoExpr <|> parseMatchAllExpr <|> parseMatchExpr @@ -112,7 +112,7 @@ parseTupleExpr = brackets $ TupleExpr <$> sepEndBy parseExpr whiteSpace parseCollectionExpr :: Parser EgisonExpr -parseCollectionExpr = braces $ CollectionExpr <$> sepEndBy parseInnerExpr whiteSpace +parseCollectionExpr = braces $ CollectionExpr . Sq.fromList <$> sepEndBy parseInnerExpr whiteSpace where parseInnerExpr :: Parser InnerExpr parseInnerExpr = (char '@' >> SubCollectionExpr <$> parseExpr) @@ -214,10 +214,6 @@ parseVarName :: Parser String parseVarName = char '$' >> ident -parseIndexLoopExpr :: Parser EgisonExpr -parseIndexLoopExpr = keywordIndexLoop >> IndexLoopExpr <$> parseVarName <*> parseVarName <*> parseVarName - <*> parseExpr <*> parseExpr <*> parseExpr <*> parseExpr - parseApplyExpr :: Parser EgisonExpr parseApplyExpr = (keywordApply >> ApplyExpr <$> parseExpr <*> parseExpr) <|> parseApplyExpr' @@ -281,9 +277,11 @@ <|> parseNotPat <|> parseTuplePat <|> parseInductivePat + <|> parseContPat <|> parens (parseAndPat <|> parseOrPat - <|> parseApplyPat) + <|> parseApplyPat + <|> parseLoopPat) parseWildCard :: Parser EgisonPattern parseWildCard = reservedOp "_" >> pure WildCard @@ -312,6 +310,9 @@ parseInductivePat :: Parser EgisonPattern parseInductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy parsePattern whiteSpace +parseContPat :: Parser EgisonPattern +parseContPat = reservedOp "..." >> pure ContPat + parseAndPat :: Parser EgisonPattern parseAndPat = reservedOp "&" >> AndPat <$> sepEndBy parsePattern whiteSpace @@ -321,6 +322,9 @@ parseApplyPat :: Parser EgisonPattern parseApplyPat = ApplyPat <$> parseExpr <*> sepEndBy parsePattern whiteSpace +parseLoopPat :: Parser EgisonPattern +parseLoopPat = keywordLoop >> LoopPat <$> parseVarName <*> parseExpr <*> parsePattern <*> parsePattern + -- Constants parseConstantExpr :: Parser EgisonExpr @@ -385,12 +389,12 @@ , "pattern-constructor" , "letrec" , "let" - , "index-loop" + , "loop" , "match-all" + , "match-lambda" , "match" , "matcher" , "do" - , "function" , "algebraic-data-matcher" , "generate-array" , "array-size" @@ -407,7 +411,8 @@ , "^" , "!" , "," - , "@"] + , "@" + , "..."] reserved :: String -> Parser () reserved = P.reserved lexer @@ -428,7 +433,7 @@ keywordPatternFunction = reserved "pattern-function" keywordLetRec = reserved "letrec" keywordLet = reserved "let" -keywordIndexLoop = reserved "index-loop" +keywordLoop = reserved "loop" keywordMatchAll = reserved "match-all" keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda" 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 @@ -2,12 +2,17 @@ MultiParamTypeClasses, UndecidableInstances #-} module Language.Egison.Types where +import Prelude hiding (foldr) + import Control.Applicative import Control.Monad.Error import Control.Monad.State import Control.Monad.Identity import Control.Monad.Trans.Maybe +import Data.Foldable (foldr, toList) +import qualified Data.Sequence as Sq +import Data.Sequence (Seq) import Data.IORef import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -41,7 +46,7 @@ | IndexedExpr EgisonExpr [EgisonExpr] | InductiveDataExpr String [EgisonExpr] | TupleExpr [EgisonExpr] - | CollectionExpr [InnerExpr] + | CollectionExpr (Seq InnerExpr) | ArrayExpr [EgisonExpr] | LambdaExpr [String] EgisonExpr @@ -51,8 +56,6 @@ | LetExpr [BindingExpr] EgisonExpr | LetRecExpr [BindingExpr] EgisonExpr - | IndexLoopExpr String String String EgisonExpr EgisonExpr EgisonExpr EgisonExpr - | MatchExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllExpr EgisonExpr EgisonExpr MatchClause | MatchLambdaExpr EgisonExpr [MatchClause] @@ -68,6 +71,7 @@ | ArraySizeExpr EgisonExpr | ArrayRefExpr EgisonExpr EgisonExpr + | ValueExpr EgisonValue | SomethingExpr | UndefinedExpr deriving (Show) @@ -90,6 +94,8 @@ | TuplePat [EgisonPattern] | InductivePat String [EgisonPattern] | ApplyPat EgisonExpr [EgisonPattern] + | LoopPat String EgisonExpr EgisonPattern EgisonPattern + | ContPat deriving (Show) data PrimitivePatPattern = @@ -127,7 +133,7 @@ | Float Double | InductiveData String [EgisonValue] | Tuple [EgisonValue] - | Collection [EgisonValue] + | Collection (Seq EgisonValue) | Array (IntMap EgisonValue) | Matcher Matcher | Func Env [String] EgisonExpr @@ -152,7 +158,7 @@ show (InductiveData name []) = "<" ++ name ++ ">" show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">" show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]" - show (Collection vals) = "{" ++ unwords (map show vals) ++ "}" + show (Collection vals) = "{" ++ unwords (map show (toList vals)) ++ "}" show (Array vals) = "[|" ++ unwords (map show $ IntMap.elems vals) ++ "|]" show (Matcher _) = "#" show (Func _ names _) = "(lambda [" ++ unwords names ++ "] ...)" @@ -194,13 +200,13 @@ data Intermediate = IInductiveData String [ObjectRef] | ITuple [ObjectRef] - | ICollection [Inner] + | ICollection (Seq Inner) | IArray (IntMap ObjectRef) data Inner = IElement ObjectRef | ISubCollection ObjectRef - + instance Show WHNFData where show (Value val) = show val show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>" @@ -266,7 +272,7 @@ -- Pattern Match -- -data MatchingState = MState Env [Binding] [MatchingTree] +data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree] data MatchingTree = MAtom EgisonPattern ObjectRef WHNFData @@ -274,6 +280,8 @@ type PatternBinding = (Var, EgisonPattern) +data LoopContext = LoopContext (String, ObjectRef) ObjectRef EgisonPattern EgisonPattern + -- -- Errors -- @@ -364,6 +372,10 @@ fromList :: Monad m => [a] -> MList m a fromList = foldr f MNil + where f x xs = MCons x $ return xs + +fromSeq :: Monad m => Seq a -> MList m a +fromSeq = foldr f MNil where f x xs = MCons x $ return xs fromMList :: Monad m => MList m a -> m [a]