packages feed

egison 3.2.21 → 3.2.22

raw patch · 6 files changed

+187/−143 lines, 6 files

Files

egison.cabal view
@@ -1,5 +1,5 @@ Name:                egison-Version:             3.2.21+Version:             3.2.22 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.
hs-src/Language/Egison/Core.hs view
@@ -38,7 +38,7 @@ import Control.Arrow import Control.Applicative import Control.Monad.Error hiding (mapM)-import Control.Monad.State hiding (mapM)+import Control.Monad.State hiding (mapM, state) import Control.Monad.Trans.Maybe  import Data.Sequence (Seq, ViewL(..), ViewR(..), (><))@@ -420,20 +420,25 @@ 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+  (matches, streams') <- mapM processMStates' streams >>= extractMatches . concat+  mappend (fromList matches) $ processMStates streams'++processMStates' :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]+processMStates' MNil = return []+processMStates' stream@(MCons state _) =+  case pmMode (getMatcher (topMAtom state)) of+    DFSMode -> processMStatesDFS stream+    BFSMode -> processMStatesBFS stream++extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])+extractMatches = extractMatches' ([], [])  where-  processMStates' :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]-  processMStates' MNil = return []-  processMStates' stream@(MCons state _) =-    case topMAtom state of-      Nothing -> processMStatesDFS stream-      Just matom -> do-        case pmMode (getMatcher matom) of-          DFSMode -> processMStatesDFS stream-          BFSMode -> processMStatesBFS stream+  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            processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [(MList EgisonM MatchingState)] processMStatesDFS (MCons state stream) = do@@ -447,20 +452,9 @@   newStream' <- stream   return [newStream, newStream'] -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--topMAtom :: MatchingState -> Maybe MatchingTree-topMAtom (MState _ _ _ (mAtom@(MAtom _ _ _):_)) = return mAtom+topMAtom :: MatchingState -> MatchingTree+topMAtom (MState _ _ _ (mAtom@(MAtom _ _ _):_)) = mAtom topMAtom (MState _ _ _ ((MNode _ mstate):_)) = topMAtom mstate-topMAtom (MState _ _ _ _) = Nothing  getMatcher :: MatchingTree -> Matcher getMatcher (MAtom _ _ matcher) = matcher@@ -477,106 +471,137 @@     else processMState' state  where   isNotPat :: MatchingState -> Bool-  isNotPat (MState _ _ _ ((MAtom (NotPat _) _ _) : _)) = True-  isNotPat (MState _ _ _ ((MNode _ state) : _)) = isNotPat state-  isNotPat _ = False-+  isNotPat state = case topMAtom state of+                     MAtom (NotPat _) _ _ -> True+                     _ -> False   splitMState :: MatchingState -> (MatchingState, MatchingState)   splitMState (MState env loops bindings ((MAtom (NotPat pattern) target matcher) : trees)) =     (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+  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))  processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState' state@(MState _ _ _ []) = throwError $ strMsg "should not reach here"+processMState' (MState _ _ _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)"++processMState' (MState _ _ _ ((MNode _ (MState _ _ _ [])):_)) = throwError $ EgisonBug "should not reach here (empty matching-node)"++processMState' (MState env loops bindings (MNode penv (MState env' loops' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) = do+  case lookup name penv of+    Just pattern ->+      case trees' of+        [] -> return $ msingleton $ MState env loops bindings ((MAtom pattern target matcher):trees)+        _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target matcher):(MNode penv (MState env' loops' bindings' trees')):trees)+    Nothing -> throwError $ UnboundVariable name++processMState' (MState env loops bindings (MNode penv (MState env' loops' bindings' ((MAtom (IndexedPat (VarPat name) indices) target matcher):trees')):trees)) = do+  case lookup name penv of+    Just pattern -> do+      let env'' = extendEnvForNonLinearPatterns env' bindings loops'+      indices' <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices+      let pattern' = IndexedPat pattern $ map IntegerExpr indices'+      case trees' of+        [] -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):trees)+        _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):(MNode penv (MState env' loops' bindings' trees')):trees)+    Nothing -> throwError $ UnboundVariable name++processMState' (MState env loops bindings ((MNode penv state):trees)) = do+  processMState' state >>= mmap (\state' -> case state' of+                                              MState _ _ _ [] -> return $ MState env loops bindings trees+                                              _ -> (return . MState env loops bindings . (: trees) . MNode penv) state')+ processMState' (MState env loops bindings ((MAtom pattern target matcher):trees)) = do-  let env' = extendEnv env (bindings ++ map (\lc -> case lc of-                                                      (LoopContextConstant binding _ _ _) -> binding-                                                      (LoopContextVariable binding _ _ _) -> binding) loops)+  let env' = extendEnvForNonLinearPatterns env bindings loops   case pattern of+    NotPat _ -> throwError $ EgisonBug "should not reach here (not pattern)"     VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function"++    LetPat bindings' pattern' ->+      let extractBindings ([name], expr) =+            makeBindings [name] . (:[]) <$> newObjectRef env' expr+          extractBindings (names, expr) =+            makeBindings names <$> (evalExpr env' expr >>= fromTuple)+      in+       liftM concat (mapM extractBindings bindings')+         >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern' target matcher):trees))+    PredPat predicate -> do+      func <- evalExpr env' predicate+      arg <- evalRef target+      result <- applyFunc func arg >>= fromWHNF+      if result then return $ msingleton $ (MState env loops bindings trees)+                else return MNil+     ApplyPat func args -> do-      func <- evalExpr env' func-      case func of+      func' <- evalExpr env' func+      case func' of         Value (PatternFunc env'' names expr) ->           let penv = zip names args           in return $ msingleton $ MState env loops bindings (MNode penv (MState env'' [] [] [MAtom expr target matcher]) : trees)-        _ -> throwError $ TypeMismatch "pattern constructor" func+        _ -> throwError $ TypeMismatch "pattern constructor" func'     -    LoopPat name (LoopRangeConstant start end) pat pat' -> do-      startNum <- evalExpr env' start >>= fromWHNF-      endNum <- evalExpr env' end >>= fromWHNF-      if startNum > endNum-        then do-          return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)-        else do-          startNumRef <- newEvalutedObjectRef $ Value $ Integer startNum-          let loops' = LoopContextConstant (name, startNumRef) endNum pat pat' : loops-          return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)-    LoopPat name (LoopRangeVariable start lastNumPat) pat pat' -> do+    LoopPat loopMode name (LoopRange start endPat) pat pat' -> do       startNum <- evalExpr env' start >>= fromWHNF-      startNumRef <- newEvalutedObjectRef $ Value $ Integer startNum-      lastNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum - 1)-      return $ fromList [MState env loops bindings (MAtom lastNumPat lastNumRef Something : MAtom pat' target matcher : trees),-                         MState env (LoopContextVariable (name, startNumRef) lastNumPat pat pat' : loops) bindings (MAtom pat target matcher : trees)]+      startNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum - 1)+      return $ msingleton $ MState env ((LoopContext loopMode (name, startNumRef) (False, endPat) pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)     ContPat ->       case loops of         [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern"-        LoopContextConstant (name, startNumRef) endNum pat pat' : loops -> do+        LoopContext SmartMode (name, startNumRef) (matched, endPat) pat pat' : loops' -> do           startNum <- evalRef startNumRef >>= fromWHNF-          let nextNum = startNum + 1-          if nextNum > endNum-            then return $ msingleton $ MState env loops bindings (MAtom pat' target matcher : trees)-            else do-              nextNumRef <- newEvalutedObjectRef $ Value $ Integer nextNum-              let loops' = LoopContextConstant (name, nextNumRef) endNum pat pat' : loops -              return $ msingleton $ MState env loops' bindings (MAtom pat target matcher : trees)-        LoopContextVariable (name, startNumRef) lastNumPat pat pat' : loops -> do+          nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1)+          let (carPat, mCdrPat) = unconsOrPattern endPat+          matches <- patternMatch env' carPat startNumRef Something+          case (matched, matches) of+            (False, MNil) -> return $ msingleton $ MState env ((LoopContext SmartMode (name, nextNumRef) (False, endPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)+            (True, MNil) -> case mCdrPat of+                              Nothing -> return MNil+                              Just cdrPat -> do+                                let (carPat', _) = unconsOrPattern cdrPat+                                matches' <- patternMatch env' carPat' startNumRef Something+                                case matches' of+                                  MNil -> return $ msingleton $ MState env ((LoopContext SmartMode (name, nextNumRef) (False, cdrPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)+                                  MCons _ _ -> do+                                    return $ fromList [MState env loops' bindings ((MAtom cdrPat startNumRef Something):(MAtom pat' target matcher):trees),+                                                       MState env ((LoopContext SmartMode (name, nextNumRef) (True, cdrPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)]+            (_, MCons _ _) -> do+              return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees),+                                 MState env ((LoopContext SmartMode (name, nextNumRef) (True, endPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)]+        LoopContext NaiveMode (name, startNumRef) (matched, endPat) pat pat' : loops' -> do           startNum <- evalRef startNumRef >>= fromWHNF-          let nextNum = startNum + 1-          nextNumRef <- newEvalutedObjectRef $ Value $ Integer nextNum-          let loops' = LoopContextVariable (name, nextNumRef) lastNumPat pat pat' : loops -          return $ fromList [MState env loops bindings (MAtom lastNumPat startNumRef Something : MAtom pat' target matcher : trees),-                             MState env loops' bindings (MAtom pat target matcher : trees)]-          -    TuplePat patterns -> do-      targets <- evalRef target >>= fromTuple-      let matchers = fromTupleValue matcher-      if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()-      if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return ()-      let trees' = zipWith3 MAtom patterns targets matchers ++ trees-      return $ msingleton $ MState env loops bindings trees'+          nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1)+          return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees),+                             MState env ((LoopContext NaiveMode (name, nextNumRef) (True, endPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)]+     AndPat patterns ->-      let trees' = map (\pattern -> MAtom pattern target matcher) patterns ++ trees+      let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees       in return $ msingleton $ MState env loops bindings trees'     OrPat patterns ->-      return $ fromList $ flip map patterns $ \pattern ->-        MState env loops bindings (MAtom pattern target matcher : trees)-    NotPat pattern -> throwError $ strMsg "should not reach here (cut pattern)"-    PredPat pred -> do-      func <- evalExpr env' pred-      arg <- evalRef target-      result <- applyFunc func arg >>= fromWHNF-      if result then return $ msingleton $ (MState env loops bindings trees)-                else return MNil-    LetPat bindings' pattern ->-      let extractBindings ([name], expr) =-            makeBindings [name] . (:[]) <$> newObjectRef env' expr-          extractBindings (names, expr) =-            makeBindings names <$> (evalExpr env' expr >>= fromTuple)-      in-       liftM concat (mapM extractBindings bindings')-         >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern target matcher):trees))+      return $ fromList $ flip map patterns $ \pat ->+        MState env loops bindings (MAtom pat target matcher : trees)+     _ ->       case matcher of-        matcher@(UserMatcher _ _ _) -> do+        UserMatcher _ _ _ -> 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 loops bindings trees'             +        Tuple matchers -> do+          case pattern of+            ValuePat _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)+            WildCard -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)+            PatVar _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)+            IndexedPat _ _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)+            TuplePat patterns -> do+              targets <- evalRef target >>= fromTuple+              if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()+              if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return ()+              let trees' = zipWith3 MAtom patterns targets matchers ++ trees+              return $ msingleton $ MState env loops bindings trees'+            _ ->  throwError $ strMsg $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern+         Something ->           case pattern of             ValuePat valExpr -> do@@ -593,7 +618,7 @@                 Just ref -> do                   obj <- evalRef ref >>= updateHash indices >>= newEvalutedObjectRef                   return $ msingleton $ MState env loops (subst name obj bindings) trees-                Nothing  -> do -- throwError $ strMsg "Cannot reach here!\nIndexed-patttern-variable does not initialized."+                Nothing  -> do                   obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvalutedObjectRef                   return $ msingleton $ MState env loops ((name,obj):bindings) trees                where@@ -615,29 +640,7 @@                 subst _ _ [] = []             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 _ (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 loops bindings (MAtom pattern target matcher:MNode penv (MState env' loops' bindings' trees'):trees)-            Nothing -> throwError $ UnboundVariable name-        IndexedPat (VarPat name) indices ->-          case lookup name penv of-            Just pattern -> do-              let env'' = extendEnv env' (bindings' ++ map (\lc -> case lc of-                                                                     (LoopContextConstant binding _ _ _) -> binding-                                                                     (LoopContextVariable binding _ _ _) -> binding) loops')-              indices <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) 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 loops bindings . (: trees) . MNode penv)-    _ -> processMState' state >>= mmap (return . MState env loops bindings . (: trees) . MNode penv)+        _ ->  throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern  inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher ->                   EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher])@@ -765,6 +768,23 @@       liftIO $ writeIORef innersRef (hInners >< tInners)       unsnocCollection coll unsnocCollection _ = matchFail++extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopContext] -> Env+extendEnvForNonLinearPatterns env bindings loops =  extendEnv env $ bindings ++ map (\(LoopContext _ binding _ _ _) -> binding) loops++unconsOrPattern :: EgisonPattern -> (EgisonPattern, Maybe EgisonPattern)+unconsOrPattern (LetPat bindings pat) = let (pat',mpat'') = unconsOrPattern pat in+                                          case mpat'' of+                                            Just pat'' -> (LetPat bindings pat', Just (LetPat bindings pat''))+                                            Nothing -> (LetPat bindings pat', Nothing)+unconsOrPattern (OrPat [pat]) = (pat, Nothing)+unconsOrPattern (OrPat (pat:pats)) = (pat, Just (OrPat pats))+unconsOrPattern (AndPat [pat]) = unconsOrPattern pat+unconsOrPattern (AndPat (pat:pats)) = let (pat',mpat'') = unconsOrPattern pat in+                                        case mpat'' of+                                          Just pat'' -> (AndPat (pat':pats), Just (AndPat (pat'':pats)))+                                          Nothing -> (AndPat (pat':pats), Nothing)+unconsOrPattern pat = (pat, Nothing)  -- -- Util
hs-src/Language/Egison/Desugar.hs view
@@ -246,7 +246,7 @@    collectName (TuplePat patterns) = collectNames patterns    collectName (InductivePat _ patterns) = collectNames patterns    collectName (ApplyPat _ patterns) = collectNames patterns-   collectName (LoopPat _ _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2+   collectName (LoopPat _ _ _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2    collectName (LetPat _ pattern) = collectName pattern    collectName (IndexedPat (PatVar name) _) = S.singleton name    collectName (OrPat patterns) = collectNames patterns@@ -267,8 +267,8 @@   IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs desugarPattern' (ApplyPat expr patterns) =   ApplyPat <$> desugar expr <*> mapM desugarPattern' patterns -desugarPattern' (LoopPat name range pattern1 pattern2) =-  LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2+desugarPattern' (LoopPat mode name range pattern1 pattern2) =+  LoopPat mode name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = do   LetPat <$> desugarBindings binds <*> desugarPattern' pattern desugarPattern' (OrPat patterns)  = @@ -276,13 +276,10 @@ desugarPattern' pattern = return pattern  desugarLoopRange :: LoopRange -> DesugarM LoopRange-desugarLoopRange (LoopRangeConstant expr1 expr2) = do-  expr1' <- desugar expr1-  expr2' <- desugar expr2-  return $ LoopRangeConstant expr1' expr2'-desugarLoopRange (LoopRangeVariable expr1 name) = do-  expr1' <- desugar expr1-  return $ LoopRangeVariable expr1' name+desugarLoopRange (LoopRange expr pattern) = do+  expr' <- desugar expr+  pattern' <- desugarPattern pattern+  return $ LoopRange expr' pattern'  desugarBinding :: BindingExpr -> DesugarM BindingExpr desugarBinding (name, expr) = do
hs-src/Language/Egison/Parser.hs view
@@ -384,6 +384,8 @@                     <|> orPat                     <|> applyPat                     <|> loopPat+                    <|> naiveLoopPat+                    <|> smartLoopPat                     <|> letPat)  wildCard :: Parser EgisonPattern@@ -426,11 +428,16 @@ applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace   loopPat :: Parser EgisonPattern-loopPat = keywordLoop >> LoopPat <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern+loopPat = keywordLoop >> LoopPat SmartMode <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern +naiveLoopPat :: Parser EgisonPattern+naiveLoopPat = keywordNaiveLoop >> LoopPat NaiveMode <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern++smartLoopPat :: Parser EgisonPattern+smartLoopPat = keywordSmartLoop >> LoopPat SmartMode <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern+ loopRange :: Parser LoopRange-loopRange = brackets ((try $ LoopRangeConstant <$> expr <*> (reservedOp "," >> expr))-                      <|> LoopRangeVariable  <$> expr <*> pattern)+loopRange = brackets $ LoopRange  <$> expr <*> pattern  -- Constants @@ -505,6 +512,8 @@   , "letrec"   , "let"   , "loop"+  , "naive-loop"+  , "smart-loop"   , "match-all"   , "match"   , "match-all-lambda"@@ -553,6 +562,8 @@ keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let" keywordLoop                 = reserved "loop"+keywordNaiveLoop            = reserved "naive-loop"+keywordSmartLoop            = reserved "smart-loop" keywordMatchAll             = reserved "match-all" keywordMatchAllLambda       = reserved "match-all-lambda" keywordMatch                = reserved "match"
hs-src/Language/Egison/Types.hs view
@@ -19,6 +19,7 @@     , BindingExpr (..)     , MatchClause (..)     , MatcherInfo (..)+    , LoopMode (..)     , LoopRange (..)     , PrimitivePatPattern (..)     , PrimitiveDataPattern (..)@@ -190,17 +191,18 @@   | OrPat [EgisonPattern]   | TuplePat [EgisonPattern]   | InductivePat String [EgisonPattern]-  | LoopPat String LoopRange EgisonPattern EgisonPattern+  | LoopPat LoopMode String LoopRange EgisonPattern EgisonPattern   | ContPat   | ApplyPat EgisonExpr [EgisonPattern]   | VarPat String  deriving (Show) -data LoopRange =-    LoopRangeConstant EgisonExpr EgisonExpr-  | LoopRangeVariable EgisonExpr EgisonPattern+data LoopMode = NaiveMode | SmartMode  deriving (Show) +data LoopRange = LoopRange EgisonExpr EgisonPattern+ deriving (Show)+ data PrimitivePatPattern =     PPWildCard   | PPPatVar@@ -524,9 +526,7 @@  type PatternBinding = (Var, EgisonPattern) -data LoopContext =-    LoopContextConstant Binding Integer EgisonPattern EgisonPattern-  | LoopContextVariable Binding EgisonPattern EgisonPattern EgisonPattern+data LoopContext = LoopContext LoopMode Binding (Bool, EgisonPattern) EgisonPattern EgisonPattern  deriving (Show)  --@@ -542,7 +542,7 @@   | Match String   | Parser String   | Desugar String-  | UserInterruption+  | EgisonBug String   | Default String   deriving Typeable     @@ -556,7 +556,7 @@   show (NotImplemented message) = "Not implemented: " ++ message   show (Assertion message) = "Assertion failed: " ++ message   show (Desugar message) = "Error: " ++ message-  show UserInterruption = "Aborted: User interruption"+  show (EgisonBug message) = "Egison Error: " ++ message   show (Default message) = "Error: " ++ message  instance Exception EgisonError@@ -653,6 +653,10 @@ matchFail = MaybeT $ return Nothing  data MList m a = MNil | MCons a (m (MList m a))++instance Show (MList m a) where+  show MNil = "MNil"+  show (MCons _ _) = "(MCons ... ...)"  fromList :: Monad m => [a] -> MList m a fromList = foldr f MNil
lib/core/number.egi view
@@ -56,6 +56,18 @@         {[$tgt {tgt}]}]        }))) +(define $even?+  (lambda [$n]+    (eq? 0 (modulo n 2))))++(define $odd?+  (lambda [$n]+    (eq? 1 (modulo n 2))))++(define $between?+  (lambda [$m $n $x]+    (and (lte? m x) (lte? x n))))+ ;; ;; Float Numbers ;;