egison 1.1.1 → 1.2.0
raw patch · 2 files changed
+87/−38 lines, 2 files
Files
- Egison.hs +86/−37
- egison.cabal +1/−1
Egison.hs view
@@ -11,7 +11,7 @@ import Paths_egison welcomeMsg :: String-welcomeMsg = "Egison, version 1.1.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+welcomeMsg = "Egison, version 1.2.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"@@ -217,12 +217,13 @@ | CollectionExp [InnerExp] | WildCardExp | PatVarExp String [Expression]+ | PatVarOmitExp Expression | CutPatExp Expression | AndPatExp [Expression] | OrPatExp [Expression] | PredPatExp String [Expression] | FunctionExp FunPat Expression- | MacroExp FunPat Expression+ | MacroExp [String] Expression | DoExp Bind Expression | LetExp RecursiveBind Expression | LoopExp Expression Expression Expression Expression Expression@@ -277,7 +278,7 @@ | OrPat [ObjectRef] | Function Environment FunPat Expression | Expression Expression- | Macro FunPat Expression+ | Macro [String] Expression | Loop String String ObjectRef Expression Expression | Type Frame | DestructorFunction DestructInfo@@ -620,6 +621,10 @@ ws <- word nums <- parseIndexNums return (PatVarExp ws nums))+ <|> do try (do char '$'+ char '~'+ expr <- parseExpression+ return (PatVarOmitExp expr)) <|> do try (do char '#' ws <- word nums <- parseIndexNums@@ -666,7 +671,11 @@ return (FunctionExp args body) <|> do try (do string "macro" spaces1)- args <- parseFunPat+ args <-brackets (do args2 <- sepEndBy (do char '$'+ name <- word+ return name)+ spaces+ return args2) spaces body <- parseExpression spaces@@ -871,12 +880,15 @@ showExpression (StringExp s) = "\"" ++ show s ++ "\"" showExpression (IntegerExp n) = show n showExpression (VariableExp name nums) = name ++ unwordsNums nums+showExpression (SymbolExp name nums) = "#" ++ name ++ unwordsNums nums+showExpression (OmitExp expr) = "~" ++ showExpression expr showExpression (InductiveDataExp s []) = "<" ++ s ++ ">" showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">" showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]" showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}" showExpression WildCardExp = "_" showExpression (PatVarExp name nums) = "$" ++ name ++ unwordsNums nums+showExpression (PatVarOmitExp expr) = "$~" ++ showExpression expr showExpression (CutPatExp p) = "!" ++ show p showExpression (AndPatExp ps) = "(& " ++ unwordsList ps ++ ")" showExpression (OrPatExp ps) = "(| " ++ unwordsList ps ++ ")"@@ -1122,6 +1134,11 @@ eval1 env (PatVarExp name numExprs) = do numVals <- evalList env numExprs return (PatVar name (integerValListToIntegerList numVals))+eval1 env (PatVarOmitExp expr) = do+ val <- eval1 env expr+ case val of+ Symbol name nums -> return (PatVar name nums)+ _ -> throwError (Default "argument of omit is not symbol") eval1 env (PredPatExp name exprs) = do objRefs <- liftIO (makeClosureList env exprs) return (PredPat name objRefs)@@ -1145,7 +1162,7 @@ frame <- makeRecursiveFrame env bind objRef <- liftIO (newIORef (Closure (frame:env) body)) cEval1 objRef-eval1 env expr@(LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do+eval1 env (LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do range <- liftIO (makeClosure env rangeExpr) eval1Loop env (Loop var1 var2 range expr1 expr2) eval1 env (TypeExp bind) = do@@ -1182,14 +1199,66 @@ frame <- makeFrame fpat arg objRef <- liftIO (makeClosure (frame:funEnv) body) cEval1 objRef- Macro fpat body -> do argsObjRefs <- liftIO (makeExpressionList argsExps)- arg <- liftIO (newIORef (Value (Tuple argsObjRefs)))- frame <- makeFrame fpat arg- objRef <- liftIO (makeClosure (frame:env) body)- cEval1 objRef+ Macro vars body -> let body2 = expandMacro (zip vars argsExps) body in+ eval1 env body2 _ -> throwError (WithExpression "applying non-functional object" expr) +type MFrame = [(String, Expression)] +searchMFrame :: MFrame -> String -> Maybe Expression+searchMFrame [] _ = Nothing+searchMFrame ((name,expr):rest) varName = if name == varName+ then Just expr+ else searchMFrame rest varName++expandMacro :: MFrame -> Expression -> Expression+expandMacro mf (VariableExp name []) =+ case searchMFrame mf name of+ Nothing -> VariableExp name []+ Just expr -> expr+expandMacro mf (VariableExp name numExprs) = VariableExp name (mapExpandMacro mf numExprs)+expandMacro mf (SymbolExp name numExprs) = SymbolExp name (mapExpandMacro mf numExprs)+expandMacro mf (OmitExp expr) = OmitExp (expandMacro mf expr)+expandMacro mf (InductiveDataExp cons exprs) = InductiveDataExp cons (mapExpandMacro mf exprs)+expandMacro mf (TupleExp innerExprs) = TupleExp (mapExpandMacroInnerExp mf innerExprs)+expandMacro mf (CollectionExp innerExprs) = CollectionExp (mapExpandMacroInnerExp mf innerExprs)+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 (AndPatExp exprs) = AndPatExp (mapExpandMacro mf exprs)+expandMacro mf (OrPatExp exprs) = OrPatExp (mapExpandMacro mf exprs)+expandMacro mf (PredPatExp name exprs) = PredPatExp name (mapExpandMacro mf exprs)+expandMacro mf (FunctionExp fpat body) = FunctionExp fpat (expandMacro mf body)+expandMacro mf (MacroExp vars body) = MacroExp vars (expandMacro mf body)+expandMacro mf (DoExp bind body) = undefined+expandMacro mf (LetExp bind body) = undefined+expandMacro mf (LoopExp lVar iVar rangeExp inExp outExp) =+ LoopExp (expandMacro mf lVar) (expandMacro mf iVar) (expandMacro mf rangeExp) (expandMacro mf inExp) (expandMacro mf outExp)+expandMacro mf (TypeExp bind) = undefined+expandMacro mf (TypeRefExp tExp name) = TypeRefExp (expandMacro mf tExp) name+expandMacro mf (DestructorExp deconsInfo) = undefined+expandMacro mf (MatchExp tgtExp typExp clsExps) = MatchExp (expandMacro mf tgtExp) (expandMacro mf typExp) (mapExpandMacroMatchClause mf clsExps)+expandMacro mf (MatchAllExp tgtExp typExp clsExp) = MatchAllExp (expandMacro mf tgtExp) (expandMacro mf typExp) (expandMacroMatchClause mf clsExp)+expandMacro mf (ApplyExp fnExp argsExp) = ApplyExp (expandMacro mf fnExp) (expandMacro mf argsExp)+expandMacro mf (ApplyListExp fnExp argsExps) = ApplyListExp (expandMacro mf fnExp) (mapExpandMacro mf argsExps)+expandMacro _ expr = expr++mapExpandMacro :: MFrame -> [Expression] -> [Expression]+mapExpandMacro mf exprs = map (\expr -> expandMacro mf expr) exprs++expandMacroMatchClause :: MFrame -> MatchClause -> MatchClause+expandMacroMatchClause mf (MatchClause patExp body) = MatchClause (expandMacro mf patExp) (expandMacro mf body)++mapExpandMacroMatchClause :: MFrame -> [MatchClause] -> [MatchClause]+mapExpandMacroMatchClause mf mClss = map (\mCls -> expandMacroMatchClause mf mCls) mClss++mapExpandMacroInnerExp :: MFrame -> [InnerExp] -> [InnerExp]+mapExpandMacroInnerExp mf innerExps = map (\innerExp -> expandMacroInnerExp mf innerExp) innerExps++expandMacroInnerExp :: MFrame -> InnerExp -> InnerExp+expandMacroInnerExp mf (ElementExp expr) = ElementExp (expandMacro mf expr)+expandMacroInnerExp mf (SubCollectionExp expr) = SubCollectionExp (expandMacro mf expr)+ eval :: Environment -> Expression -> IOThrowsError Value eval env expr = do objRef <- liftIO (makeClosure env expr)@@ -1323,9 +1392,7 @@ Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef- 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")+ patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of@@ -1342,14 +1409,9 @@ do inTypObjRefs <- tupleToObjRefList nTypObjRef 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)--- 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")+ patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))+ pats inTgtObjRefs inTypObjRefs) ++ atoms)))+ inTgtObjRefss) ++ states) _ -> throwError (Default "patternMatch1: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef@@ -1413,9 +1475,7 @@ Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef- 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")+ patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of@@ -1433,13 +1493,8 @@ 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)--- 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")+ pats inTgtObjRefs inTypObjRefs) ++ atoms)))+ inTgtObjRefss) ++ states) _ -> throwError (Default "patternMatch: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef@@ -1483,12 +1538,6 @@ 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.1+Version: 1.2.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison