egison 1.2.0 → 1.2.1
raw patch · 6 files changed
+272/−42 lines, 6 filesdep −haskell98
Dependencies removed: haskell98
Files
- Egison.hs +217/−39
- egison.cabal +2/−2
- etc/elisp/egison-mode.el +2/−0
- etc/lib/base.egi +1/−0
- etc/lib/number.egi +34/−1
- etc/sample/collection-test.egi +16/−0
Egison.hs view
@@ -1,5 +1,7 @@ module Main where+ import System.Environment+import Control.Monad import Control.Monad.Error import Data.IORef --import qualified Data.HashMap as Hash@@ -7,11 +9,14 @@ import Text.Parsec.String (Parser) import qualified Text.Parsec.Token as P import Text.Parsec.Language (haskellDef)-import IO hiding (try)+import System.IO+import Control.Exception (catch, SomeException)+import Prelude hiding (catch)+ import Paths_egison welcomeMsg :: String-welcomeMsg = "Egison, version 1.2.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+welcomeMsg = "Egison, version 1.2.1 : 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"@@ -72,7 +77,8 @@ getExpression :: IO Input getExpression = catch (do str <- getExpressionHelper False 0 return (Input str))- (\_ -> return Eof)+ (\e2 -> let e = e2 :: SomeException in+ return Eof) --@@ -117,8 +123,8 @@ readOrThrow :: Parser a -> String -> ThrowsError a readOrThrow parser input = case parse parser "egison" input of- Left err -> throwError (Parser err)- Right val -> return val+ Left err -> throwError (Parser err)+ Right val -> return val readTopExpression :: String -> IOThrowsError TopExpression readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr)@@ -140,24 +146,24 @@ mStr <- liftIO (readEgisonFile filename) case mStr of Nothing -> throwError (Default "load error")- Just str -> let str2 = removeComment str in- do topExprs <- readTopExpressionList str2- let loop topExprs2 = case topExprs2 of- [] -> return (filename ++ " loaded\n")- topExpr:rest -> do executeTopExpression defs topExpr- loop rest- in loop topExprs+ Just str -> do let str2 = removeComment str+ topExprs <- readTopExpressionList str2+ let loop topExprs2 = case topExprs2 of+ [] -> return (filename ++ " loaded\n")+ topExpr:rest -> do executeTopExpression defs topExpr+ loop rest+ loop topExprs executeTopExpression defs (LoadFile filename) = do mStr <- liftIO (readEgisonFile filename) case mStr of Nothing -> throwError (Default "load-file error")- Just str -> let str2 = removeComment str in- do topExprs <- readTopExpressionList str2- let loop topExprs2 = case topExprs2 of- [] -> return (filename ++ " loaded\n")- topExpr:rest -> do executeTopExpression defs topExpr- loop rest- in loop topExprs+ Just str -> do let str2 = removeComment str+ topExprs <- readTopExpressionList str2+ let loop topExprs2 = case topExprs2 of+ [] -> return (filename ++ " loaded\n")+ topExpr:rest -> do executeTopExpression defs topExpr+ loop rest+ loop topExprs executeTopExpression defs Execute = do topFrame <- makeTopFrame defs mainFn <- eval [topFrame] (VariableExp "main" [])@@ -174,7 +180,8 @@ readEgisonFile :: String -> IO (Maybe String) readEgisonFile filename = catch (do str <- (readFile filename) return (Just str))- (\_ -> return Nothing)+ (\e2 -> let e = e2 :: SomeException in+ return Nothing) runRepl :: Definitions -> IO ()@@ -182,7 +189,7 @@ case input of Eof -> flushStr byebyeMsg Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defsRef) >>= flushStr >> runRepl defsRef--- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs+-- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs loadBasicLibrary :: Definitions -> Definitions loadBasicLibrary defsRef = undefined@@ -219,6 +226,7 @@ | PatVarExp String [Expression] | PatVarOmitExp Expression | CutPatExp Expression+ | NotPatExp Expression | AndPatExp [Expression] | OrPatExp [Expression] | PredPatExp String [Expression]@@ -232,6 +240,7 @@ | DestructorExp DestructInfoExp | MatchExp Expression Expression [MatchClause] | MatchAllExp Expression Expression MatchClause+ | MatchMaxExp Expression Expression MatchMaxClause | ApplyExp Expression Expression | ApplyListExp Expression [Expression] @@ -247,6 +256,8 @@ data MatchClause = MatchClause Expression Expression +data MatchMaxClause = MatchMaxClause Expression Expression Expression+ type DestructInfoExp = [(String, Expression, [(PrimePat, Expression)])] data PrimePat = PrimeWildCard@@ -263,6 +274,7 @@ | Value Value data Value = World [Action]+ | Port Handle String | Character Char | Integer Integer | Double Double@@ -274,6 +286,7 @@ | PatVar String [Integer] | PredPat String [ObjectRef] | CutPat ObjectRef+ | NotPat ObjectRef | AndPat [ObjectRef] | OrPat [ObjectRef] | Function Environment FunPat Expression@@ -289,6 +302,13 @@ data Action = Read Value | Write Value | Print String+ | OpenInputFile String+ | OpenOutputFile String+ | CloseInputFile String+ | CloseOutputFile String+ | ReadFromPort String Value+ | WriteToPort String Value+ | PrintToPort String String data InnerValue = Element ObjectRef | SubCollection ObjectRef@@ -398,9 +418,9 @@ makeDestructInfo _ [] = return [] makeDestructInfo env ((cons, typeExp, dcs):deconsInfoExp) = do typeObjRef <- makeClosure env typeExp- let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in- do deconsInfo <- makeDestructInfo env deconsInfoExp- return ((cons, typeObjRef, dcs2):deconsInfo)+ let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs+ deconsInfo <- makeDestructInfo env deconsInfoExp+ return ((cons, typeObjRef, dcs2):deconsInfo) makeFrameHelper :: [FunPat] -> [ObjectRef] -> IOThrowsError Frame makeFrameHelper fpats objRefs =@@ -432,18 +452,18 @@ evalVariableList _ [] = return [] evalVariableList env ((name,numExprs):rest) = do numVals <- evalList env numExprs- let nums = integerValListToIntegerList numVals in- do vars <- evalVariableList env rest- return ((name,nums):vars)+ let nums = integerValListToIntegerList numVals+ vars <- evalVariableList env rest+ return ((name,nums):vars) makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame makeRecursiveFrame env bind = do vars <- evalVariableList env (map fst bind)- let exprs = map snd bind in- do objRefs <- liftIO (makeClosureList [] exprs)- let newFrame = zip vars objRefs in- do liftIO (makeRecursiveFrameHelper env newFrame newFrame)- return newFrame+ let exprs = map snd bind+ objRefs <- liftIO (makeClosureList [] exprs)+ let newFrame = zip vars objRefs+ liftIO (makeRecursiveFrameHelper env newFrame newFrame)+ return newFrame makeTopFrame :: Definitions -> IOThrowsError Frame makeTopFrame defsRef = do@@ -637,6 +657,9 @@ <|> do char '!' expr <- parseExpression return (CutPatExp expr)+ <|> do char '^'+ expr <- parseExpression+ return (NotPatExp expr) <|> do char ',' expr <- parseExpression return (PredPatExp "equal?" [expr])@@ -741,6 +764,15 @@ cls <- parseMatchClause spaces return (MatchAllExp tgt typ cls)+ <|> do try (do string "match-max"+ spaces1)+ tgt <- parseExpression+ spaces+ typ <- parseExpression+ spaces+ cls <- parseMatchMaxClause+ spaces+ return (MatchMaxExp tgt typ cls) <|> do try (do string "apply" spaces1) fn <- parseExpression@@ -856,6 +888,14 @@ body <- parseExpression return (MatchClause pat body)) +parseMatchMaxClause :: Parser MatchMaxClause+parseMatchMaxClause = brackets (do pat <- parseExpression+ spaces+ expr <- parseExpression+ spaces+ body <- parseExpression+ return (MatchMaxClause pat expr body))+ -- -- Show --@@ -890,6 +930,7 @@ showExpression (PatVarExp name nums) = "$" ++ name ++ unwordsNums nums showExpression (PatVarOmitExp expr) = "$~" ++ showExpression expr showExpression (CutPatExp p) = "!" ++ show p+showExpression (NotPatExp p) = "^" ++ show p showExpression (AndPatExp ps) = "(& " ++ unwordsList ps ++ ")" showExpression (OrPatExp ps) = "(| " ++ unwordsList ps ++ ")" showExpression (PredPatExp name ps) = "(? " ++ name ++ " " ++ unwordsList ps ++ ")"@@ -1107,12 +1148,12 @@ eval1 _ (DoubleExp d) = return (Double d) eval1 env (VariableExp name numExprs) = do numVals <- evalList env numExprs- let nums = integerValListToIntegerList numVals in- eval1Variable env name nums+ let nums = integerValListToIntegerList numVals+ eval1Variable env name nums eval1 env (SymbolExp name numExprs) = do numVals <- evalList env numExprs- let nums = integerValListToIntegerList numVals in- return (Symbol name nums)+ let nums = integerValListToIntegerList numVals+ return (Symbol name nums) eval1 env (OmitExp expr) = do val <- eval1 env expr case val of@@ -1142,6 +1183,9 @@ eval1 env (PredPatExp name exprs) = do objRefs <- liftIO (makeClosureList env exprs) return (PredPat name objRefs)+eval1 env (NotPatExp expr) = do+ objRef <- liftIO (makeClosure env expr)+ return (NotPat objRef) eval1 env (CutPatExp expr) = do objRef <- liftIO (makeClosure env expr) return (CutPat objRef)@@ -1188,6 +1232,10 @@ typObj <- liftIO (makeClosure env typExp) tgtObj <- liftIO (makeClosure env tgtExp) evalMatchAllExp env typObj tgtObj mC +eval1 env (MatchMaxExp tgtExp typExp mC) = do+ typObj <- liftIO (makeClosure env typExp)+ tgtObj <- liftIO (makeClosure env tgtExp)+ evalMatchMaxExp env typObj tgtObj mC eval1 env expr@(ApplyListExp fnExp argsExps) = do fnVal <- eval1 env fnExp case fnVal of@@ -1225,6 +1273,7 @@ expandMacro mf (PatVarExp name numExprs) = PatVarExp name (mapExpandMacro mf numExprs) expandMacro mf (PatVarOmitExp expr) = PatVarOmitExp (expandMacro mf expr) expandMacro mf (CutPatExp expr) = CutPatExp (expandMacro mf expr)+expandMacro mf (NotPatExp expr) = NotPatExp (expandMacro mf expr) expandMacro mf (AndPatExp exprs) = AndPatExp (mapExpandMacro mf exprs) expandMacro mf (OrPatExp exprs) = OrPatExp (mapExpandMacro mf exprs) expandMacro mf (PredPatExp name exprs) = PredPatExp name (mapExpandMacro mf exprs)@@ -1355,6 +1404,53 @@ rest <- evalMatchAllExpHelper env frames expr return (Element objRef:rest) +evalMatchMaxExp :: Environment -> ObjectRef -> ObjectRef -> MatchMaxClause -> IOThrowsError Value+evalMatchMaxExp env typObjRef tgtObjRef (MatchMaxClause pat expr body) = do+ patObjRef <- liftIO (makeClosure env pat)+ matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]+ case matchs of+ [] -> throwError (Default "matchMax: no matching")+ _ -> do+ evallist <- mapM (\frame -> eval (frame:env) expr) matchs+ let numlist = map (\val -> case val of+ Integer n -> n+ ) evallist+ maxplace <- maxlistplace numlist+ maxmatchs <- pickupnumlist matchs maxplace+ innerVals <- evalMatchAllExpHelper env maxmatchs body+ retObjRef <- liftIO (newIORef (Value (Collection innerVals)))+ cEval retObjRef++maxlistplace :: [Integer] -> IOThrowsError [Integer]+maxlistplace [] = throwError (Default "matchMax: no number list")+maxlistplace (x:xs) =+ let mhelper ls maxnumber maxplace nowplace = case ls of+ [] -> return maxplace+ (y:ys) -> if (y > maxnumber) + then mhelper ys y [nowplace] (nowplace + 1)+ else if (y == maxnumber)+ then mhelper ys maxnumber (nowplace:maxplace) (nowplace + 1)+ else mhelper ys maxnumber maxplace (nowplace + 1)+ in mhelper xs x [1] 2+ +pickupnum :: [a] -> Integer -> IOThrowsError a+pickupnum [] _ = throwError (Default "matchMax: cannot pick up")+pickupnum (x:xs) n = if (n >= 1)+ then if (n > 1)+ then pickupnum xs (n - 1)+ else return x+ else throwError (Default "matchMax: cannot pick up")++pickupnumlist :: [a] -> [Integer] -> IOThrowsError [a] +pickupnumlist [] _ = throwError (Default "matchMax: cannot pick up")+pickupnumlist list n = + let phelper ls nl picked = case nl of+ [] -> return picked+ (m:ms) -> do+ nowpick <- pickupnum ls m+ phelper ls ms (nowpick:picked)+ in phelper list n []+ -- -- Pattern Match --@@ -1425,6 +1521,11 @@ (InductiveData "true" []) -> patternMatch1 ((MState frame atoms):states) (InductiveData "false" []) -> patternMatch1 states _ -> throwError (Default "patternMatch1: return value of pred-pattern is not boolean")+ Value (NotPat pat) -> + do retFrames <- patternMatch [(MState frame [(MAtom (PClosure bf pat) tgtObjRef typObjRef)])]+ case retFrames of+ [] -> patternMatch1 ((MState frame atoms):states)+ _ -> patternMatch1 states Value (AndPat pats) -> patternMatch1 ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states) Value (OrPat pats) ->@@ -1508,6 +1609,11 @@ (InductiveData "true" []) -> patternMatch ((MState frame atoms):states) (InductiveData "false" []) -> patternMatch states _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean")+ Value (NotPat pat) -> + do retFrames <- patternMatch [(MState frame [(MAtom (PClosure bf pat) tgtObjRef typObjRef)])]+ case retFrames of+ [] -> patternMatch ((MState frame atoms):states)+ _ -> patternMatch states Value (AndPat pats) -> patternMatch ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states) Value (OrPat pats) ->@@ -1694,11 +1800,20 @@ getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value) getBuiltin name = case name of+ "open-input-file" -> Just builtinOpenInputFile+ "open-output-file" -> Just builtinOpenInputFile+ "close-input-file" -> Just builtinCloseInputFile+ "close-output-file" -> Just builtinCloseOutputFile "read" -> Just builtinRead "write" -> Just builtinWrite "print" -> Just builtinPrint "read-char" -> Just builtinReadChar "write-char" -> Just builtinWriteChar+ "read-from-port" -> Just builtinReadFromPort+ "write-to-port" -> Just builtinWriteToPort+ "print-to-port" -> Just builtinPrintToPort+ "read-char-from-port" -> Just builtinReadCharFromPort+ "write-char-to-port" -> Just builtinWriteCharToPort "=c" -> Just builtinEqualCharacter "compare-character" -> Just builtinCompareCharacter "int-to-float" -> Just builtinIntToFloat@@ -1714,7 +1829,7 @@ "dev" -> Just builtinDevide "mod" -> Just builtinMod "=f" -> Just builtinEqualFloat- "compare-float" -> Just builtinCompareFloat+ "compare-float" -> Just builtinCompareFloat; "+f" -> Just builtinPlusFloat "-f" -> Just builtinMinusFloat "*f" -> Just builtinMultiplyFloat@@ -1739,6 +1854,34 @@ "atanh" -> Just builtinAtanh _ -> Nothing +builtinOpenInputFile :: [Value] -> IOThrowsError Value+builtinOpenInputFile [(World actions), val] = do+ fileName <- charCollectionToString val+ port <- liftM Port $ liftIO $ openFile fileName ReadMode+ ret <- liftIO (makeTupleFromValueList [World ((OpenInputFile fileName):actions), (port fileName)])+ return ret+builtinOpenInputFile _ = throwError (Default "invalid args to open-input-file")+ +builtinOpenOutputFile :: [Value] -> IOThrowsError Value+builtinOpenOutputFile [(World actions), val] = do+ fileName <- charCollectionToString val+ port <- liftM Port $ liftIO $ openFile fileName WriteMode+ ret <- liftIO (makeTupleFromValueList [World ((OpenOutputFile fileName):actions), (port fileName)])+ return ret+builtinOpenOutputFile _ = throwError (Default "invalid args to open-output-file")+ +builtinCloseInputFile :: [Value] -> IOThrowsError Value+builtinCloseInputFile [(World actions), (Port handle fileName)] = do+ liftIO $ hClose handle+ return (World ((CloseInputFile fileName):actions))+builtinCloseInputFile _ = throwError (Default "invalid args to close-input-file")+ +builtinCloseOutputFile :: [Value] -> IOThrowsError Value+builtinCloseOutputFile [(World actions), (Port handle fileName)] = do+ liftIO $ hClose handle+ return (World ((CloseInputFile fileName):actions))+builtinCloseOutputFile _ = throwError (Default "invalid args to close-output-file")+ builtinRead :: [Value] -> IOThrowsError Value builtinRead [(World actions)] = do str <- liftIO (getExpressionHelper False 0)@@ -1749,7 +1892,7 @@ builtinWrite :: [Value] -> IOThrowsError Value builtinWrite [(World actions), val] = do- valStr <-showValue val+ valStr <- showValue val liftIO (flushStr valStr) return (World ((Write val):actions)) builtinWrite _ = throwError (Default "invalid args to write")@@ -1775,6 +1918,42 @@ builtinWriteChar _ = throwError (Default "invalid args to write-char") +builtinReadFromPort :: [Value] -> IOThrowsError Value+builtinReadFromPort [(World actions)] = do+ str <- liftIO (getExpressionHelper False 0)+ val <- readValue str+ ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])+ return ret+builtinReadFromPort _ = throwError (Default "invalid args to read-from-port")+ +builtinWriteToPort :: [Value] -> IOThrowsError Value+builtinWriteToPort [(World actions), val] = do+ valStr <- showValue val+ liftIO (flushStr valStr)+ return (World ((Write val):actions))+builtinWriteToPort _ = throwError (Default "invalid args to write-to-port")++builtinPrintToPort :: [Value] -> IOThrowsError Value+builtinPrintToPort [(World actions), val] = do+ str <- charCollectionToString val+ liftIO (flushStr str)+ return (World ((Print str):actions))+builtinPrintToPort _ = throwError (Default "invalid args to print-to-port")+ +builtinReadCharFromPort :: [Value] -> IOThrowsError Value+builtinReadCharFromPort [(World actions)] = do+ c <- liftIO getChar+ ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])+ return ret+builtinReadCharFromPort _ = throwError (Default "invalid args to read-char-from-port")++builtinWriteCharToPort :: [Value] -> IOThrowsError Value+builtinWriteCharToPort [(World actions), (Character c)] = do+ liftIO (putChar c)+ return (World ((Write (Character c)):actions))+builtinWriteCharToPort _ = throwError (Default "invalid args to write-char-to-port")++ builtinEqualCharacter :: [Value] -> IOThrowsError Value builtinEqualCharacter [(Character c1), (Character c2)] = if (c1 == c2) then return (InductiveData "true" [])@@ -1960,4 +2139,3 @@ objStr <- liftIO $ showObjectRef objRef liftIO $ putStr $ tag ++ ": " liftIO $ putStrLn objStr-
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: 1.2.0+Version: 1.2.1 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison@@ -60,7 +60,7 @@ Main-is: Egison.hs -- Packages needed in order to build this package.- Build-depends: base >= 4.0 && < 5, haskell98, mtl, parsec >= 3.0+ Build-depends: base >= 4.0 && < 5, mtl, parsec >= 3.0 -- Modules not exported by this package. Other-modules: Paths_egison
etc/elisp/egison-mode.el view
@@ -21,6 +21,8 @@ "\\\." "\\\," "\\\!"+ "\\\~"+ "\\\#" "|" "\\\&" "@"
etc/lib/base.egi view
@@ -62,3 +62,4 @@ [[<equal> <equal>] <true>] [[<greater> <greater>] <true>] [[_ _] <false>]}))]}))+
etc/lib/number.egi view
@@ -26,4 +26,37 @@ (lambda [$m $n] (match (compare-integer m n) Order {[<less> {m @(between (+ m 1) n)}]- [<equal> {n}]})))+ [<equal> {n}]+ [<greater> {}]+ })))++(define $min+ (lambda [$ns]+ (match ns (List Integer)+ {[<cons $n <nil>> n]+ [<cons $n $rs>+ (let {[$r (min rs)]}+ (match (compare-integer n r) Order+ {[<less> n]+ [_ r]}))]})))++(define $max+ (lambda [$ns]+ (match ns (List Integer)+ {[<cons $n <nil>> n]+ [<cons $n $rs>+ (let {[$r (max rs)]}+ (match (compare-integer n r) Order+ {[<greater> n]+ [_ r]}))]})))++(define $gcd+ (lambda [$ns]+ (match ns (Set Integer)+ {[<cons $n <nil>> n]+ [<cons (& ,(min ns) $m)+ $rs>+ (gcd {m @((remove-all Integer)+ (map (lambda [$r] (mod r m))+ rs)+ 0)})]})))
etc/sample/collection-test.egi view
@@ -182,3 +182,19 @@ [_ <ko>]}))) (test (isStraight? {1 2}))++(define $CompactList+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[nil []+ {[$tgt (match-all tgt (List a) [<nil> []])]}]+ [cons [a (List a)]+ {[$tgt + [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]])}]}]})]+ [$equal? (lambda [$val $tgt]+ )]})))