diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -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 - 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: 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 diff --git a/etc/elisp/egison-mode.el b/etc/elisp/egison-mode.el --- a/etc/elisp/egison-mode.el +++ b/etc/elisp/egison-mode.el @@ -21,6 +21,8 @@ "\\\." "\\\," "\\\!" + "\\\~" + "\\\#" "|" "\\\&" "@" diff --git a/etc/lib/base.egi b/etc/lib/base.egi --- a/etc/lib/base.egi +++ b/etc/lib/base.egi @@ -62,3 +62,4 @@ [[ ] ] [[ ] ] [[_ _] ]}))]})) + diff --git a/etc/lib/number.egi b/etc/lib/number.egi --- a/etc/lib/number.egi +++ b/etc/lib/number.egi @@ -26,4 +26,37 @@ (lambda [$m $n] (match (compare-integer m n) Order {[ {m @(between (+ m 1) n)}] - [ {n}]}))) + [ {n}] + [ {}] + }))) + +(define $min + (lambda [$ns] + (match ns (List Integer) + {[> n] + [ + (let {[$r (min rs)]} + (match (compare-integer n r) Order + {[ n] + [_ r]}))]}))) + +(define $max + (lambda [$ns] + (match ns (List Integer) + {[> n] + [ + (let {[$r (max rs)]} + (match (compare-integer n r) Order + {[ n] + [_ r]}))]}))) + +(define $gcd + (lambda [$ns] + (match ns (Set Integer) + {[> n] + [ + (gcd {m @((remove-all Integer) + (map (lambda [$r] (mod r m)) + rs) + 0)})]}))) 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 @@ -182,3 +182,19 @@ [_ ]}))) (test (isStraight? {1 2})) + +(define $CompactList + (lambda [$a] + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (destructor + {[nil [] + {[$tgt (match-all tgt (List a) [ []])]}] + [cons [a (List a)] + {[$tgt + [join [(List a) (List a)] + {[$tgt {@(match-all tgt (List a) [ [xs ys]]) + @(match-all (reverse tgt) (List a) [ [xs ys]])}]}]})] + [$equal? (lambda [$val $tgt] + )]})))