diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -11,7 +11,7 @@ import Paths_egison welcomeMsg :: String -welcomeMsg = "Egison, version 1.1.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" +welcomeMsg = "Egison, version 1.1.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" @@ -25,6 +25,18 @@ flushStr :: String -> IO () flushStr str = putStr str >> hFlush stdout +removeComment :: String -> String +removeComment "" = "" +removeComment (c:cs) = case c of + ';' -> removeCommentHelper cs + _ -> c:(removeComment cs) + +removeCommentHelper :: String -> String +removeCommentHelper "" = "" +removeCommentHelper (c:cs) = case c of + '\n' -> removeComment cs + _ -> removeCommentHelper cs + getExpressionHelper :: Bool -> Integer -> IO String getExpressionHelper b n = do c <- getChar case c of @@ -115,9 +127,9 @@ readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str) executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String -executeTopExpression defsRef (Define name expr) = do - liftIO (modifyIORef defsRef (\ls -> ((name, expr) : ls))) - return (name ++ "\n") +executeTopExpression defsRef (Define name numExprs expr) = do + liftIO (modifyIORef defsRef (\ls -> (((name,numExprs),expr) : ls))) + return (name ++ unwordsNums numExprs ++ "\n") executeTopExpression defs (Test expr) = do topFrame <- makeTopFrame defs val <- eval [topFrame] expr @@ -128,22 +140,24 @@ mStr <- liftIO (readEgisonFile filename) case mStr of Nothing -> throwError (Default "load error") - Just str -> do topExprs <- readTopExpressionList str - let loop topExprs2 = case topExprs2 of - [] -> return (filename ++ " loaded\n") - topExpr:rest -> do executeTopExpression defs topExpr - loop rest - in loop topExprs + 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 executeTopExpression defs (LoadFile filename) = do mStr <- liftIO (readEgisonFile filename) case mStr of Nothing -> throwError (Default "load-file error") - Just str -> do topExprs <- readTopExpressionList str - let loop topExprs2 = case topExprs2 of - [] -> return (filename ++ " loaded\n") - topExpr:rest -> do executeTopExpression defs topExpr - loop rest - in loop topExprs + 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 executeTopExpression defs Execute = do topFrame <- makeTopFrame defs mainFn <- eval [topFrame] (VariableExp "main" []) @@ -185,7 +199,7 @@ -- Data Types -- -data TopExpression = Define String Expression +data TopExpression = Define String [Expression] Expression | Test Expression | Load String | LoadFile String @@ -228,7 +242,7 @@ data FunPat = FunPatVar String | FunPatTuple [FunPat] -type RecursiveBind = [(String, Expression)] +type RecursiveBind = [((String, [Expression]), Expression)] data MatchClause = MatchClause Expression Expression @@ -254,7 +268,7 @@ | InductiveData String [ObjectRef] | Tuple [ObjectRef] | Collection [InnerValue] - | Symbol String [ObjectRef] + | Symbol String [Integer] | WildCard | PatVar String [Integer] | PredPat String [ObjectRef] @@ -286,7 +300,7 @@ type Association = ((String, [Integer]), ObjectRef) -type Definitions = IORef [(String, Expression)] +type Definitions = IORef [((String, [Expression]), Expression)] data PClosure = PClosure Frame ObjectRef @@ -413,14 +427,22 @@ (Closure _ expr) -> writeIORef objRef (Closure (newFrame:env) expr) makeRecursiveFrameHelper env newFrame assocs +evalVariableList :: Environment -> [(String, [Expression])] -> IOThrowsError [(String, [Integer])] +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) + makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame -makeRecursiveFrame env bind = - let vars = map (\name -> (name, [])) (map fst bind) in - 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 +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 makeTopFrame :: Definitions -> IOThrowsError Frame makeTopFrame defsRef = do @@ -559,9 +581,10 @@ spaces char '$' name <- word + nums <- parseIndexNums spaces expr <- parseExpression - return (Define name expr) + return (Define name nums expr) <|> do try (string "test") spaces expr <- parseExpression @@ -639,24 +662,28 @@ args <- parseFunPat spaces body <- parseExpression + spaces return (FunctionExp args body) <|> do try (do string "macro" spaces1) args <- parseFunPat spaces body <- parseExpression + spaces return (MacroExp args body) <|> do try (do string "do" spaces1) bind <- parseBind spaces body <- parseExpression + spaces return (DoExp bind body) <|> do try (do string "let" spaces1) bind <- parseRecursiveBind spaces body <- parseExpression + spaces return (LetExp bind body) <|> do try (do string "loop" spaces1) @@ -670,6 +697,7 @@ body1 <- parseExpression spaces body2 <- parseExpression + spaces return (LoopExp var1 var2 range body1 body2) <|> do try (do string "type" spaces1) @@ -680,10 +708,12 @@ typ <- parseExpression spaces name <- word + spaces return (TypeRefExp typ name) <|> do try (do string "destructor" spaces1) deconsInfo <- parseDestructInfoExp + spaces return (DestructorExp deconsInfo) <|> do try (do string "match" spaces1) @@ -707,6 +737,7 @@ fn <- parseExpression spaces args <- parseExpression + spaces return (ApplyExp fn args) <|> do fn <- parseExpression spaces @@ -747,9 +778,10 @@ parseRecursiveBind :: Parser RecursiveBind parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$' var <- word + nums <- parseIndexNums spaces expr <- parseExpression - return (var, expr))) + return ((var,nums),expr))) spaces return bs) @@ -762,12 +794,14 @@ typExpr <- parseExpression spaces dc2s <- braces (sepEndBy parseDestructClause2 spaces) + spaces return (patCons, typExpr, dc2s)) parseDestructClause2 :: Parser (PrimePat, Expression) parseDestructClause2 = brackets (do datPat <- parsePrimePat spaces - expr <- parseExpression + expr <- parseExpression + spaces return (datPat, expr)) parsePrimePat :: Parser PrimePat @@ -824,7 +858,7 @@ unwordsNums (n:ns) = "_" ++ show n ++ unwordsNums ns showTopExpression :: TopExpression -> String -showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")" +showTopExpression (Define name nums expr) = "(define $" ++ name ++ unwordsNums nums ++ " " ++ show expr ++ ")" showTopExpression (Test expr) = "(test " ++ show expr ++ ")" showTopExpression (Load expr) = "(load " ++ show expr ++ ")" showTopExpression (LoadFile expr) = "(load-file " ++ show expr ++ ")" @@ -869,8 +903,8 @@ showRecursiveBind [] = "{}" showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}" -showRecursiveBindHelper :: (String, Expression) -> String -showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]" +showRecursiveBindHelper :: ((String, [Expression]), Expression) -> String +showRecursiveBindHelper ((name,nums),expr) = "[$" ++ name ++ unwordsNums nums ++ " " ++ show expr ++ "]" showFunPat :: FunPat -> String showFunPat (FunPatVar name) = "$" ++ name @@ -1038,6 +1072,20 @@ -- -- Evaluation -- +eval1Variable :: Environment -> String -> [Integer] -> IOThrowsError Value +eval1Variable env name nums = + let maybeObjRef = getValue env (name,nums) in + case maybeObjRef of + Just objRef -> do val <- cEval1 objRef + case val of + Loop _ _ _ _ _ -> eval1Loop env val + Expression expr -> eval1 env expr + _ -> return val + Nothing -> let mBuiltinFn = getBuiltin name in + case mBuiltinFn of + Just builtinFn -> return (BuiltinFunction builtinFn) + Nothing -> throwError (UnboundVariable name nums) + eval1 :: Environment -> Expression -> IOThrowsError Value eval1 _ (CharacterExp c) = return (Character c) eval1 _ (StringExp str) = do @@ -1048,18 +1096,16 @@ eval1 env (VariableExp name numExprs) = do numVals <- evalList env numExprs let nums = integerValListToIntegerList numVals in - let maybeObjRef = getValue env (name,nums) in - case maybeObjRef of - Just objRef -> do val <- cEval1 objRef - case val of - Loop _ _ _ _ _ -> eval1Loop env val - Expression expr -> do liftIO $ putStrLn "here" - eval1 env expr - _ -> return val - Nothing -> let mBuiltinFn = getBuiltin name in - case mBuiltinFn of - Just builtinFn -> return (BuiltinFunction builtinFn) - Nothing -> throwError (UnboundVariable name nums) + eval1Variable env name nums +eval1 env (SymbolExp name numExprs) = do + numVals <- evalList env numExprs + let nums = integerValListToIntegerList numVals in + return (Symbol name nums) +eval1 env (OmitExp expr) = do + val <- eval1 env expr + case val of + Symbol name nums -> eval1Variable env name nums + _ -> throwError (Default "argument of omit is not symbol") eval1 env (InductiveDataExp con exprs) = do objRefs <- liftIO (makeClosureList env exprs) return (InductiveData con objRefs) @@ -1277,7 +1323,9 @@ Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef - patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) + if length3 pats tgts typs + then patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) + else throwError (Default "patternMatch1: the number of pats, tgts, and typs are different of Tuple") Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of @@ -1294,9 +1342,14 @@ do inTypObjRefs <- tupleToObjRefList nTypObjRef inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs - patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) - pats inTgtObjRefs inTypObjRefs) ++ atoms))) - inTgtObjRefss) ++ states) + patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) + pats inTgtObjRefs inTypObjRefs) ++ atoms))) + inTgtObjRefss) ++ states) +-- if length3 pats inTgtsRefs inTypObjRefs +-- then patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) +-- pats inTgtObjRefs inTypObjRefs) ++ atoms))) +-- inTgtObjRefss) ++ states) +-- else throwError (Default "patternMatch1: the number of pats, tgts, and typs are different of InductiveData") _ -> throwError (Default "patternMatch1: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef @@ -1360,7 +1413,9 @@ Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef - patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) + if length3 pats tgts typs + then patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) + else throwError (Default "patternMatch: the number of pats, tgts, and typs are different") Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of @@ -1378,8 +1433,13 @@ inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) - pats inTgtObjRefs inTypObjRefs) ++ atoms))) - inTgtObjRefss) ++ states) + pats inTgtObjRefs inTypObjRefs) ++ atoms))) + inTgtObjRefss) ++ states) +-- if length3 pats inTgtsRefs inTgtsRefs +-- then patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) +-- pats inTgtObjRefs inTypObjRefs) ++ atoms))) +-- inTgtObjRefss) ++ states) +-- else throwError (Default "patternMatch: the number of pats, tgts, and typs are different") _ -> throwError (Default "patternMatch: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef @@ -1423,6 +1483,12 @@ return retVal _ -> throwError (Default "cApply: not a function") + +length3 :: [a] -> [b] -> [c] -> Bool +length3 [] [] [] = True +length3 (_:xs) (_:ys) (_:zs) = length3 xs ys zs +length3 _ _ _ = False + map3 :: ((a,b,c) -> d) -> [a] -> [b] -> [c] -> [d] map3 fn [] [] [] = [] map3 fn (x:xs) (y:ys) (z:zs) = (fn (x,y,z)):(map3 fn xs ys zs) 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.1.0 +Version: 1.1.1 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language 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 @@ -33,6 +33,7 @@ (eval-when-compile (list (cons "\\\$\\\w*" font-lock-variable-name-face) + (cons ";.*$" font-lock-comment-face) ))) "Gaudy expressions to highlight in Egison modes.") @@ -96,7 +97,7 @@ ((equal "match" name) 2) ((equal "match-all" name) 2) ((equal "type" name) 2) - ((equal "deconstructor" name) 2) + ((equal "destructor" name) 2) )) (defun egison-indent-line () diff --git a/etc/lib/base.egi b/etc/lib/base.egi --- a/etc/lib/base.egi +++ b/etc/lib/base.egi @@ -1,3 +1,8 @@ +;; +;; Base.egi +;; + + (define $Something (type {[$var-match (lambda [$tgt] {tgt})]})) (define $Bool diff --git a/etc/lib/collection.egi b/etc/lib/collection.egi --- a/etc/lib/collection.egi +++ b/etc/lib/collection.egi @@ -1,3 +1,7 @@ +;; +;; Collection.egi +;; + (define $List (lambda [$a] (type diff --git a/etc/sample/graph-test.egi b/etc/sample/graph-test.egi --- a/etc/sample/graph-test.egi +++ b/etc/sample/graph-test.egi @@ -1,14 +1,8 @@ - (define $g { +(define $g { - - }) - -(define $g2 { - - - - }) + + }) (test (match-all g Graph [ _> @@ -26,7 +20,7 @@ _>>>>> [n1 n2 n3 n4 n5]])) -(test (match-all g2 Graph +(test (match-all g Graph [ _> _> _> @@ -35,6 +29,6 @@ >>>>> [n1 n2 n3 n4 n5]])) -(test (hamilton-cycle g2)) +(test (hamilton-cycle g)) -(test (hamilton-path g2)) +(test (hamilton-path g)) 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 @@ -13,3 +13,25 @@ :))) (execute) + + +(define $main + (lambda [$:] + (do {[$: (print : "Return world? (y/n) : ")] + [[$: $c] (read-char :)]} + (match c Character + {['y' :] + ['n' 0]})))) + +(execute) + + +(define $main + (lambda [$:] + (do {[$: (print : "Return world? (1/0) : ")] + [[$: $n] (read :)]} + (match n Integer + {[,1 :] + [,0 0]})))) + +(execute)