egison 0.3.0.3 → 0.3.1.0
raw patch · 7 files changed
+59/−179 lines, 7 files
Files
- Egison.hs +31/−10
- egison.cabal +1/−1
- etc/lib/base.egi +1/−3
- etc/lib/number.egi +2/−4
- etc/lib/poker-hands.egi +13/−27
- etc/sample/collection-test.egi +6/−131
- etc/sample/io-test.egi +5/−3
Egison.hs view
@@ -9,7 +9,7 @@ import IO hiding (try) welcomeMsg :: String-welcomeMsg = "Egison, version 0.3.0.3 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+welcomeMsg = "Egison, version 0.3.1.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" byebyeMsg :: String byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n"@@ -89,8 +89,8 @@ showError :: EgiError -> String showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n" showError (UnboundVariable name) = "Error : unbound variable : " ++ name ++ "\n"-showError (WithTopExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"-showError (WithExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"+showError (WithTopExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n"+showError (WithExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n" showError (Default str) = "Error : " ++ str ++ "\n" instance Show EgiError where show = showError@@ -241,6 +241,7 @@ data Action = Read Value | Write Value+ | Print String | Memorize Value | Remember Value @@ -653,8 +654,8 @@ expressionToValue (CollectionExp innerExps) = do innerVals <- innerExpToInnerValueMap innerExps return (Collection innerVals)-expressionToValue expr@(PatternExp _) = throwError (WithExpression "not implemented yet :" expr)-expressionToValue expr = throwError (WithExpression "read expression is not value :" expr)+expressionToValue expr@(PatternExp _) = throwError (WithExpression "not implemented yet" expr)+expressionToValue expr = throwError (WithExpression "You should give a value as an input of read." expr) expressionToValueMap :: [Expression] -> IOThrowsError [Value] expressionToValueMap [] = return []@@ -796,10 +797,10 @@ case typVal of (Type frame) -> let mIValRef = getValueFromFrame frame name in case mIValRef of- Nothing -> throwError (WithExpression ("no method in type : " ++ name) expr)+ Nothing -> throwError (WithExpression ("no method in type" ++ name) expr) Just iValRef -> do val <- force iValRef return val- _ -> throwError (WithExpression "first arg of typeref is not type :" expr)+ _ -> throwError (WithExpression "first arg of typeref is not type" expr) eval1 env (DeconstructorExp deconsInfoExp) = do deconsInfo <- liftIO (makeDeconsInfo env deconsInfoExp) return (DeconstructorFunction deconsInfo)@@ -822,7 +823,7 @@ iValRef <- liftIO (makeClosure (addFrame frame funEnv) body) force iValRef DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo)- _ -> throwError (WithExpression "applying non-functional object :" expr)+ _ -> throwError (WithExpression "applying non-functional object" expr) evalPattern1 :: Environment -> PatternExp -> IOThrowsError Value evalPattern1 _ WildCardExp = return (Pattern WildCard)@@ -1241,6 +1242,15 @@ vals2 <- collectionToValueList (Collection rest) return (vals1 ++ vals2) +charCollectionToString :: Value -> IOThrowsError [Char]+charCollectionToString (Collection []) = return []+charCollectionToString (Collection (Element eRef : rest)) = do+ eIVal <- liftIO (readIORef eRef)+ restStr <- charCollectionToString (Collection rest)+ case eIVal of+ Value (Character c) -> return (c : restStr)+ _ -> throwError (Default "charCollectionToString : not char collection")+ makeCollectionFromValueList :: [Value] -> IO Value makeCollectionFromValueList vals = let loop vals2 = case vals2 of@@ -1250,7 +1260,7 @@ return ((Element iValRef):restRefs) in do innerVals <- loop vals return (Collection innerVals)-+ --- --- Builtin Function ---@@ -1260,6 +1270,7 @@ case name of "read" -> Just builtinRead "write" -> Just builtinWrite+ "print" -> Just builtinPrint "read-char" -> Just builtinReadChar "write-char" -> Just builtinWriteChar "int-to-float" -> Just builtinIntToFloat@@ -1312,6 +1323,13 @@ liftIO (flushStr valStr) return (World ((Write val):actions)) builtinWrite _ = throwError (Default "invalid args to write")++builtinPrint :: [Value] -> IOThrowsError Value+builtinPrint [(World actions), val] = do+ str <- charCollectionToString val+ liftIO (flushStr str)+ return (World ((Print str):actions))+builtinPrint _ = throwError (Default "invalid args to print") builtinReadChar :: [Value] -> IOThrowsError Value builtinReadChar [(World actions)] = do@@ -1473,12 +1491,14 @@ showTopExpression :: TopExpression -> String showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")" showTopExpression (Test expr) = "(test " ++ show expr ++ ")"+showTopExpression (Load expr) = "(load " ++ show expr ++ ")" showTopExpression Execute = "(execute)" instance Show TopExpression where show = showTopExpression showExpression :: Expression -> String-showExpression (CharacterExp c) = show c+showExpression (CharacterExp c) = "'" ++ show c ++ "'"+showExpression (StringExp s) = "\"" ++ show s ++ "\"" showExpression (IntegerExp n) = show n showExpression (SymbolExp name) = name showExpression (InductiveDataExp s []) = "<" ++ s ++ ">"@@ -1487,6 +1507,7 @@ showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}" showExpression (PatternExp pat) = show pat showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"+showExpression (WithExp name expr) = "(with " ++ show name ++ " " ++ show expr ++ ")" showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")" showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")" showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")"
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.3.0.3+Version: 0.3.1.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison
etc/lib/base.egi view
@@ -1,6 +1,4 @@-(define $Something- (type- {[$var-match (lambda [$tgt] {tgt})]}))+(define $Something (type {[$var-match (lambda [$tgt] {tgt})]})) (define $Bool (type
etc/lib/number.egi view
@@ -1,8 +1,7 @@ (define $Number (type {[$var-match (lambda [$tgt] {tgt})]- [$equal? (lambda [$val $tgt]- (= val tgt))]}))+ [$equal? (lambda [$val $tgt] (= val tgt))]})) (define $Int Number) @@ -18,6 +17,5 @@ {[$tgt (match (compare-number tgt 0) Order {[<greater> {(- tgt 1)}] [_ {}]})]}]})]- [$equal? (lambda [$val $tgt]- (= val tgt))]}))+ [$equal? (lambda [$val $tgt] (= val tgt))]}))
etc/lib/poker-hands.egi view
@@ -14,8 +14,7 @@ [_ {}]}] [diamond [] {[<diamond> {[]}]- [_ {}]}]- })]+ [_ {}]}]})] [$equal? (lambda [$val $tgt] (match [val tgt] [Suit Suit]@@ -23,15 +22,13 @@ [[<heart> <heart>] <true>] [[<club> <club>] <true>] [[<diamond> <diamond>] <true>]- [[_ _] <false>]}))]- }))+ [[_ _] <false>]}))]})) (define $Mod (lambda [$m] (type {[$var-match (lambda [$tgt] {(mod tgt m)})]- [$equal? (lambda [$val $tgt]- (= (mod val m) (mod tgt m)))]})))+ [$equal? (lambda [$val $tgt] (= (mod val m) (mod tgt m)))]}))) (define $Card (type@@ -42,9 +39,7 @@ {[<card $s $n> {[s n]}]}]})] [$equal? (lambda [$val $tgt] (match [val tgt] [Card Card]- {[[<card $s $n>- <card ,s ,n>]- <true>]+ {[[<card $s $n> <card ,s ,n>] <true>] [[_ _] <false>]}))]})) (define $poker-hands@@ -55,70 +50,61 @@ <cons <card ,S ,(- n 2)> <cons <card ,S ,(- n 3)> <cons <card ,S ,(- n 4)>- !<nil>- >>>>>+ !<nil>>>>>> <straight-flush>] [<cons <card _ $n> <cons <card _ ,n> !<cons <card _ ,n> !<cons <card _ ,n> !<cons _- !<nil>- >>>>>+ !<nil>>>>>> <four-of-kind>] [<cons <card _ $m> <cons <card _ ,m> <cons <card _ ,m> !<cons <card _ $n> !<cons <card _ ,n>- !<nil>- >>>>>+ !<nil>>>>>> <full-house>] [<cons <card $S _> !<cons <card ,S _> !<cons <card ,S _> !<cons <card ,S _> !<cons <card ,S _>- !<nil>- >>>>>+ !<nil>>>>>> <flush>] [<cons <card _ $n> <cons <card _ ,(- n 1)> <cons <card _ ,(- n 2)> <cons <card _ ,(- n 3)> <cons <card _ ,(- n 4)>- !<nil>- >>>>>+ !<nil>>>>>> <straight>] [<cons <card _ $n> <cons <card _ ,n> <cons <card _ ,n> <cons _ <cons _- !<nil>- >>>>>+ !<nil>>>>>> <three-of-kind>] [<cons <card _ $m> <cons <card _ ,m> !<cons <card _ $n> <cons <card _ ,n> !<cons _- !<nil>- >>>>>+ !<nil>>>>>> <two-pair>] [<cons <card _ $n> <cons <card _ ,n> <cons _ <cons _ <cons _- !<nil>- >>>>>+ !<nil>>>>>> <one-pair>] [<cons _ <cons _ <cons _ <cons _ <cons _- !<nil>- >>>>>+ !<nil>>>>>> <nothing>]})))
etc/sample/collection-test.egi view
@@ -1,128 +1,3 @@-(define $Suit- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[spade []- {[<spade> {[]}]- [_ {}]}]- [heart []- {[<heart> {[]}]- [_ {}]}]- [club []- {[<club> {[]}]- [_ {}]}]- [diamond []- {[<diamond> {[]}]- [_ {}]}]- })]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Suit Suit]- {[[<spade> <spade>] <true>]- [[<heart> <heart>] <true>]- [[<club> <club>] <true>]- [[<diamond> <diamond>] <true>]- [[_ _] <false>]}))]- }))--(define $Mod- (lambda [$m]- (type- {[$var-match (lambda [$tgt] {(mod tgt m)})]- [$equal? (lambda [$val $tgt]- (= (mod val m) (mod tgt m)))]})))--(define $Card- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[card [Suit (Mod 13)]- {[<card $s $n> {[s n]}]}]})]- [$equal? (lambda [$val $tgt]- (match [val tgt] [Card Card]- {[[<card $s $n>- <card ,s ,n>]- <true>]- [[_ _] <false>]}))]}))--(define $poker-hands- (lambda [$Cs]- (match Cs (Multiset Card)- {[<cons <card $S $n>- <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 _ ,n>- !<cons <card _ ,n>- !<cons <card _ ,n>- !<cons _- !<nil>- >>>>>- <four-of-kind>]- [<cons <card _ $m>- <cons <card _ ,m>- <cons <card _ ,m>- !<cons <card _ $n>- !<cons <card _ ,n>- !<nil>- >>>>>- <full-house>]- [<cons <card $S _>- !<cons <card ,S _>- !<cons <card ,S _>- !<cons <card ,S _>- !<cons <card ,S _>- !<nil>- >>>>>- <flush>]- [<cons <card _ $n>- <cons <card _ ,(- n 1)>- <cons <card _ ,(- n 2)>- <cons <card _ ,(- n 3)>- <cons <card _ ,(- n 4)>- !<nil>- >>>>>- <straight>]- [<cons <card _ $n>- <cons <card _ ,n>- <cons <card _ ,n>- <cons _- <cons _- !<nil>- >>>>>- <three-of-kind>]- [<cons <card _ $m>- <cons <card _ ,m>- !<cons <card _ $n>- <cons <card _ ,n>- !<cons _- !<nil>- >>>>>- <two-pair>]- [<cons <card _ $n>- <cons <card _ ,n>- <cons _- <cons _- <cons _- !<nil>- >>>>>- <one-pair>]- [<cons _- <cons _- <cons _- <cons _- <cons _- !<nil>- >>>>>- <nothing>]})))-- (test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number)) [<cons <cons $x _> <cons <cons $y _>@@ -130,11 +5,11 @@ <nil>>>> [x y z]])) -(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number))+(test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Number)) [<cons <cons $n _>- <cons <cons ,n _>- <cons <cons ,n _>- <nil>>>>+ <cons <cons ,n _>+ <cons <cons ,n _>+ <nil>>>> n])) (test (match (with $loop {1 @loop}) (List Number)@@ -225,7 +100,7 @@ !<cons ,n !<nil>>>>>> <ok>]- [ _ <ko>]}))+ [_ <ko>]})) (test (match {5 2 1 3 4} (Multiset Number) {[<cons $n@@ -235,7 +110,7 @@ <cons ,(- n 4) <nil>>>>>> <ok>]- [ _ <ko>]}))+ [_ <ko>]})) (test (match-all {1 2 3 4 5} (Multiset Number) [<cons $n $rest> [n rest]]))
etc/sample/io-test.egi view
@@ -1,11 +1,13 @@ (define $main (lambda [$:]- (do {[$: (write : "char : ")]+ (do {[$: (print : "input char : ")] [[$: $c] (read-char :)]+ [$: (print : "output : ")] [$: (write-char : c)] [$: (write-char : '\n')]- [$: (write : "expr : ")]+ [$: (print : "input number :")] [[$: $e] (read :)]- [$: (write : e)]+ [$: (print : "output : ")]+ [$: (write : (* 2 e))] [$: (write-char : '\n')]} :)))