egison 3.0.2 → 3.0.3

raw patch · 6 files changed

+230/−127 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• benchmark/Benchmark-Collection.hs +30/−0
• egison.cabal +8/−2
• hs-src/Language/Egison/Core.hs +137/−91
• hs-src/Language/Egison/Desugar.hs +19/−15
• hs-src/Language/Egison/Parser.hs +16/−11
• hs-src/Language/Egison/Types.hs +20/−8

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

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

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

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

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

@@ -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 _) = "#<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]