egison 0.1.2.5 → 0.2.0.0
raw patch · 5 files changed
+137/−111 lines, 5 files
Files
- Egison.hs +37/−53
- egison.cabal +1/−1
- etc/elisp/egison-mode.el +6/−2
- etc/sample/collection-test.egi +92/−54
- etc/sample/nat-test.egi +1/−1
Egison.hs view
@@ -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 "#<cut-pat>" showPattern (AsPat _ _) = return "#<as-pat>" showPattern (OfPat _) = return "#<of-pat>"-showPattern (OnPat _ _ _) = return "#<on-pat>"-showPattern (ValPat _) = return "#<val-pat>"+showPattern (ValPat _ _) = return "#<val-pat>" 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
egison.cabal view
@@ -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
etc/elisp/egison-mode.el view
@@ -21,9 +21,10 @@ "\\\!" "@" "\\<_\\>"- "\\<on\\>" "\\<as\\>" "\\<of\\>"+ "\\<some\\>"+ "\\<rest\\>" )) "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)
etc/sample/collection-test.egi view
@@ -18,6 +18,12 @@ [[_ _] <false>]}))] })) +(define $or+ (lambda [$b1 $b2]+ (match b1 Bool+ {[<true> <true>]+ [<false> b2]})))+ (define $Order (type {[$var-match (lambda [$tgt] {tgt})]@@ -105,7 +111,7 @@ [$equal? (lambda [$val $tgt] (match [val tgt] [Card Card] {[[<card $s $n>- <card (on [$s] ,s) (on [$n] ,n)>]+ <card ,s ,n>] <true>] [[_ _] <false>]}))]})) @@ -153,12 +159,12 @@ }] })] [$equal? (lambda [$val $tgt]- (match [val tgt] [(List a) (List a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs>- <cons (on [$x] ,x) (on [$xs] ,xs)>]- <true>]- [[_ _] <false>]}))]+ (match [val tgt] [(List a) (List a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons ,x ,xs>]+ <true>]+ [[_ _] <false>]}))] }))) (define $map@@ -223,7 +229,7 @@ (match [val tgt] [(Multiset a) (Multiset a)] {[[<nil> <nil>] <true>] [[<cons $x $xs>- <cons (on [$x] ,x) (on [$xs] ,xs)>]+ <cons ,x ,xs>] <true>] [[_ _] <false>]}))] })))@@ -232,63 +238,63 @@ (lambda [$Cs] (match Cs (Multiset Card) {[<cons <card $S $n>- <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>+ <cons <card ,S ,(- n 1)>+ <cons <card ,S ,(- n 2)>+ <cons <card ,S ,(- n 3)>+ <cons <card ,S ,(- n 4)> !<nil> >>>>> <straight-flush>] [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>+ <cons <card _ ,n>+ !<cons <card _ ,n>+ !<cons <card _ ,n> !<cons _ !<nil> >>>>> <four-of-kind>] [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- <cons <card _ (on [$m] ,m)>+ <cons <card _ ,m>+ <cons <card _ ,m> !<cons <card _ $n>- !<cons <card _ (on [$n] ,n)>+ !<cons <card _ ,n> !<nil> >>>>> <full-house>] [<cons <card $S _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>+ !<cons <card ,S _>+ !<cons <card ,S _>+ !<cons <card ,S _>+ !<cons <card ,S _> !<nil> >>>>> <flush>] [<cons <card _ $n>- <cons <card _ (on [$n] ,(- n 1))>- <cons <card _ (on [$n] ,(- n 2))>- <cons <card _ (on [$n] ,(- n 3))>- <cons <card _ (on [$n] ,(- n 4))>+ <cons <card _ ,(- n 1)>+ <cons <card _ ,(- n 2)>+ <cons <card _ ,(- n 3)>+ <cons <card _ ,(- n 4)> !<nil> >>>>> <straight>] [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- <cons <card _ (on [$n] ,n)>+ <cons <card _ ,n>+ <cons <card _ ,n> !<cons _ !<cons _ !<nil> >>>>> <three-of-kind>] [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>+ <cons <card _ ,m> !<cons <card _ $n>- <cons <card _ (on [$n] ,n)>+ <cons <card _ ,n> !<cons _ !<nil> >>>>> <two-pair>] [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>+ <cons <card _ ,n> !<cons _ !<cons _ !<cons _@@ -305,10 +311,10 @@ <nothing>]}))) (define $min- (lambda [$Ns]- (match Ns (List Int)+ (lambda [$ns]+ (match ns (List Int) {[<cons $n <nil>> n]- [<cons $n $Rs>+ [<cons $n $rs> (let {[$r (min Rs)]} (match ((type-ref Int compare) n r) Order {[<less> n]@@ -320,19 +326,9 @@ (match ns2 (Set Int) {[<cons $n <nil>> n] [<cons ,(min ns2)- $Rs>- (gcd {n @(map (lambda [$r] (mod r n))- Rs)})]}))))--(define $gcd- (lambda [$Ns]- (let {[$Ns2 (remove-all Ns 0)]}- (match Ns2 (Set Int)- {[<cons $n <nil>> n]- [<cons ,(min Ns2)- $Rs>+ $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)] {[[<join $hs <cons $x $ts>>- <join (on [$hs] ,hs) <cons (on [$x] ,(not x)) (on [$ts] ,ts)>>]+ <join ,hs <cons ,(not x) ,ts>>] <true>] [[_ _] <false>]}))) -(define $ham1- (lambda [$xs $ys]- (match [xs ys] [(List Bool) (List Bool)]- {[[<join $hs <cons $x $ts>>- <join (on [$hs] ,{}) <cons (on [$x] ,(not x)) (on [$ts] ,{})>>]- <true>]- [[_ _] <false>]}))) +(test (match-map {{1 2 3} {4 5 1} {6 1 7}} (Multiset (Multiset Int))+ [<cons <cons ,1 _>+ <cons <cons ,1 _>+ <cons <cons ,1 _>+ <nil>>>>+ n]))++(test (match-map {{1 2 3} {4 5 1} {6 1 7}} (Multiset (Multiset Int))+ [<cons <cons $n _>+ <cons <cons ,n _>+ <cons <cons ,n _>+ <nil>>>>+ n]))+++(test (match {1 1 1 1 2} (Mulset Int)+ {[<cons ,2 (some <cons ,1 (rest <nil>)>)> <ok>]+ [_ <not-ok>]}))+ (test (match-map {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]])) (test (match-map {<x> <y> <z> <w>} (List Something)@@ -465,4 +473,34 @@ <card <club> 5> <card <heart> 1> <card <diamond> 3>}))+++(define $Stick+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[$tgt (match-map tgt (List a) [<nil> []])]+ }]+ [cons [a (List a)]+ {[$tgt {@(match-map tgt (List a) [<cons $x $xs> [x xs]])+ @(match-map (reverse tgt) (List a) [<cons $x $xs> [x xs]])}]+ }]+ [join [(List a) (List a)]+ {[$tgt {@(match-map tgt (List a) [<join $xs $ys> [xs ys]])+ @(match-map (reverse tgt) (List a) [<join $xs $ys> [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) [<cons $x $xs> [x xs]]))+(test (match-map {1 2 3} (Stick Int) [<join $xs $ys> [xs ys]]))+(test (match-map {1 2 3 4} (Stick Int) [<join $xs <cons $w $ys>> [xs w ys]]))+(test (match-map {1 2 3} (Stick Int) [,{3 2 1} <ok>]))+
etc/sample/nat-test.egi view
@@ -36,7 +36,7 @@ (lambda [$val $tgt] (match [val tgt] [Nat Nat] {[[<o> <o>] <true>]- [[<s $n1> <s (on [$n1] ,n1)>] <true>]+ [[<s $n1> <s ,n1>] <true>] [[_ _] <false>]}))] }))