diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -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 ++ ")" 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.3.0.3 +Version: 0.3.1.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison diff --git a/etc/lib/base.egi b/etc/lib/base.egi --- a/etc/lib/base.egi +++ b/etc/lib/base.egi @@ -1,6 +1,4 @@ -(define $Something - (type - {[$var-match (lambda [$tgt] {tgt})]})) +(define $Something (type {[$var-match (lambda [$tgt] {tgt})]})) (define $Bool (type diff --git a/etc/lib/number.egi b/etc/lib/number.egi --- a/etc/lib/number.egi +++ b/etc/lib/number.egi @@ -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 {[ {(- tgt 1)}] [_ {}]})]}]})] - [$equal? (lambda [$val $tgt] - (= val tgt))]})) + [$equal? (lambda [$val $tgt] (= val tgt))]})) diff --git a/etc/lib/poker-hands.egi b/etc/lib/poker-hands.egi --- a/etc/lib/poker-hands.egi +++ b/etc/lib/poker-hands.egi @@ -14,8 +14,7 @@ [_ {}]}] [diamond [] {[ {[]}] - [_ {}]}] - })] + [_ {}]}]})] [$equal? (lambda [$val $tgt] (match [val tgt] [Suit Suit] @@ -23,15 +22,13 @@ [[ ] ] [[ ] ] [[ ] ] - [[_ _] ]}))] - })) + [[_ _] ]}))]})) (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 @@ {[ {[s n]}]}]})] [$equal? (lambda [$val $tgt] (match [val tgt] [Card Card] - {[[ - ] - ] + {[[ ] ] [[_ _] ]}))]})) (define $poker-hands @@ -55,70 +50,61 @@ - ! - >>>>> + !>>>>> ] [ ! ! ! - >>>>> + !>>>>> ] [ ! ! - ! - >>>>> + !>>>>> ] [ ! ! ! ! - ! - >>>>> + !>>>>> ] [ - ! - >>>>> + !>>>>> ] [ - >>>>> + !>>>>> ] [ ! ! - >>>>> + !>>>>> ] [ - >>>>> + !>>>>> ] [ - >>>>> + !>>>>> ]}))) 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 @@ -1,128 +1,3 @@ -(define $Suit - (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[spade [] - {[ {[]}] - [_ {}]}] - [heart [] - {[ {[]}] - [_ {}]}] - [club [] - {[ {[]}] - [_ {}]}] - [diamond [] - {[ {[]}] - [_ {}]}] - })] - [$equal? - (lambda [$val $tgt] - (match [val tgt] [Suit Suit] - {[[ ] ] - [[ ] ] - [[ ] ] - [[ ] ] - [[_ _] ]}))] - })) - -(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)] - {[ {[s n]}]}]})] - [$equal? (lambda [$val $tgt] - (match [val tgt] [Card Card] - {[[ - ] - ] - [[_ _] ]}))]})) - -(define $poker-hands - (lambda [$Cs] - (match Cs (Multiset Card) - {[ - - - - - >>>>> - ] - [ - - ! - ! - ! - >>>>> - ] - [ - - - ! - ! - ! - >>>>> - ] - [ - ! - ! - ! - ! - ! - >>>>> - ] - [ - - - - - ! - >>>>> - ] - [ - - - - >>>>> - ] - [ - - ! - - ! - >>>>> - ] - [ - - - >>>>> - ] - [ - >>>>> - ]}))) - - (test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number)) [ @@ -130,11 +5,11 @@ >>> [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)) [ - - - >>> + + + >>> n])) (test (match (with $loop {1 @loop}) (List Number) @@ -225,7 +100,7 @@ !>>>>> ] - [ _ ]})) + [_ ]})) (test (match {5 2 1 3 4} (Multiset Number) {[>>>>> ] - [ _ ]})) + [_ ]})) (test (match-all {1 2 3 4 5} (Multiset Number) [ [n rest]])) diff --git a/etc/sample/io-test.egi b/etc/sample/io-test.egi --- a/etc/sample/io-test.egi +++ b/etc/sample/io-test.egi @@ -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')]} :)))