egison 1.1.0 → 1.1.1
raw patch · 7 files changed
+158/−66 lines, 7 files
Files
- Egison.hs +118/−52
- egison.cabal +1/−1
- etc/elisp/egison-mode.el +2/−1
- etc/lib/base.egi +5/−0
- etc/lib/collection.egi +4/−0
- etc/sample/graph-test.egi +6/−12
- etc/sample/io-test.egi +22/−0
Egison.hs view
@@ -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)
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.1.0+Version: 1.1.1 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison
etc/elisp/egison-mode.el view
@@ -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 ()
etc/lib/base.egi view
@@ -1,3 +1,8 @@+;;+;; Base.egi+;;++ (define $Something (type {[$var-match (lambda [$tgt] {tgt})]})) (define $Bool
etc/lib/collection.egi view
@@ -1,3 +1,7 @@+;;+;; Collection.egi+;;+ (define $List (lambda [$a] (type
etc/sample/graph-test.egi view
@@ -1,14 +1,8 @@- (define $g {<node 1 {2 3 4 5} {2 3 4 5}>+(define $g {<node 1 {2 3 4 5} {2 3 4 5}> <node 2 {1 3} {1 3}> <node 3 {1 2 4} {1 2 4}>- <node 4 {1 3} {1 3}>- <node 5 {1} {1}>})--(define $g2 {<node 1 {2 3 4 5} {2 3 4 5}>- <node 2 {1 3} {1 3}>- <node 3 {1 2 4} {1 2 4}>- <node 4 {1 3 5} {1 3 5}>- <node 5 {1 5} {1 5}>})+ <node 4 {1 3 5} {1 3 5}>+ <node 5 {1 5} {1 5}>}) (test (match-all g Graph [<cons <node $n1 <cons $n2 _> _>@@ -26,7 +20,7 @@ _>>>>> [n1 n2 n3 n4 n5]])) -(test (match-all g2 Graph+(test (match-all g Graph [<cons <node $n1 <cons $n2 _> _> <cons <node ,n2 <cons $n3 _> _> <cons <node ,n3 <cons $n4 _> _>@@ -35,6 +29,6 @@ <nil>>>>>> [n1 n2 n3 n4 n5]])) -(test (hamilton-cycle g2))+(test (hamilton-cycle g)) -(test (hamilton-path g2))+(test (hamilton-path g))
etc/sample/io-test.egi view
@@ -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)