diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -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. 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 @@ -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 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 @@ -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 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 @@ -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" 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 @@ -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 diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -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 ;;