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.1.2.5 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" + 0 -> do flushStr "Egison, version 0.2.0.0 : 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!" @@ -176,7 +176,6 @@ | CutPatExp Expression | AsPatExp String Expression | OfPatExp Expression - | OnPatExp [String] Expression | ValPatExp Expression data FunPat = FunPatVar String @@ -237,8 +236,8 @@ | CutPat (IORef IntermidiateValue) | AsPat String (IORef IntermidiateValue) | OfPat [IORef IntermidiateValue] - | OnPat [String] Environment Expression - | ValPat (IORef IntermidiateValue) +-- | SomePat [String] Environment Expression + | ValPat Environment Expression type DeconsInfo = [(String, IORef IntermidiateValue, [(Environment, PrimePat, Expression)])] @@ -489,15 +488,7 @@ <|> do try (do string "of" spaces1) expr <- parseExpression - return (OfPatExp expr) - <|> do try (do string "on" - spaces1) - vars <- try (do var <- (char '$' >> word) - return [var] - <|> brackets (sepEndBy (char '$' >> word) spaces)) - spaces - expr <- parseExpression - return (OnPatExp vars expr)) + return (OfPatExp expr)) -- -- Environment @@ -698,8 +689,7 @@ showPattern (CutPat _) = return "#" showPattern (AsPat _ _) = return "#" showPattern (OfPat _) = return "#" -showPattern (OnPat _ _ _) = return "#" -showPattern (ValPat _) = return "#" +showPattern (ValPat _ _) = return "#" unwordsList :: Show a => [a] -> String unwordsList = unwords . map show @@ -817,11 +807,8 @@ iValRef <- liftIO (makeClosure env expr) iValRefs <- tupleToList iValRef return (Pattern (OfPat iValRefs)) -evalPattern1 env (OnPatExp vars expr) = do - return (Pattern (OnPat vars env expr)) evalPattern1 env (ValPatExp expr) = do - iValRef <- liftIO (makeClosure env expr) - return (Pattern (ValPat iValRef)) + return (Pattern (ValPat env expr)) eval :: Environment -> Expression -> IOThrowsError Value eval env expr = do @@ -877,10 +864,8 @@ forceRecursivelyPattern (OfPat iValRefs) = do forceRecursivelyList iValRefs return (OfPat iValRefs) -forceRecursivelyPattern (OnPat vars env expr) = return (OnPat vars env expr) -forceRecursivelyPattern (ValPat iValRef) = do - forceRecursively iValRef - return (ValPat iValRef) +forceRecursivelyPattern (ValPat onEnv expr) = do + return (ValPat onEnv expr) --- --- @@ -960,28 +945,28 @@ patternMatch (frame:_) typVal (Pattern (CutPat patIValRef)) tgtIValRef = do patVal <- force patIValRef patternMatch [frame] typVal patVal tgtIValRef -patternMatch (frame:frames) typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef = do - onFrame <- extractAssocs frame vars - patIValRef <- liftIO (makeClosure (addFrame onFrame onEnv) expr) - patVal <- force patIValRef - newFrames1 <- patternMatch [frame] typVal patVal tgtIValRef - newFrames2 <- patternMatch frames typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef - return (newFrames1 ++ newFrames2) -patternMatch frames (Type bind) (Pattern (ValPat iValPatRef)) tgtIValRef = do +patternMatch frames (Type bind) (Pattern (ValPat onEnv expr)) tgtIValRef = do case getValueFromFrame bind "equal?" of Nothing -> throwError (Default "no equal? function") - Just valMatchFnRef -> do valMatchFn <- force valMatchFnRef - case valMatchFn of - Function funEnv fpat body -> do argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef]))) - argsFrame <- makeFrame fpat argsIValRef - iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body) - val <- force iValRef - case val of - (InductiveData "true" []) -> return frames - (InductiveData "false" []) -> return [] - _ -> throwError (Default "invalid return value from equal? function") - _ -> throwError (Default "equal? is not function") -patternMatch _ _ _ _ = throwError (Default "invalid pattern : you shold add ',' to the head of value pattern") + Just equalFnRef -> do equalFn <- force equalFnRef + case equalFn of + Function funEnv fpat body + -> let loop frames2 = case frames2 of + [] -> return [] + (frame:rests) + -> do iValPatRef <- liftIO (makeClosure (addFrame frame onEnv) expr) + argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef]))) + argsFrame <- makeFrame fpat argsIValRef + iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body) + val <- force iValRef + restFrames <- loop rests + case val of + (InductiveData "true" []) -> return (frame:restFrames) + (InductiveData "false" []) -> return restFrames + _ -> throwError (Default "invalid return value from equal? function") in + loop frames + _ -> throwError (Default "equal? is not function") +patternMatch _ _ _ _ = throwError (Default "invalid pattern : you shold add ',' to the head of value") doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame] doDeconstruct [] _ _ _ = throwError (Default "no match decons clause") @@ -1013,15 +998,15 @@ connectFrames (frame:frames) newFrames = (map (\newFrame -> (appendFrames frame newFrame)) newFrames) ++ (connectFrames frames newFrames) -extractAssocs :: Frame -> [String] -> IOThrowsError Frame -extractAssocs _ [] = return (Frame []) -extractAssocs frame (var:vars) = - let mValRef = getValueFromFrame frame var in - case mValRef of - Nothing -> throwError (Default "extractAssocs") - Just iValRef -> do newFrame <- extractAssocs frame vars - case newFrame of - Frame assocs -> return (Frame ((var, iValRef):assocs)) +--extractAssocs :: Frame -> [String] -> IOThrowsError Frame +--extractAssocs _ [] = return (Frame []) +--extractAssocs frame (var:vars) = +-- let mValRef = getValueFromFrame frame var in +-- case mValRef of +-- Nothing -> throwError (Default "extractAssocs") +-- Just iValRef -> do newFrame <- extractAssocs frame vars +-- case newFrame of +-- Frame assocs -> return (Frame ((var, iValRef):assocs)) --- --- @@ -1360,7 +1345,6 @@ showPatternExp (CutPatExp p) = "!" ++ show p showPatternExp (AsPatExp s p) = "(as " ++ s ++ " " ++ show p ++ ")" showPatternExp (OfPatExp ps) = "(of " ++ show ps ++ ")" -showPatternExp (OnPatExp vars pat) = "(on [" ++ unwords (map (\var -> "$" ++ var) vars) ++ "] " ++ show pat ++ ")" showPatternExp (ValPatExp expr) = "," ++ show expr instance Show PatternExp where show = showPatternExp 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.1.2.5 +Version: 0.2.0.0 -- 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 @@ -21,9 +21,10 @@ "\\\!" "@" "\\<_\\>" - "\\" "\\" "\\" + "\\" + "\\" )) "Subdued expressions to highlight in Egison modes.") @@ -55,7 +56,10 @@ (setq pc 2) (backward-char) (if (open-paren-p) - (setq pc (+ pc 1)) + (progn + (setq pc (+ pc 1)) + (if (and (= pc 0) (= (current-column) 0)) + (setq pc 2))) (if (close-paren-p) (setq pc (- pc 1)))))) (if (= pc 2) 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 @@ -18,6 +18,12 @@ [[_ _] ]}))] })) +(define $or + (lambda [$b1 $b2] + (match b1 Bool + {[ ] + [ b2]}))) + (define $Order (type {[$var-match (lambda [$tgt] {tgt})] @@ -105,7 +111,7 @@ [$equal? (lambda [$val $tgt] (match [val tgt] [Card Card] {[[ - ] + ] ] [[_ _] ]}))]})) @@ -153,12 +159,12 @@ }] })] [$equal? (lambda [$val $tgt] - (match [val tgt] [(List a) (List a)] - {[[ ] ] - [[ - ] - ] - [[_ _] ]}))] + (match [val tgt] [(List a) (List a)] + {[[ ] ] + [[ + ] + ] + [[_ _] ]}))] }))) (define $map @@ -223,7 +229,7 @@ (match [val tgt] [(Multiset a) (Multiset a)] {[[ ] ] [[ - ] + ] ] [[_ _] ]}))] }))) @@ -232,63 +238,63 @@ (lambda [$Cs] (match Cs (Multiset Card) {[ - - - - + + + + ! >>>>> ] [ - - ! - ! + + ! + ! ! >>>>> ] [ - - + + ! - ! + ! ! >>>>> ] [ - ! - ! - ! - ! + ! + ! + ! + ! ! >>>>> ] [ - - - - + + + + ! >>>>> ] [ - - + + ! >>>>> ] [ - + ! - + ! >>>>> ] [ - + !]}))) (define $min - (lambda [$Ns] - (match Ns (List Int) + (lambda [$ns] + (match ns (List Int) {[> n] - [ + [ (let {[$r (min Rs)]} (match ((type-ref Int compare) n r) Order {[ n] @@ -320,19 +326,9 @@ (match ns2 (Set Int) {[> n] [ - (gcd {n @(map (lambda [$r] (mod r n)) - Rs)})]})))) - -(define $gcd - (lambda [$Ns] - (let {[$Ns2 (remove-all Ns 0)]} - (match Ns2 (Set Int) - {[> n] - [ + $rs> (gcd {n @(map (lambda [$r] (mod r n)) - Rs)})]})))) + rs)})]})))) (define $car (lambda [$xs] @@ -415,18 +411,30 @@ (lambda [$xs $ys] (match [xs ys] [(List Bool) (List Bool)] {[[> - >] + >] ] [[_ _] ]}))) -(define $ham1 - (lambda [$xs $ys] - (match [xs ys] [(List Bool) (List Bool)] - {[[> - >] - ] - [[_ _] ]}))) +(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)) + [ + + + >>> + n])) + + +(test (match {1 1 1 1 2} (Mulset Int) + {[)>)> ] + [_ ]})) + (test (match-map { } (List Something) [ [xs ys]])) (test (match-map { } (List Something) @@ -465,4 +473,34 @@ 5> 1> 3>})) + + +(define $Stick + (lambda [$a] + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[nil [] + {[$tgt (match-map tgt (List a) [ []])] + }] + [cons [a (List a)] + {[$tgt {@(match-map tgt (List a) [ [x xs]]) + @(match-map (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]])}] + }] + })] + [$equal? (lambda [$val $tgt] + (or ((type-ref (List a) equal?) val tgt) + ((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} ])) + diff --git a/etc/sample/nat-test.egi b/etc/sample/nat-test.egi --- a/etc/sample/nat-test.egi +++ b/etc/sample/nat-test.egi @@ -36,7 +36,7 @@ (lambda [$val $tgt] (match [val tgt] [Nat Nat] {[[ ] ] - [[ ] ] + [[ ] ] [[_ _] ]}))] }))