egison 1.0.5 → 1.0.6
raw patch · 2 files changed
+92/−77 lines, 2 files
Files
- Egison.hs +91/−76
- egison.cabal +1/−1
Egison.hs view
@@ -11,7 +11,7 @@ import Paths_egison welcomeMsg :: String-welcomeMsg = "Egison, version 1.0.5 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+welcomeMsg = "Egison, version 1.0.6 : 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"@@ -115,13 +115,13 @@ readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str) executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String-executeTopExpression defs (Define name expr) = do- liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))+executeTopExpression defsRef (Define name expr) = do+ liftIO (modifyIORef defsRef (\ls -> ((name, expr) : ls))) return (name ++ "\n") executeTopExpression defs (Test expr) = do topFrame <- makeTopFrame defs val <- eval [topFrame] expr- ret <- liftIO (showValue val)+ ret <- showValue val return (ret ++ "\n") executeTopExpression defs (Load libname) = do filename <- liftIO (getDataFileName libname)@@ -164,12 +164,15 @@ runRepl :: Definitions -> IO ()-runRepl defs = do input <- (readPrompt "> ")- case input of- Eof -> flushStr byebyeMsg- Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defs) >>= flushStr >> runRepl defs--- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs+runRepl defsRef = do input <- (readPrompt "> ")+ 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 +loadBasicLibrary :: Definitions -> Definitions+loadBasicLibrary defsRef = undefined+ main :: IO () main = do args <- getArgs case length args of@@ -193,8 +196,10 @@ | IntegerExp Integer | DoubleExp Double | VariableExp String [Expression]+ | SymbolExp String [Expression]+ | OmitExp Expression | InductiveDataExp String [Expression]- | TupleExp [Expression]+ | TupleExp [InnerExp] | CollectionExp [InnerExp] | WildCardExp | PatVarExp String [Expression]@@ -203,6 +208,7 @@ | OrPatExp [Expression] | PredPatExp String [Expression] | FunctionExp FunPat Expression+ | MacroExp FunPat Expression | DoExp Bind Expression | LetExp RecursiveBind Expression | LoopExp Expression Expression Expression Expression Expression@@ -247,6 +253,7 @@ | InductiveData String [ObjectRef] | Tuple [ObjectRef] | Collection [InnerValue]+ | Symbol String [ObjectRef] | WildCard | PatVar String [Integer] | PredPat String [ObjectRef]@@ -254,6 +261,7 @@ | AndPat [ObjectRef] | OrPat [ObjectRef] | Function Environment FunPat Expression+ | Expression Expression | Macro FunPat Expression | Loop String String Integer Integer Expression Expression | Type Frame@@ -291,17 +299,17 @@ isEqualValue (Double d1) (Double d2) = return (d1 == d2) isEqualValue (InductiveData c1 objRefs1) (InductiveData c2 objRefs2) = if (c1 == c2)- then do vals1 <- liftIO (objRefListToValueList objRefs1)- vals2 <- liftIO (objRefListToValueList objRefs2)+ then do vals1 <- cEvalList objRefs1+ vals2 <- cEvalList objRefs2 isEqualValueList vals1 vals2 else return False isEqualValue (Tuple objRefs1) (Tuple objRefs2) = do- vals1 <- liftIO (objRefListToValueList objRefs1)- vals2 <- liftIO (objRefListToValueList objRefs2)+ vals1 <- cEvalList objRefs1+ vals2 <- cEvalList objRefs2 isEqualValueList vals1 vals2-isEqualValue val1@(Collection _) val2@(Collection _) = do- vals1 <- liftIO (collectionToValueList val1)- vals2 <- liftIO (collectionToValueList val2)+isEqualValue (Collection innerVals1) (Collection innerVals2) = do+ vals1 <- innerValueListToValueList innerVals1+ vals2 <- innerValueListToValueList innerVals2 isEqualValueList vals1 vals2 isEqualValue _ _ = return False @@ -320,6 +328,7 @@ case obj of Value (Integer n) -> return n _ -> throwError (Default "objectRefToInteger: not Integer value")+ -- -- Environment --@@ -382,7 +391,7 @@ makeFrame (FunPatTuple fpats) objRef = do val <- cEval1 objRef case val of- Tuple objRefs -> makeFrameHelper fpats objRefs+ Tuple objRefs -> do makeFrameHelper fpats objRefs _ -> makeFrameHelper fpats [objRef] makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO ()@@ -417,29 +426,38 @@ objRefs <- valListToObjRefList vals return (objRef:objRefs) -objRefListToValueList :: [ObjectRef] -> IO [Value]-objRefListToValueList [] = return []-objRefListToValueList (objRef:objRefs) = do- obj <- readIORef objRef- case obj of- Value val -> do vals <- objRefListToValueList objRefs- return (val:vals)+objRefListToInnerVals :: [ObjectRef] -> IO [InnerValue]+objRefListToInnerVals [] = return []+objRefListToInnerVals (objRef:objRefs) = do+ innerVals <- objRefListToInnerVals objRefs+ return ((Element objRef):innerVals) +innerValueListToObjRefList :: [InnerValue] -> IOThrowsError [ObjectRef]+innerValueListToObjRefList [] = return []+innerValueListToObjRefList (Element eRef:rest) = do+ restRefs <- innerValueListToObjRefList rest+ return (eRef:restRefs)+innerValueListToObjRefList (SubCollection subRef:rest) = do+ subVal <- cEval1 subRef+ case subVal of+ Collection inners -> innerValueListToObjRefList (inners ++ rest)++innerValueListToValueList :: [InnerValue] -> IOThrowsError [Value]+innerValueListToValueList innerVals = do+ objRefs <- innerValueListToObjRefList innerVals+ cEvalList objRefs+ tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef] tupleToObjRefList objRef = do val <- cEval1 objRef case val of- (Tuple objRefs) -> return objRefs+ Tuple objRefs -> return objRefs val -> return [objRef] -tupleToValueList :: Value -> IO [Value]+tupleToValueList :: Value -> IOThrowsError [Value] tupleToValueList (Tuple []) = return []-tupleToValueList (Tuple (objRef:objRefs)) = do- val <- readIORef objRef- case val of- Value val -> do vals <- tupleToValueList (Tuple objRefs)- return (val:vals)-tupleToValueList val = return [val] +tupleToValueList (Tuple objRefs) = cEvalList objRefs+tupleToValueList val = return [val] tupleObjRefListToListOfList :: [ObjectRef] -> IOThrowsError [[ObjectRef]] tupleObjRefListToListOfList [] = return []@@ -466,28 +484,9 @@ collectionToObjRefList val collectionToObjRefList :: Value -> IOThrowsError [ObjectRef]-collectionToObjRefList (Collection []) = return []-collectionToObjRefList (Collection (Element eRef:rest)) = do restRefs <- collectionToObjRefList (Collection rest)- return (eRef : restRefs)-collectionToObjRefList (Collection (SubCollection subRef:rest)) = do valRefs1 <- collectionObjToObjRefList subRef- valRefs2 <- collectionToObjRefList (Collection rest)- return (valRefs1 ++ valRefs2)+collectionToObjRefList (Collection innerVals) = innerValueListToObjRefList innerVals collectionToObjRefList _ = throwError (Default "collectionObjToObjRefList : not a collection") -collectionToValueList :: Value -> IO [Value]-collectionToValueList (Collection []) = return []-collectionToValueList (Collection (Element eRef : rest)) = do- eObj <- readIORef eRef- case eObj of- Value e -> do rest <- collectionToValueList (Collection rest)- return (e : rest)-collectionToValueList (Collection (SubCollection subRef : rest)) = do- subObj <- readIORef subRef- case subObj of- Value subVal -> do vals1 <- collectionToValueList subVal- vals2 <- collectionToValueList (Collection rest)- return (vals1 ++ vals2)- charCollectionToString :: Value -> IOThrowsError [Char] charCollectionToString (Collection []) = return [] charCollectionToString (Collection (Element eRef : rest)) = do@@ -587,6 +586,13 @@ ws <- word nums <- parseIndexNums return (PatVarExp ws nums))+ <|> do try (do char '#'+ ws <- word+ nums <- parseIndexNums+ return (SymbolExp ws nums))+ <|> do char '~'+ expr <- parseExpression+ return (OmitExp expr) <|> do char '_' return WildCardExp <|> do char '!'@@ -599,7 +605,7 @@ spaces vs <- sepEndBy parseExpression spaces return (InductiveDataExp c vs))- <|> brackets (do vs <- sepEndBy parseExpression spaces+ <|> brackets (do vs <- sepEndBy parseInnerExp spaces return (TupleExp vs)) <|> braces (do vs <- sepEndBy parseInnerExp spaces return (CollectionExp vs))@@ -623,6 +629,12 @@ spaces body <- parseExpression return (FunctionExp args body)+ <|> do try (do string "macro"+ spaces1)+ args <- parseFunPat+ spaces+ body <- parseExpression+ return (MacroExp args body) <|> do try (do string "do" spaces1) bind <- parseBind@@ -687,7 +699,7 @@ return (ApplyExp fn args) <|> do fn <- parseExpression spaces- args <- sepEndBy parseExpression spaces+ args <- sepEndBy parseInnerExp spaces return (ApplyExp fn (TupleExp args))) parseIndexNums :: Parser [Expression]@@ -903,11 +915,12 @@ vals <- expressionToValueMap exprs objRefs <- liftIO (valListToObjRefList vals) return (InductiveData con objRefs)-expressionToValue (TupleExp exprs) = do- vals <- expressionToValueMap exprs+expressionToValue (TupleExp innerExps) = do+ innerVals <- innerExpToInnerValueMap innerExps+ vals <- innerValueListToValueList innerVals case vals of [val] -> return val- _ -> do objRefs <- liftIO (valListToObjRefList vals)+ _ -> do objRefs <- liftIO $ makeObjRefList vals return (Tuple objRefs) expressionToValue (CollectionExp innerExps) = do innerVals <- innerExpToInnerValueMap innerExps@@ -934,7 +947,7 @@ innerVals <- innerExpToInnerValueMap rest return (SubCollection objRef:innerVals) -showValue :: Value -> IO String+showValue :: Value -> IOThrowsError String showValue (World _) = return "#<world>" showValue (Character c) = return (show c) showValue (Integer n) = return (show n)@@ -942,19 +955,19 @@ showValue (InductiveData cons []) = do return ("<" ++ cons ++ ">") showValue (InductiveData cons objRefs) = do- vals <- objRefListToValueList objRefs+ vals <- cEvalList objRefs str <- unwordsVals vals return ("<" ++ cons ++ " " ++ str ++ ">") showValue (Tuple []) = do return ("[]") showValue (Tuple objRefs) = do- vals <- objRefListToValueList objRefs+ vals <- cEvalList objRefs str <- unwordsVals vals return ("[" ++ str ++ "]") showValue (Collection []) = do return ("{}") showValue (Collection innerVals) = do- vals <- collectionToValueList (Collection innerVals)+ vals <- innerValueListToValueList innerVals str <- unwordsVals vals return ("{" ++ str ++ "}") showValue WildCard = return "_"@@ -973,14 +986,14 @@ showValue (BuiltinFunction _) = do return "#<builtin-function>" -unwordsVals :: [Value] -> IO String+unwordsVals :: [Value] -> IOThrowsError String unwordsVals [] = return "" unwordsVals (val:vals) = do s1 <- showValue val s2 <- unwordsValsHelper vals return (s1 ++ s2) -unwordsValsHelper :: [Value] -> IO String+unwordsValsHelper :: [Value] -> IOThrowsError String unwordsValsHelper [] = return "" unwordsValsHelper (val:vals) = do s1 <- showValue val@@ -1037,10 +1050,11 @@ eval1 env (InductiveDataExp con exprs) = do objRefs <- liftIO (makeClosureList env exprs) return (InductiveData con objRefs)-eval1 env (TupleExp exprs) = do- objRefs <- liftIO (makeClosureList env exprs)+eval1 env (TupleExp innerExps) = do+ innerVals <- liftIO (makeClosureInnerVals env innerExps)+ objRefs <- innerValueListToObjRefList innerVals case objRefs of- [objRef] -> do cEval1 objRef+ [objRef] -> cEval1 objRef _ -> return (Tuple objRefs) eval1 env (CollectionExp innerExps) = do innerVals <- liftIO (makeClosureInnerVals env innerExps)@@ -1107,7 +1121,7 @@ argsObjRef <- liftIO (makeClosure env argsExp) case fnVal of BuiltinFunction builtinFn -> do argsVal <- cEval argsObjRef- argsVals <- liftIO (tupleToValueList argsVal)+ argsVals <- tupleToValueList argsVal builtinFn argsVals Function funEnv fpat body -> do frame <- makeFrame fpat argsObjRef objRef <- liftIO (makeClosure (frame:funEnv) body)@@ -1147,11 +1161,12 @@ val1 <- cEval1 objRef evalValue val1 -cEvalList :: [ObjectRef] -> IOThrowsError ()-cEvalList [] = return ()+cEvalList :: [ObjectRef] -> IOThrowsError [Value]+cEvalList [] = return [] cEvalList (objRef:objRefs) = do- cEval objRef- cEvalList objRefs+ val <- cEval objRef+ vals <- cEvalList objRefs+ return (val:vals) evalValue :: Value -> IOThrowsError Value evalValue (InductiveData cons objRefs) = do@@ -1382,7 +1397,7 @@ cApply fnObjRef argObjRefs = do fnVal <- cEval1 fnObjRef case fnVal of- BuiltinFunction builtinFn -> do argVals <- liftIO (objRefListToValueList argObjRefs)+ BuiltinFunction builtinFn -> do argVals <- cEvalList argObjRefs retVal <- builtinFn argVals return retVal Function funEnv fpat body -> do objRef <- liftIO (newIORef (Value (Tuple argObjRefs)))@@ -1447,7 +1462,7 @@ InductiveData cons objRefs -> if pCons == cons then primitivePatternMatchList pPats objRefs else return Nothing- _ -> do valStr <- liftIO (showValue val)+ _ -> do valStr <- showValue val throwError (Default ("primitive : not inductive value to primitive inductive pattern : " ++ valStr)) primitivePatternMatch EmptyPat objRef = do val <- cEval1 objRef@@ -1601,7 +1616,7 @@ builtinWrite :: [Value] -> IOThrowsError Value builtinWrite [(World actions), val] = do- valStr <- liftIO (showValue val)+ valStr <-showValue val liftIO (flushStr valStr) return (World ((Write val):actions)) builtinWrite _ = throwError (Default "invalid args to write")@@ -1788,7 +1803,7 @@ debug :: String -> ObjectRef -> IOThrowsError () debug tag objRef = do val <- cEval objRef- valStr <- liftIO $ showValue val+ valStr <- showValue val liftIO $ putStr $ tag ++ ": " liftIO $ putStrLn valStr
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.0.5+Version: 1.0.6 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison