diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -11,7 +11,7 @@ main :: IO () main = do args <- getArgs case length args of - 0 -> do flushStr "Egison, version 0.2.0.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" + 0 -> do flushStr "Egison, version 0.2.0.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" defsRef <- newIORef [] runRepl defsRef _ -> putStrLn "Program takes only 0 argument!" @@ -159,13 +159,14 @@ | CollectionExp [InnerExp] | PatternExp PatternExp | FunctionExp FunPat Expression + | WithExp String Expression | DoExp Bind Expression | LetExp RecursiveBind Expression | TypeExp RecursiveBind | TypeRefExp Expression String | DeconstructorExp DeconsInfoExp | MatchExp Expression Expression [MatchClause] - | MatchMapExp Expression Expression MatchClause + | MatchAllExp Expression Expression MatchClause | ApplyExp Expression Expression data InnerExp = ElementExp Expression @@ -236,7 +237,6 @@ | CutPat (IORef IntermidiateValue) | AsPat String (IORef IntermidiateValue) | OfPat [IORef IntermidiateValue] --- | SomePat [String] Environment Expression | ValPat Environment Expression type DeconsInfo = [(String, IORef IntermidiateValue, [(Environment, PrimePat, Expression)])] @@ -317,6 +317,13 @@ spaces body <- parseExpression return (FunctionExp args body) + <|> do try (do string "with" + spaces1) + char '$' + name <- word + spaces + expr <- parseExpression + return (WithExp name expr) <|> do try (do string "do" spaces1) bind <- parseBind @@ -351,7 +358,7 @@ spaces clss <- braces (sepEndBy parseMatchClause spaces) return (MatchExp tgt typ clss) - <|> do try (do string "match-map" + <|> do try (do string "match-all" spaces1) tgt <- parseExpression spaces @@ -359,7 +366,7 @@ spaces cls <- parseMatchClause spaces - return (MatchMapExp tgt typ cls) + return (MatchAllExp tgt typ cls) <|> do try (do string "apply" spaces1) fn <- parseExpression @@ -488,7 +495,8 @@ <|> do try (do string "of" spaces1) expr <- parseExpression - return (OfPatExp expr)) + return (OfPatExp expr) + ) -- -- Environment @@ -690,7 +698,7 @@ showPattern (AsPat _ _) = return "#" showPattern (OfPat _) = return "#" showPattern (ValPat _ _) = return "#" - + unwordsList :: Show a => [a] -> String unwordsList = unwords . map show @@ -749,6 +757,7 @@ return (Collection innerVals) eval1 env (PatternExp patExp) = evalPattern1 env patExp eval1 env (FunctionExp args body) = return (Function env args body) +eval1 env (WithExp name expr) = eval1 env (LetExp [(name, expr)] (SymbolExp name)) eval1 env (DoExp [] body) = eval1 env body eval1 env (DoExp ((fpat,expr):assocs) body) = do iValRef <- liftIO (makeClosure env expr) @@ -777,10 +786,10 @@ typIVal <- liftIO (makeClosure env typExp) tgtIVal <- liftIO (makeClosure env tgtExp) forceMatchExp env typIVal tgtIVal mCs -eval1 env (MatchMapExp tgtExp typExp mC) = do +eval1 env (MatchAllExp tgtExp typExp mC) = do typIVal <- liftIO (makeClosure env typExp) tgtIVal <- liftIO (makeClosure env tgtExp) - forceMatchMapExp env typIVal tgtIVal mC + forceMatchAllExp env typIVal tgtIVal mC eval1 env expr@(ApplyExp fnExp argsExp) = do fnVal <- eval1 env fnExp argsIValRef <- liftIO (makeClosure env argsExp) @@ -805,7 +814,7 @@ return (Pattern (AsPat var iValRef)) evalPattern1 env (OfPatExp expr) = do iValRef <- liftIO (makeClosure env expr) - iValRefs <- tupleToList iValRef + iValRefs <- collectionToList iValRef return (Pattern (OfPat iValRefs)) evalPattern1 env (ValPatExp expr) = do return (Pattern (ValPat env expr)) @@ -884,22 +893,22 @@ force iValRef forceMatchExp _ _ _ _ = throwError (Default "end of match clause") -forceMatchMapExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value -forceMatchMapExp env typIValRef tgtIValRef (MatchClause pat expr) = do +forceMatchAllExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value +forceMatchAllExp env typIValRef tgtIValRef (MatchClause pat expr) = do typVals <- tupleToList typIValRef tgtVals <- tupleToList tgtIValRef patIValRef <- liftIO (makeClosure env pat) patVals <- tupleToList patIValRef matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals - innerVals <- forceMatchMapExpHelper env matchs expr + innerVals <- forceMatchAllExpHelper env matchs expr return (Collection innerVals) -forceMatchMapExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue] -forceMatchMapExpHelper _ [] _ = return [] -forceMatchMapExpHelper env (frame:frames) expr = do +forceMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue] +forceMatchAllExpHelper _ [] _ = return [] +forceMatchAllExpHelper env (frame:frames) expr = do iValRef <- liftIO (makeClosure (addFrame frame env) expr) force iValRef - rest <- forceMatchMapExpHelper env frames expr + rest <- forceMatchAllExpHelper env frames expr return (Element iValRef:rest) patternMatchList :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame] @@ -945,6 +954,15 @@ patternMatch (frame:_) typVal (Pattern (CutPat patIValRef)) tgtIValRef = do patVal <- force patIValRef patternMatch [frame] typVal patVal tgtIValRef +patternMatch frames typVal (Pattern (AsPat name patIValRef)) tgtIValRef = undefined +patternMatch frames typVal (Pattern (OfPat patIValRefs)) tgtIValRef = + let loop patIValRefs2 = case patIValRefs2 of + [] -> return [] + patIValRef:rests -> do patVal <- force patIValRef + newFrames1 <- patternMatch frames typVal patVal tgtIValRef + newFrames2 <- loop rests + return (newFrames1 ++ newFrames2) in + loop patIValRefs patternMatch frames (Type bind) (Pattern (ValPat onEnv expr)) tgtIValRef = do case getValueFromFrame bind "equal?" of Nothing -> throwError (Default "no equal? function") @@ -1040,13 +1058,13 @@ val <- force iValRef case val of InductiveData cons iValRefs -> if pCons == cons - then primitivePatternMatchMap pPats iValRefs + then primitivePatternMatchAll pPats iValRefs else return Nothing _ -> throwError (Default "primitive : not inductive value to primitive inductive pattern") primitivePatternMatch (TuplePrimePat pPats) iValRef = do val <- force iValRef case val of - Tuple iValRefs -> primitivePatternMatchMap pPats iValRefs + Tuple iValRefs -> primitivePatternMatchAll pPats iValRefs _ -> throwError (Default "primitive : not tuple value to primitive tuple pattern") primitivePatternMatch EmptyPat iValRef = do val <- force iValRef @@ -1081,17 +1099,17 @@ Just rdcFrame -> return (Just (appendFrames racFrame rdcFrame)) Nothing -> return Nothing -primitivePatternMatchMap :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame) -primitivePatternMatchMap [] [] = return (Just (Frame [])) -primitivePatternMatchMap (pat:pats) (iValRef:iValRefs) = do +primitivePatternMatchAll :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame) +primitivePatternMatchAll [] [] = return (Just (Frame [])) +primitivePatternMatchAll (pat:pats) (iValRef:iValRefs) = do mFrame <- primitivePatternMatch pat iValRef case mFrame of Nothing -> return Nothing - Just frame -> do mRestFrame <- primitivePatternMatchMap pats iValRefs + Just frame -> do mRestFrame <- primitivePatternMatchAll pats iValRefs case mRestFrame of Nothing -> return Nothing Just restFrame -> return (Just (appendFrames frame restFrame)) -primitivePatternMatchMap _ _ = throwError (Default "primitivePatternMatchMap : number of patterns and targets are different") +primitivePatternMatchAll _ _ = throwError (Default "primitivePatternMatchAll : number of patterns and targets are different") isEmptyCollection :: Value -> IOThrowsError Bool isEmptyCollection (Collection []) = return True @@ -1328,7 +1346,7 @@ showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")" showExpression (DeconstructorExp deconsInfoExp) = "(deconstructor " ++ showDeconsInfoExp deconsInfoExp ++ ")" showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})" -showExpression (MatchMapExp tgt typ cls) = "(match-map " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")" +showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")" showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")" instance Show Expression where show = showExpression diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.2.0.0 +Version: 0.2.0.1 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison diff --git a/etc/elisp/egison-mode.el b/etc/elisp/egison-mode.el --- a/etc/elisp/egison-mode.el +++ b/etc/elisp/egison-mode.el @@ -14,7 +14,8 @@ "\\" "\\" "\\" - "\\" + "\\" + "\\" "\\\." "\\\," @@ -23,8 +24,6 @@ "\\<_\\>" "\\" "\\" - "\\" - "\\" )) "Subdued expressions to highlight in Egison modes.") diff --git a/etc/sample/collection-test.egi b/etc/sample/collection-test.egi --- a/etc/sample/collection-test.egi +++ b/etc/sample/collection-test.egi @@ -310,26 +310,6 @@ >>>>> ]}))) -(define $min - (lambda [$ns] - (match ns (List Int) - {[> n] - [ - (let {[$r (min Rs)]} - (match ((type-ref Int compare) n r) Order - {[ n] - [_ r]}))]}))) - -(define $gcd - (lambda [$ns] - (let {[$ns2 ((remove-all Int) ns 0)]} - (match ns2 (Set Int) - {[> n] - [ - (gcd {n @(map (lambda [$r] (mod r n)) - rs)})]})))) - (define $car (lambda [$xs] (match xs (List Something) @@ -416,34 +396,44 @@ [[_ _] ]}))) -(test (match-map {{1 2 3} {4 5 1} {6 1 7}} (Multiset (Multiset Int)) - [ - - - >>> - n])) - -(test (match-map {{1 2 3} {4 5 1} {6 1 7}} (Multiset (Multiset Int)) +(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Int)) [ >>> n])) +(test (match (with $loop {1 @loop}) (List Int) + {[> [m n]] + [_ ]})) -(test (match {1 1 1 1 2} (Mulset Int) - {[)>)> ] +(test (let {[$pat >]} + (match {1} (Multiset Int) + {[pat ] + [_ ]}))) + +(test (match {1} (Multiset Int) + {[(of { >}) ] [_ ]})) -(test (match-map { } (List Something) [ [xs ys]])) +(test (let {[$loop loop})>]} + (match {1 1 1 1} (Multiset Int) + {[loop ] + [_ ]}))) -(test (match-map { } (List Something) +(test (match {1 1 1 1} (Multiset Int) + {[(with $loop loop})>) ] + [_ ]})) + +(test (match-all { } (List Something) [ [xs ys]])) + +(test (match-all { } (List Something) [> [hs x ts]])) -(test (match-map { } (Multiset Something) +(test (match-all { } (Multiset Something) [ [hs x ts]])) -(test (match-map { } (Set Something) +(test (match-all { } (Set Something) [ [hs ts]])) (test ((remove-collection Suit) { } { })) @@ -482,15 +472,15 @@ [$inductive-match (deconstructor {[nil [] - {[$tgt (match-map tgt (List a) [ []])] + {[$tgt (match-all tgt (List a) [ []])] }] [cons [a (List a)] - {[$tgt {@(match-map tgt (List a) [ [x xs]]) - @(match-map (reverse tgt) (List a) [ [x xs]])}] + {[$tgt {@(match-all tgt (List a) [ [x xs]]) + @(match-all (reverse tgt) (List a) [ [x xs]])}] }] [join [(List a) (List a)] - {[$tgt {@(match-map tgt (List a) [ [xs ys]]) - @(match-map (reverse tgt) (List a) [ [xs ys]])}] + {[$tgt {@(match-all tgt (List a) [ [xs ys]]) + @(match-all (reverse tgt) (List a) [ [xs ys]])}] }] })] [$equal? (lambda [$val $tgt] @@ -498,9 +488,12 @@ ((type-ref (List a) equal?) val (reverse tgt))))] }))) -(test (match-map {1 2 3} (Stick Int) [ [x xs]])) -(test (match-map {1 2 3} (Stick Int) [ [xs ys]])) -(test (match-map {1 2 3 4} (Stick Int) [> [xs w ys]])) -(test (match-map {1 2 3} (Stick Int) [,{3 2 1} ])) +(test (match-all {1 2 3} (Stick Int) [ [x xs]])) +(test (match-all {1 2 3} (Stick Int) [ [xs ys]])) +(test (match-all {1 2 3 4} (Stick Int) [> [xs w ys]])) +(test (match-all {1 2 3} (Stick Int) [,{3 2 1} ])) +(test (match {1} (Multiset Int) + {[> ] + [_ ]}))