egison 0.2.0.0 → 0.2.0.1
raw patch · 4 files changed
+82/−72 lines, 4 files
Files
- Egison.hs +43/−25
- egison.cabal +1/−1
- etc/elisp/egison-mode.el +2/−3
- etc/sample/collection-test.egi +36/−43
Egison.hs view
@@ -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 "#<as-pat>" showPattern (OfPat _) = return "#<of-pat>" showPattern (ValPat _ _) = return "#<val-pat>"- + 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
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.2.0.0+Version: 0.2.0.1 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison
etc/elisp/egison-mode.el view
@@ -14,7 +14,8 @@ "\\<type-ref\\>" "\\<deconstructor\\>" "\\<match\\>"- "\\<match-map\\>"+ "\\<match-all\\>"+ "\\<with\\>" "\\\." "\\\,"@@ -23,8 +24,6 @@ "\\<_\\>" "\\<as\\>" "\\<of\\>"- "\\<some\\>"- "\\<rest\\>" )) "Subdued expressions to highlight in Egison modes.")
etc/sample/collection-test.egi view
@@ -310,26 +310,6 @@ >>>>> <nothing>]}))) -(define $min- (lambda [$ns]- (match ns (List Int)- {[<cons $n <nil>> n]- [<cons $n $rs>- (let {[$r (min Rs)]}- (match ((type-ref Int compare) n r) Order- {[<less> n]- [_ r]}))]}))) --(define $gcd- (lambda [$ns]- (let {[$ns2 ((remove-all Int) ns 0)]}- (match ns2 (Set Int)- {[<cons $n <nil>> n]- [<cons ,(min ns2)- $rs>- (gcd {n @(map (lambda [$r] (mod r n))- rs)})]}))))- (define $car (lambda [$xs] (match xs (List Something)@@ -416,34 +396,44 @@ [[_ _] <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))+(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Int)) [<cons <cons $n _> <cons <cons ,n _> <cons <cons ,n _> <nil>>>> n])) +(test (match (with $loop {1 @loop}) (List Int)+ {[<cons $m <cons $n _>> [m n]]+ [_ <not-ok>]})) -(test (match {1 1 1 1 2} (Mulset Int)- {[<cons ,2 (some <cons ,1 (rest <nil>)>)> <ok>]+(test (let {[$pat <cons ,1 <nil>>]}+ (match {1} (Multiset Int)+ {[pat <ok>]+ [_ <not-ok>]})))++(test (match {1} (Multiset Int)+ {[(of {<nil> <cons ,1 <nil>>}) <ok>] [_ <not-ok>]})) -(test (match-map {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))+(test (let {[$loop <cons ,1 (of {<nil> loop})>]}+ (match {1 1 1 1} (Multiset Int)+ {[loop <ok>]+ [_ <not-ok>]}))) -(test (match-map {<x> <y> <z> <w>} (List Something)+(test (match {1 1 1 1} (Multiset Int)+ {[(with $loop <cons ,1 (of {<nil> loop})>) <ok>]+ [_ <not-ok>]}))++(test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))++(test (match-all {<x> <y> <z> <w>} (List Something) [<join $hs <cons $x $ts>> [hs x ts]])) -(test (match-map {<x> <y> <z>} (Multiset Something)+(test (match-all {<x> <y> <z>} (Multiset Something) [<join $hs $ts> [hs x ts]])) -(test (match-map {<x> <y> <z>} (Set Something)+(test (match-all {<x> <y> <z>} (Set Something) [<join $hs $ts> [hs ts]])) (test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))@@ -482,15 +472,15 @@ [$inductive-match (deconstructor {[nil []- {[$tgt (match-map tgt (List a) [<nil> []])]+ {[$tgt (match-all 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]])}]+ {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])+ @(match-all (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]])}]+ {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])+ @(match-all (reverse tgt) (List a) [<join $xs $ys> [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) [<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>]))+(test (match-all {1 2 3} (Stick Int) [<cons $x $xs> [x xs]]))+(test (match-all {1 2 3} (Stick Int) [<join $xs $ys> [xs ys]]))+(test (match-all {1 2 3 4} (Stick Int) [<join $xs <cons $w $ys>> [xs w ys]]))+(test (match-all {1 2 3} (Stick Int) [,{3 2 1} <ok>])) +(test (match {1} (Multiset Int)+ {[<cons (where $n (lambda [$x] (= x 1))) <nil>> <ok>]+ [_ <not-ok>]}))