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.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 "#" 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 "#" -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 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.0.5 +Version: 1.0.6 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison