egison 0.3.1.1 → 0.4.0.0
raw patch · 4 files changed
+152/−63 lines, 4 files
Files
- Egison.hs +91/−18
- egison.cabal +1/−1
- etc/sample/collection-test.egi +46/−43
- etc/sample/io-test.egi +14/−1
Egison.hs view
@@ -2,6 +2,7 @@ import System.Environment import Control.Monad.Error import Data.IORef+--import qualified Data.HashMap as Hash import Text.Parsec hiding (spaces) import Text.Parsec.String (Parser) import qualified Text.Parsec.Token as P@@ -9,7 +10,7 @@ import IO hiding (try) welcomeMsg :: String-welcomeMsg = "Egison, version 0.3.1.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+welcomeMsg = "Egison, version 0.4.0.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"@@ -145,7 +146,7 @@ executeTopExpression defs Execute = do topFrame <- makeTopFrame defs mainFn <- eval (Environment [topFrame]) (SymbolExp "main")- args <- liftIO (newIORef (Value (World [])))+ args <- liftIO (newIORef (Value (World initMemory []))) case mainFn of Function funEnv fpat body -> do frame <- makeFrame fpat args@@ -225,7 +226,34 @@ data IntermidiateValue = Closure Environment Expression | Value Value -data Value = World [Action]++--type Memory = Hash.Map Value [Value]+type Memory = [(Value, Value)]+ +--initMemory :: Memory+--initMemory = Hash.empty+initMemory :: Memory+initMemory = []++--addToMemory :: Value -> Value -> Memory -> Memory+--addToMemory key val memory =+-- let mStack = Hash.lookup key memory in+-- let newStack = case mStack of+-- Nothing -> [val]+-- Just s -> (val : s) in+-- Hash.insert key newStack memory+addToMemory :: Value -> Value -> Memory -> Memory+addToMemory key val memory = (key, val) : memory++lookupMemory :: Value -> Memory -> IOThrowsError (Maybe Value)+lookupMemory key [] = return Nothing+lookupMemory key ((k,v):memory) = do+ b <- isEqualValue key k+ if b+ then return (Just v)+ else lookupMemory key memory++data Value = World Memory [Action] | Character Char | Integer Integer | Double Double@@ -239,11 +267,40 @@ | DeconstructorFunction DeconsInfo | BuiltinFunction ([Value] -> IOThrowsError Value) +isEqualValue :: Value -> Value -> IOThrowsError Bool+isEqualValue (Character c1) (Character c2) = return (c1 == c2)+isEqualValue (Integer n1) (Integer n2) = return (n1 == n2)+isEqualValue (Double d1) (Double d2) = return (d1 == d2)+isEqualValue (InductiveData c1 iValRefs1) (InductiveData c2 iValRefs2) =+ if (c1 == c2)+ then do vals1 <- liftIO (iValRefListToValueList iValRefs1)+ vals2 <- liftIO (iValRefListToValueList iValRefs2)+ isEqualValueList vals1 vals2+ else return False+isEqualValue (Tuple iValRefs1) (Tuple iValRefs2) = do+ vals1 <- liftIO (iValRefListToValueList iValRefs1)+ vals2 <- liftIO (iValRefListToValueList iValRefs2)+ isEqualValueList vals1 vals2+isEqualValue val1@(Collection _) val2@(Collection _) = do+ vals1 <- liftIO (collectionToValueList val1)+ vals2 <- liftIO (collectionToValueList val2)+ isEqualValueList vals1 vals2+isEqualValue _ _ = return False++isEqualValueList :: [Value] -> [Value] -> IOThrowsError Bool+isEqualValueList [] [] = return True+isEqualValueList (v1:vals1) (v2:vals2) = do+ b <- isEqualValue v1 v2+ if b+ then isEqualValueList vals1 vals2+ else return False+isEqualValueList _ _ = return False + data Action = Read Value | Write Value | Print String- | Memorize Value- | Remember Value+ | Memorize Value Value+ | Remember Value Value data InnerValue = Element (IORef IntermidiateValue) | SubCollection (IORef IntermidiateValue)@@ -678,7 +735,7 @@ return (SubCollection iValRef:innerVals) showValue :: Value -> IO String-showValue (World _) = return "#<world>"+showValue (World _ _) = return "#<world>" showValue (Character c) = return (show c) showValue (Integer n) = return (show n) showValue (Double d) = return (show d)@@ -1014,7 +1071,7 @@ _ -> 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")+patternMatch _ _ _ _ = throwError (Default "invalid pattern : you should add ',' to the head of value") doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame] doDeconstruct [] _ _ _ = throwError (Default "no match decons clause")@@ -1072,7 +1129,8 @@ InductiveData cons iValRefs -> if pCons == cons then primitivePatternMatchAll pPats iValRefs else return Nothing- _ -> throwError (Default "primitive : not inductive value to primitive inductive pattern")+ _ -> do valStr <- liftIO (showValue val)+ throwError (Default ("primitive : not inductive value to primitive inductive pattern : " ++ valStr)) primitivePatternMatch (TuplePrimePat pPats) iValRef = do val <- force iValRef case val of@@ -1273,6 +1331,8 @@ "print" -> Just builtinPrint "read-char" -> Just builtinReadChar "write-char" -> Just builtinWriteChar+ "memorize" -> Just builtinMemorize+ "remember" -> Just builtinRemember "int-to-float" -> Just builtinIntToFloat "ceiling" -> Just builtinCeiling "floor" -> Just builtinFloor@@ -1312,40 +1372,53 @@ _ -> Nothing builtinRead :: [Value] -> IOThrowsError Value-builtinRead [(World actions)] = do+builtinRead [(World memory actions)] = do str <- liftIO (getExpressionHelper False 0) val <- readValue str- ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])+ ret <- liftIO (makeTupleFromValueList [World memory ((Read val):actions), val]) return ret builtinRead _ = throwError (Default "invalid args to read") builtinWrite :: [Value] -> IOThrowsError Value-builtinWrite [(World actions), val] = do+builtinWrite [(World memory actions), val] = do valStr <- liftIO (showValue val) liftIO (flushStr valStr)- return (World ((Write val):actions))+ return (World memory ((Write val):actions)) builtinWrite _ = throwError (Default "invalid args to write") builtinPrint :: [Value] -> IOThrowsError Value-builtinPrint [(World actions), val] = do+builtinPrint [(World memory actions), val] = do str <- charCollectionToString val liftIO (flushStr str)- return (World ((Print str):actions))+ return (World memory ((Print str):actions)) builtinPrint _ = throwError (Default "invalid args to print") builtinReadChar :: [Value] -> IOThrowsError Value-builtinReadChar [(World actions)] = do+builtinReadChar [(World memory actions)] = do c <- liftIO getChar- ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])+ ret <- liftIO (makeTupleFromValueList [World memory ((Read (Character c)):actions), Character c]) return ret builtinReadChar _ = throwError (Default "invalid args to read-char") builtinWriteChar :: [Value] -> IOThrowsError Value-builtinWriteChar [(World actions), (Character c)] = do+builtinWriteChar [(World memory actions), (Character c)] = do liftIO (putChar c)- return (World ((Write (Character c)):actions))+ return (World memory ((Write (Character c)):actions)) builtinWriteChar _ = throwError (Default "invalid args to write-char") ++builtinMemorize :: [Value] -> IOThrowsError Value+builtinMemorize [(World memory actions), key, val] =+ let newMemory = addToMemory key val memory in+ return (World newMemory ((Memorize key val):actions))++builtinRemember :: [Value] -> IOThrowsError Value+builtinRemember [(World memory actions), key] = do+ mVal <- lookupMemory key memory+ case mVal of+ Nothing -> throwError (Default "can not remember")+ Just val -> do iValRefs <- liftIO (makeIValRefList [(World memory ((Remember key val):actions)), val])+ return (Tuple iValRefs) builtinIntToFloat :: [Value] -> IOThrowsError Value builtinIntToFloat [Integer n] = return (Double (fromInteger n))
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.1.1+Version: 0.4.0.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison
etc/sample/collection-test.egi view
@@ -1,44 +1,47 @@-(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number))+(test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer)) [<cons <cons $x _> <cons <cons $y _> <cons <cons $z _> <nil>>>> [x y z]])) -(test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Number))+(test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Integer)) [<cons <cons $n _> <cons <cons ,n _> <cons <cons ,n _> <nil>>>> n])) -(test (match (with $loop {1 @loop}) (List Number)+(test (match-all {1 2 3 4 5} (Multiset Integer)+ [<cons $m <cons $n _>> [m n]]))++(test (match (with $loop {1 @loop}) (List Integer) {[<cons $m <cons $n _>> [m n]] [_ <not-ok>]})) (test (let {[$pat <cons ,1 <nil>>]}- (match {1} (Multiset Number)+ (match {1} (Multiset Integer) {[pat <ok>] [_ <not-ok>]}))) -(test (match {1} (Multiset Number)+(test (match {1} (Multiset Integer) {[(of {<nil> <cons ,1 <nil>>}) <ok>] [_ <not-ok>]})) (test (let {[$loop <cons ,1 (of {<nil> loop})>]}- (match {1 1 1 1} (Multiset Number)+ (match {1 1 1 1} (Multiset Integer) {[loop <ok>] [_ <not-ok>]}))) -(test (match {1 1 1 1} (Multiset Number)+(test (match {1 1 1 1} (Multiset Integer) {[(with $loop <cons ,1 (of {<nil> loop})>) <ok>] [_ <not-ok>]})) -(test (match {1 1 1 1} (Multiset Number)+(test (match {1 1 1 1} (Multiset Integer) {[<cons ,1 (with $loop <cons ,1 (of {<nil> loop})>)> <ok>] [_ <not-ok>]})) -(test (match {0 1 0 1} (List Number)+(test (match {0 1 0 1} (List Integer) {[(of {<cons ,0 (with $loop (of {<cons ,0 loop> <cons ,1 loop> <nil>}))> <cons ,1 (with $loop (of {<cons ,0 loop> <cons ,1 loop> <nil>}))>}) <ok>]@@ -46,22 +49,22 @@ (test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]])) -(test (match-all {1 2 3} (List Number)+(test (match-all {1 2 3} (List Integer) [<join $hs $ts> [hs ts]])) -(test (match-all {1 2 3} (Multiset Number)+(test (match-all {1 2 3} (Multiset Integer) [<join $hs $ts> [hs ts]])) -(test (match-all {1 2 3} (Set Number)+(test (match-all {1 2 3} (Set Integer) [<join $hs $ts> [hs ts]])) -(test (match-all {1 2 3} (List Number)+(test (match-all {1 2 3} (List Integer) [<join $hs <cons $x $ts>> [hs x ts]])) -(test (match-all {1 2 3} (Multiset Number)+(test (match-all {1 2 3} (Multiset Integer) [<join $hs <cons $x $ts>> [hs x ts]])) -(test (match-all {1 2 3} (Set Number)+(test (match-all {1 2 3} (Set Integer) [<join $hs <cons $x $ts>> [hs x ts]])) (test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))@@ -92,7 +95,7 @@ <card <heart> 1> <card <diamond> 3>})) -(test (match {2 7 7 2 7} (Multiset Number)+(test (match {2 7 7 2 7} (Multiset Integer) {[<cons $m <cons ,m <cons ,m@@ -102,7 +105,7 @@ <ok>] [_ <ko>]})) -(test (match {5 2 1 3 4} (Multiset Number)+(test (match {5 2 1 3 4} (Multiset Integer) {[<cons $n <cons ,(- n 1) <cons ,(- n 2)@@ -112,7 +115,7 @@ <ok>] [_ <ko>]})) -(test (match-all {1 2 3 4 5} (Multiset Number)+(test (match-all {1 2 3 4 5} (Multiset Integer) [<cons $n $rest> [n rest]])) (test (let {[$f (lambda [$x] (+ (g x) 10))]@@ -126,37 +129,37 @@ [$inductive-match (deconstructor {[nil []- {[$tgt (match-all tgt (List a) [<nil> []])]- }]+ {[$tgt (match-all tgt (List a) [<nil> []])]}] [cons [a (List a)] {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])- @(match-all (reverse 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-all tgt (List a) [<join $xs $ys> [xs ys]])- @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]- }]- })]+ @(match-all (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))))]- })))+ ((type-ref (List a) equal?) val (reverse tgt))))]}))) -(test (match-all {1 2 3} (Stick Number) [<cons $x $xs> [x xs]]))-(test (match-all {1 2 3} (Stick Number) [<join $xs $ys> [xs ys]]))-(test (match-all {1 2 3 4} (Stick Number) [<join $xs <cons $w $ys>> [xs w ys]]))-(test (match-all {1 2 3} (Stick Number) [,{3 2 1} <ok>]))+(test (match-all {1 2 3} (Stick Integer) [<cons $x $xs> [x xs]]))+(test (match-all {1 2 3} (Stick Integer) [<join $xs $ys> [xs ys]]))+(test (match-all {1 2 3 4} (Stick Integer) [<join $xs <cons $w $ys>> [xs w ys]]))+(test (match-all {1 2 3} (Stick Integer) [,{3 2 1} <ok>])) +(test (match {2 7 7 2 7} (Multiset Integer)+ {[<cons $m+ <cons ,m+ <cons ,m+ $tmp1>>>+ (match tmp1 (Multiset Integer)+ {[<cons $n $tmp2>+ (match tmp2 (Multiset Integer)+ {[<cons ,n $tmp3>+ (match tmp3 (Multiset Integer)+ {[<nil> <ok>]})]})]})]+ [_ <ko>]})) -(match {2 7 7 2 7} (Multiset Number)- {[<cons $m- <cons ,m- <cons ,m- $tmp1>>>- (match tmp1 (Multiset Number)- {[<cons $n $tmp2>- (match tmp2 (Multiset Number)- {[<cons ,n $tmp3>- (match tmp3 (Multiset Number)- {[<nil> <ok>]})]})]})]- [_ <ko>]})+(test (match-all {1 2 3 4 5} (List Integer)+ [<join _ <cons $m <join _ <cons $n _>>>> [m n]]))++(test (match-all {1 2 3 4} (List Integer)+ [<join _ <join $ns _>> ns]))
etc/sample/io-test.egi view
@@ -8,6 +8,19 @@ [$: (print : "input number :")] [[$: $e] (read :)] [$: (print : "output : ")]- [$: (write : (* 2 e))]+ [$: (write : e)]+ [$: (write-char : '\n')]}+ :)))++(define $main+ (lambda [$:]+ (do {[$: (memorize : 10 20)]+ [$: (memorize : [0 20] 30)]+ [$: (memorize : <test 0 20> 40)]+ [$: (memorize : {0 20 10} 40)]+ [$: (memorize : "abc" 40)]+ [$: (memorize : [0 20] 60)]+ [[$: $n] (remember : {0 20 10})]+ [$: (write : n)] [$: (write-char : '\n')]} :)))