diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -10,1667 +10,1681 @@ import IO hiding (try) welcomeMsg :: String -welcomeMsg = "Egison, version 0.4.0.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" - -main :: IO () -main = do args <- getArgs - case length args of - 0 -> do flushStr welcomeMsg - defsRef <- newIORef [] - runRepl defsRef - _ -> putStrLn "Program takes only 0 argument!" - -type Definitions = IORef [(String, Expression)] - -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 - -readPrompt :: String -> IO Input -readPrompt prompt = flushStr prompt >> getExpression - -flushStr :: String -> IO () -flushStr str = putStr str >> hFlush stdout - -data Input = Input String - | Eof - -getExpression :: IO Input -getExpression = catch (do str <- getExpressionHelper False 0 - return (Input str)) - (\_ -> return Eof) - -getExpressionHelper :: Bool -> Integer -> IO String -getExpressionHelper b n = do c <- getChar - case c of - '(' -> do l <- getExpressionHelper True (n + 1) - return (c : l) - '<' -> do l <- getExpressionHelper True (n + 1) - return (c : l) - '[' -> do l <- getExpressionHelper True (n + 1) - return (c : l) - '{' -> do l <- getExpressionHelper True (n + 1) - return (c : l) - ')' -> do l <- getExpressionHelper True (n - 1) - return (c : l) - '>' -> do l <- getExpressionHelper True (n - 1) - return (c : l) - ']' -> do l <- getExpressionHelper True (n - 1) - return (c : l) - '}' -> do l <- getExpressionHelper True (n - 1) - return (c : l) - '\n' -> if n > 0 - then do l <- getExpressionHelper b n - return (c : l) - else if b - then return "\n" - else getExpressionHelper b n - ' ' -> do l <- getExpressionHelper b n - return (c : l) - '\t' -> do l <- getExpressionHelper b n - return (c : l) - _ -> do l <- getExpressionHelper True n - return (c : l) - - -type IOThrowsError = ErrorT EgiError IO - -data EgiError = Parser ParseError - | UnboundVariable String - | WithTopExpression String Expression - | WithExpression String Expression - | Default String - -showError :: EgiError -> String -showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n" -showError (UnboundVariable name) = "Error : unbound variable : " ++ name ++ "\n" -showError (WithTopExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n" -showError (WithExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n" -showError (Default str) = "Error : " ++ str ++ "\n" - -instance Show EgiError where show = showError - -instance Error EgiError where - noMsg = Default "An error has occured" - strMsg = Default - -type ThrowsError = Either EgiError - -liftThrows :: ThrowsError a -> IOThrowsError a -liftThrows (Left err) = throwError err -liftThrows (Right val) = return val - -runIOThrows :: IOThrowsError String -> IO String -runIOThrows action = runErrorT (trapError action) >>= return . extractValue - -trapError :: (MonadError e m, Show e) => m String -> m String -trapError action = catchError action (return . show) - -extractValue :: ThrowsError a -> a -extractValue (Right val) = val - -readTopExpression :: String -> IOThrowsError TopExpression -readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr) - -readTopExpressionList :: String -> IOThrowsError [TopExpression] -readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str) - -readOrThrow :: Parser a -> String -> ThrowsError a -readOrThrow parser input = case parse parser "egison" input of - Left err -> throwError (Parser err) - Right val -> return val - -executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String -executeTopExpression defs (Define name expr) = do - liftIO (modifyIORef defs (\ls -> ((name, expr) : ls))) - return (name ++ "\n") -executeTopExpression defs (Test expr) = do - topFrame <- makeTopFrame defs - val <- eval (Environment [topFrame]) expr - ret <- liftIO (showValue val) - return (ret ++ "\n") -executeTopExpression defs (Load filename) = do - str <- liftIO (readFile filename) - topExprs <- readTopExpressionList str - 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 (Environment [topFrame]) (SymbolExp "main") - args <- liftIO (newIORef (Value (World initMemory []))) - case mainFn of - Function funEnv fpat body - -> do frame <- makeFrame fpat args - iValRef <- liftIO (makeClosure (addFrame frame funEnv) body) - forceRecursively iValRef - return "" - _ -> throwError (Default "main is not function" ) - - --- --- Data Types --- - -data TopExpression = Define String Expression - | Test Expression - | Load String - | Execute - -data Expression = CharacterExp Char - | StringExp String - | IntegerExp Integer - | DoubleExp Double - | SymbolExp String - | InductiveDataExp String [Expression] - | TupleExp [Expression] - | CollectionExp [InnerExp] - | PatternExp PatternExp - | FunctionExp FunPat Expression - | WithExp String Expression - | DoExp Bind Expression - | LetExp RecursiveBind Expression - | TypeExp RecursiveBind - | TypeRefExp Expression String - | DeconstructorExp DeconsInfoExp - | MatchExp Expression Expression [MatchClause] - | MatchAllExp Expression Expression MatchClause - | ApplyExp Expression Expression - -data InnerExp = ElementExp Expression - | SubCollectionExp Expression - -data PatternExp = WildCardExp - | PatVarExp String - | CutPatExp Expression - | AsPatExp String Expression - | OfPatExp Expression - | ValPatExp Expression - -data FunPat = FunPatVar String - | FunPatTuple [FunPat] - -type Bind = [(FunPat, Expression)] - -type RecursiveBind = [(String, Expression)] - -type DeconsInfoExp = [(String, Expression, [(PrimePat, Expression)])] - -data MatchClause = MatchClause Expression Expression - -data PrimePat = PrimeWildCard - | PrimePatCharacter Char - | PrimePatInteger Integer - | PrimePatDouble Double - | PrimePatVar String - | InductivePrimePat String [PrimePat] - | TuplePrimePat [PrimePat] - | EmptyPat - | ConsPat PrimePat PrimePat - | SnocPat PrimePat PrimePat - -type Association = (String, IORef IntermidiateValue) - -data Frame = Frame [Association] - -data Environment = Environment [Frame] - -data IntermidiateValue = Closure Environment Expression - | Value Value - - ---type Memory = Hash.Map Value [Value] -type Memory = [(Value, Value)] - ---initMemory :: Memory ---initMemory = Hash.empty -initMemory :: Memory -initMemory = [] - ---addToMemory :: Value -> Value -> Memory -> Memory ---addToMemory key val memory = --- let mStack = Hash.lookup key memory in --- let newStack = case mStack of --- Nothing -> [val] --- Just s -> (val : s) in --- Hash.insert key newStack memory -addToMemory :: Value -> Value -> Memory -> Memory -addToMemory key val memory = (key, val) : memory - -lookupMemory :: Value -> Memory -> IOThrowsError (Maybe Value) -lookupMemory key [] = return Nothing -lookupMemory key ((k,v):memory) = do - b <- isEqualValue key k - if b - then return (Just v) - else lookupMemory key memory - -data Value = World Memory [Action] - | Character Char - | Integer Integer - | Double Double - | InductiveData String [IORef IntermidiateValue] - | Tuple [IORef IntermidiateValue] - | Collection [InnerValue] - | Pattern Pattern - | Function Environment FunPat Expression - | Type Frame - | Deconstructor (IORef IntermidiateValue) DeconsInfo - | DeconstructorFunction DeconsInfo - | BuiltinFunction ([Value] -> IOThrowsError Value) - -isEqualValue :: Value -> Value -> IOThrowsError Bool -isEqualValue (Character c1) (Character c2) = return (c1 == c2) -isEqualValue (Integer n1) (Integer n2) = return (n1 == n2) -isEqualValue (Double d1) (Double d2) = return (d1 == d2) -isEqualValue (InductiveData c1 iValRefs1) (InductiveData c2 iValRefs2) = - if (c1 == c2) - then do vals1 <- liftIO (iValRefListToValueList iValRefs1) - vals2 <- liftIO (iValRefListToValueList iValRefs2) - isEqualValueList vals1 vals2 - else return False -isEqualValue (Tuple iValRefs1) (Tuple iValRefs2) = do - vals1 <- liftIO (iValRefListToValueList iValRefs1) - vals2 <- liftIO (iValRefListToValueList iValRefs2) - isEqualValueList vals1 vals2 -isEqualValue val1@(Collection _) val2@(Collection _) = do - vals1 <- liftIO (collectionToValueList val1) - vals2 <- liftIO (collectionToValueList val2) - isEqualValueList vals1 vals2 -isEqualValue _ _ = return False - -isEqualValueList :: [Value] -> [Value] -> IOThrowsError Bool -isEqualValueList [] [] = return True -isEqualValueList (v1:vals1) (v2:vals2) = do - b <- isEqualValue v1 v2 - if b - then isEqualValueList vals1 vals2 - else return False -isEqualValueList _ _ = return False - -data Action = Read Value - | Write Value - | Print String - | Memorize Value Value - | Remember Value Value - -data InnerValue = Element (IORef IntermidiateValue) - | SubCollection (IORef IntermidiateValue) - -data Pattern = WildCard - | PatVar String - | CutPat (IORef IntermidiateValue) - | AsPat String (IORef IntermidiateValue) - | OfPat [IORef IntermidiateValue] - | ValPat Environment Expression - -type DeconsInfo = [(String, IORef IntermidiateValue, [(Environment, PrimePat, Expression)])] - --- --- Parser --- - -lexer = P.makeTokenParser haskellDef - -charLiteral = P.charLiteral lexer -stringLiteral = P.stringLiteral lexer -integer = P.integer lexer -float = P.float lexer -parens = P.parens lexer -angles = P.angles lexer -brackets = P.brackets lexer -braces = P.braces lexer - -headSymbol :: Parser Char -headSymbol = oneOf ":+-*/=" - -restSymbol :: Parser Char -restSymbol = oneOf "!?:+-*/=" - -word :: Parser String -word = do first <- (letter <|> headSymbol) - rest <- many (letter <|> digit <|> restSymbol) - return (first:rest) - -spaces :: Parser () -spaces = skipMany (oneOf " \n\t") - -spaces1 :: Parser () -spaces1 = skipMany1 (oneOf " \n\t") - -parseTopExpression :: Parser TopExpression -parseTopExpression = do spaces - parens (do try (string "define") - spaces - char '$' - name <- word - spaces - expr <- parseExpression - return (Define name expr) - <|> do try (string "test") - spaces - expr <- parseExpression - spaces - return (Test expr) - <|> do try (string "execute") - return Execute - <|> do try (string "load") - spaces - filename <- stringLiteral - spaces - return (Load filename) - ) "top expression" - -parseExpression :: Parser Expression -parseExpression = do ws <- word - return (SymbolExp ws) - <|> do c <- charLiteral - return (CharacterExp c) - <|> do str <- stringLiteral - return (StringExp str) - <|> do d <- try float - return (DoubleExp d) - <|> do n <- try integer - return (IntegerExp n) - <|> angles (do c <- word - spaces - vs <- sepEndBy parseExpression spaces - return (InductiveDataExp c vs)) - <|> brackets (do vs <- sepEndBy parseExpression spaces - return (TupleExp vs)) - <|> braces (do vs <- sepEndBy parseInnerExp spaces - return (CollectionExp vs)) - <|> try (do pat <- parsePatternExp - return (PatternExp pat)) - <|> parens (do try (do string "lambda" - spaces1) - args <- parseFunPat - spaces - body <- parseExpression - return (FunctionExp args body) - <|> do try (do string "with" - spaces1) - char '$' - name <- word - spaces - expr <- parseExpression - return (WithExp name expr) - <|> do try (do string "do" - spaces1) - bind <- parseBind - spaces - body <- parseExpression - return (DoExp bind body) - <|> do try (do string "let" - spaces1) - bind <- parseRecursiveBind - spaces - body <- parseExpression - return (LetExp bind body) - <|> do try (do string "type" - spaces1) - bind <- parseRecursiveBind - return (TypeExp bind) - <|> do try (do string "type-ref" - spaces1) - typ <- parseExpression - spaces - name <- word - return (TypeRefExp typ name) - <|> do try (do string "deconstructor" - spaces1) - deconsInfo <- parseDeconsInfoExp - return (DeconstructorExp deconsInfo) - <|> do try (do string "match" - spaces1) - tgt <- parseExpression - spaces - typ <- parseExpression - spaces - clss <- braces (sepEndBy parseMatchClause spaces) - return (MatchExp tgt typ clss) - <|> do try (do string "match-all" - spaces1) - tgt <- parseExpression - spaces - typ <- parseExpression - spaces - cls <- parseMatchClause - spaces - return (MatchAllExp tgt typ cls) - <|> do try (do string "apply" - spaces1) - fn <- parseExpression - spaces - args <- parseExpression - return (ApplyExp fn args) - <|> do fn <- parseExpression - spaces - args <- sepEndBy parseExpression spaces - return (ApplyExp fn (TupleExp args))) - -parseInnerExp :: Parser InnerExp -parseInnerExp = do v <- parseExpression - return (ElementExp v) - <|> do char '@' - v <- parseExpression - return (SubCollectionExp v) - -parseFunPat :: Parser FunPat -parseFunPat = do char '$' - name <- word - return (FunPatVar name) - <|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces)) - case fpats of - [fpat] -> return fpat - _ -> return (FunPatTuple fpats)) - -parseBind :: Parser Bind -parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat - spaces - expr <- parseExpression - return (fpat, expr))) - spaces - return bs) - -parseRecursiveBind :: Parser RecursiveBind -parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$' - var <- word - spaces - expr <- parseExpression - return (var, expr))) - spaces - return bs) - -parseDeconsInfoExp :: Parser DeconsInfoExp -parseDeconsInfoExp = braces (sepEndBy parseDeconsClause spaces) - -parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)]) -parseDeconsClause = brackets (do patCons <- word - spaces - typExpr <- parseExpression - spaces - dc2s <- braces (sepEndBy parseDeconsClause2 spaces) - return (patCons, typExpr, dc2s)) - -parseDeconsClause2 :: Parser (PrimePat, Expression) -parseDeconsClause2 = brackets (do datPat <- parsePrimePat - spaces - expr <- parseExpression - return (datPat, expr)) - -parsePrimePat :: Parser PrimePat -parsePrimePat = do char '_' - return PrimeWildCard - <|> do c <- try charLiteral - return (PrimePatCharacter c) - <|> do d <- try float - return (PrimePatDouble d) - <|> do n <- try integer - return (PrimePatInteger n) - <|> do char '$' - name <- word - return (PrimePatVar name) - <|> angles (do c <- word - spaces - ps <- sepEndBy parsePrimePat spaces - return (InductivePrimePat c ps)) - <|> brackets (do ps <- sepEndBy parsePrimePat spaces - return (TuplePrimePat ps)) - <|> try (do char '{' - spaces - char '}' - return EmptyPat) - <|> try (do char '{' - spaces - a <- parsePrimePat - spaces - char '.' - b <- parsePrimePat - char '}' - return (ConsPat a b)) - <|> try (do char '{' - spaces - char '.' - a <- parsePrimePat - spaces - b <- parsePrimePat - char '}' - return (SnocPat a b)) - -parseMatchClause :: Parser MatchClause -parseMatchClause = brackets (do pat <- parseExpression - spaces - body <- parseExpression - return (MatchClause pat body)) - -parsePatternExp :: Parser PatternExp -parsePatternExp = do char '_' - return WildCardExp - <|> do char '$' - name <- word - return (PatVarExp name) - <|> do char '!' - expr <- parseExpression - return (CutPatExp expr) - <|> do char ',' - expr <- parseExpression - return (ValPatExp expr) - <|> parens (do try (do string "as" - spaces1) - char '$' - name <- word - spaces - expr <- parseExpression - return (AsPatExp name expr) - <|> do try (do string "of" - spaces1) - expr <- parseExpression - return (OfPatExp expr) - ) - --- --- Environment --- -getValueFromFrame :: Frame -> String -> Maybe (IORef IntermidiateValue) -getValueFromFrame (Frame []) _ = Nothing -getValueFromFrame (Frame ((var, iValRef):rest)) name = - if name == var - then Just iValRef - else getValueFromFrame (Frame rest) name - -getValue :: Environment -> String -> Maybe (IORef IntermidiateValue) -getValue (Environment []) name = Nothing -getValue (Environment (frame : env)) name = - let mValRef = getValueFromFrame frame name in - case mValRef of - Nothing -> getValue (Environment env) name - Just iValRef -> Just iValRef - -makeClosure :: Environment -> Expression -> IO (IORef IntermidiateValue) -makeClosure env expr = newIORef (Closure env expr) - -makeClosureList :: Environment -> [Expression] -> IO [IORef IntermidiateValue] -makeClosureList _ [] = return [] -makeClosureList env (expr : exprs) = do - iVal <- makeClosure env expr - iVals <- makeClosureList env exprs - return (iVal:iVals) - -makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue] -makeClosureInnerVals _ [] = return [] -makeClosureInnerVals env (ElementExp expr : rest) = do - iValRef <- makeClosure env expr - innerValRefs <- makeClosureInnerVals env rest - return (Element iValRef : innerValRefs) -makeClosureInnerVals env (SubCollectionExp expr : rest) = do - iValRef <- makeClosure env expr - innerValRefs <- makeClosureInnerVals env rest - return (SubCollection iValRef : innerValRefs) - -makeDeconsInfo :: Environment -> DeconsInfoExp -> IO DeconsInfo -makeDeconsInfo _ [] = return [] -makeDeconsInfo env ((cons, typeExp, dcs):deconsInfoExp) = do - typeIValRef <- makeClosure env typeExp - let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in - do deconsInfo <- makeDeconsInfo env deconsInfoExp - return ((cons, typeIValRef, dcs2):deconsInfo) - -makeFrame :: FunPat -> IORef IntermidiateValue -> IOThrowsError Frame -makeFrame (FunPatVar name) iValRef = do - return (Frame [(name, iValRef)]) -makeFrame (FunPatTuple []) iValRef = do - val <- force iValRef - case val of - Tuple [] -> return (Frame []) - _ -> throwError (Default "invalid number of argument") -makeFrame (FunPatTuple fpats) iValRef = do - val <- force iValRef - let loop fpats2 iValRefs2 = case (fpats2, iValRefs2) of - ([], []) -> return (Frame []) - ((fpat2:fps), (iValRef2:ivrs)) -> do frame1 <- makeFrame fpat2 iValRef2 - frame2 <- loop fps ivrs - return (appendFrames frame1 frame2) - (_, _) -> throwError (Default "invalid number of argument") in - case val of - Tuple iValRefs2 -> loop fpats iValRefs2 - _ -> loop fpats [iValRef] - -makeFrameMap :: FunPat -> [IORef IntermidiateValue] -> IOThrowsError [Frame] -makeFrameMap _ [] = return [] -makeFrameMap fpat (iValRef:iValRefs) = do - frame <- makeFrame fpat iValRef - frames <- makeFrameMap fpat iValRefs - return (frame:frames) - -appendFrames :: Frame -> Frame -> Frame -appendFrames (Frame frame1) (Frame frame2) = Frame (frame1 ++ frame2) - -makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame -makeRecursiveFrame env bind = - let vars = map fst bind in - let exprs = map snd bind in - do iValRefs <- liftIO (makeClosureList (Environment []) exprs) - let newFrame = Frame (zip vars iValRefs) in - do liftIO (makeRecursiveFrameHelper env newFrame newFrame) - return newFrame - -makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO () -makeRecursiveFrameHelper _ _ (Frame []) = return () -makeRecursiveFrameHelper env newFrame (Frame ((_, iValRef):assocs)) = do - iVal <- readIORef iValRef - case iVal of - (Closure _ expr) -> writeIORef iValRef (Closure (addFrame newFrame env) expr) - makeRecursiveFrameHelper env newFrame (Frame assocs) - -makeTopFrame :: Definitions -> IOThrowsError Frame -makeTopFrame defsRef = do - defs <- liftIO (readIORef defsRef) - makeRecursiveFrame (Environment []) defs - -addFrame :: Frame -> Environment -> Environment -addFrame frame (Environment frames) = Environment (frame:frames) - --- --- read and show Value --- - -readValue :: String -> IOThrowsError Value -readValue exprStr = do - expr <- readExpression exprStr - expressionToValue expr - -readExpression :: String -> IOThrowsError Expression -readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr) - -expressionToValue :: Expression -> IOThrowsError Value -expressionToValue (CharacterExp c) = return (Character c) -expressionToValue (StringExp str) = do - val <- liftIO (makeCollectionFromValueList (map Character str)) - return val -expressionToValue (IntegerExp n) = return (Integer n) -expressionToValue (DoubleExp d) = return (Double d) -expressionToValue (InductiveDataExp con exprs) = do - vals <- expressionToValueMap exprs - iValRefs <- liftIO (valListToIValRefList vals) - return (InductiveData con iValRefs) -expressionToValue (TupleExp exprs) = do - vals <- expressionToValueMap exprs - case vals of - [val] -> return val - _ -> do iValRefs <- liftIO (valListToIValRefList vals) - return (Tuple iValRefs) -expressionToValue (CollectionExp innerExps) = do - innerVals <- innerExpToInnerValueMap innerExps - return (Collection innerVals) -expressionToValue expr@(PatternExp _) = throwError (WithExpression "not implemented yet" expr) -expressionToValue expr = throwError (WithExpression "You should give a value as an input of read." expr) - -expressionToValueMap :: [Expression] -> IOThrowsError [Value] -expressionToValueMap [] = return [] -expressionToValueMap (expr:exprs) = do - val <- expressionToValue expr - vals <- expressionToValueMap exprs - return (val:vals) - -innerExpToInnerValueMap :: [InnerExp] -> IOThrowsError [InnerValue] -innerExpToInnerValueMap [] = return [] -innerExpToInnerValueMap (ElementExp expr:rest) = do - val <- expressionToValue expr - iValRef <- liftIO (newIORef (Value val)) - innerVals <- innerExpToInnerValueMap rest - return (Element iValRef:innerVals) -innerExpToInnerValueMap (SubCollectionExp expr:rest) = do - val <- expressionToValue expr - iValRef <- liftIO (newIORef (Value val)) - innerVals <- innerExpToInnerValueMap rest - return (SubCollection iValRef:innerVals) - -showValue :: Value -> IO String -showValue (World _ _) = return "#" -showValue (Character c) = return (show c) -showValue (Integer n) = return (show n) -showValue (Double d) = return (show d) -showValue (InductiveData cons []) = do - return ("<" ++ cons ++ ">") -showValue (InductiveData cons iValRefs) = do - vals <- iValRefListToValueList iValRefs - str <- unwordsVals vals - return ("<" ++ cons ++ " " ++ str ++ ">") -showValue (Tuple []) = do - return ("[]") -showValue (Tuple iValRefs) = do - vals <- iValRefListToValueList iValRefs - str <- unwordsVals vals - return ("[" ++ str ++ "]") -showValue (Collection []) = do - return ("{}") -showValue (Collection innerVals) = do - vals <- collectionToValueList (Collection innerVals) - str <- unwordsVals vals - return ("{" ++ str ++ "}") -showValue (Pattern patVal) = do - showPattern patVal -showValue (Function _ _ _) = do - return "#" -showValue (Type _) = do - return "#" -showValue (DeconstructorFunction _) = do - return "#" -showValue (Deconstructor _ _) = do - return "#" -showValue (BuiltinFunction _) = do - return "#" - -showPattern :: Pattern -> IO String -showPattern WildCard = return "_" -showPattern (PatVar name) = return ("$" ++ name) -showPattern (CutPat _) = return "#" -showPattern (AsPat _ _) = return "#" -showPattern (OfPat _) = return "#" -showPattern (ValPat _ _) = return "#" - -unwordsList :: Show a => [a] -> String -unwordsList = unwords . map show - -unwordsVals :: [Value] -> IO String -unwordsVals [] = return "" -unwordsVals (val:vals) = do - s1 <- showValue val - s2 <- unwordsValsHelper vals - return (s1 ++ s2) - -unwordsValsHelper :: [Value] -> IO String -unwordsValsHelper [] = return "" -unwordsValsHelper (val:vals) = do - s1 <- showValue val - s2 <- unwordsValsHelper vals - return (" " ++ s1 ++ s2) - --- --- Eval --- - -force :: IORef IntermidiateValue -> IOThrowsError Value -force iValRef = do - iVal <- liftIO (readIORef iValRef) - case iVal of - Closure env expr -> do val <- eval1 env expr - liftIO (writeIORef iValRef (Value val)) - return val - Value val -> return val - -eval1 :: Environment -> Expression -> IOThrowsError Value -eval1 _ (CharacterExp c) = return (Character c) -eval1 _ (StringExp str) = do - val <- liftIO (makeCollectionFromValueList (map Character str)) - return val -eval1 _ (IntegerExp n) = return (Integer n) -eval1 _ (DoubleExp d) = return (Double d) -eval1 env (SymbolExp name) = - let mIValRef = getValue env name in - case mIValRef of - Just iValRef -> force iValRef - Nothing -> let mBuiltinFn = getBuiltin name in - case mBuiltinFn of - Just builtinFn -> return (BuiltinFunction builtinFn) - Nothing -> throwError (UnboundVariable name) -eval1 env (InductiveDataExp con exprs) = do - iValRefs <- liftIO (makeClosureList env exprs) - return (InductiveData con iValRefs) -eval1 env (TupleExp exprs) = do - iValRefs <- liftIO (makeClosureList env exprs) - case iValRefs of - [iValRef] -> do force iValRef - _ -> return (Tuple iValRefs) -eval1 env (CollectionExp innerExps) = do - innerVals <- liftIO (makeClosureInnerVals env innerExps) - return (Collection innerVals) -eval1 env (PatternExp patExp) = evalPattern1 env patExp -eval1 env (FunctionExp args body) = return (Function env args body) -eval1 env (WithExp name expr) = eval1 env (LetExp [(name, expr)] (SymbolExp name)) -eval1 env (DoExp [] body) = eval1 env body -eval1 env (DoExp ((fpat,expr):assocs) body) = do - iValRef <- liftIO (makeClosure env expr) - frame <- makeFrame fpat iValRef - eval1 (addFrame frame env) (DoExp assocs body) -eval1 env (LetExp bind body) = do - frame <- makeRecursiveFrame env bind - iValRef <- liftIO (newIORef (Closure (addFrame frame env) body)) - force iValRef -eval1 env (TypeExp bind) = do - frame <- makeRecursiveFrame env bind - return (Type frame) -eval1 env expr@(TypeRefExp typExp name) = do - typVal <- eval1 env typExp - case typVal of - (Type frame) -> let mIValRef = getValueFromFrame frame name in - case mIValRef of - Nothing -> throwError (WithExpression ("no method in type" ++ name) expr) - Just iValRef -> do val <- force iValRef - return val - _ -> throwError (WithExpression "first arg of typeref is not type" expr) -eval1 env (DeconstructorExp deconsInfoExp) = do - deconsInfo <- liftIO (makeDeconsInfo env deconsInfoExp) - return (DeconstructorFunction deconsInfo) -eval1 env (MatchExp tgtExp typExp mCs) = do - typIVal <- liftIO (makeClosure env typExp) - tgtIVal <- liftIO (makeClosure env tgtExp) - forceMatchExp env typIVal tgtIVal mCs -eval1 env (MatchAllExp tgtExp typExp mC) = do - typIVal <- liftIO (makeClosure env typExp) - tgtIVal <- liftIO (makeClosure env tgtExp) - forceMatchAllExp env typIVal tgtIVal mC -eval1 env expr@(ApplyExp fnExp argsExp) = do - fnVal <- eval1 env fnExp - argsIValRef <- liftIO (makeClosure env argsExp) - case fnVal of - BuiltinFunction builtinFn -> do argsVal <- forceRecursively argsIValRef - argsVals <- liftIO (tupleToValueList argsVal) - builtinFn argsVals - Function funEnv fpat body -> do frame <- makeFrame fpat argsIValRef - iValRef <- liftIO (makeClosure (addFrame frame funEnv) body) - force iValRef - DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo) - _ -> throwError (WithExpression "applying non-functional object" expr) - -evalPattern1 :: Environment -> PatternExp -> IOThrowsError Value -evalPattern1 _ WildCardExp = return (Pattern WildCard) -evalPattern1 _ (PatVarExp name) = return (Pattern (PatVar name)) -evalPattern1 env (CutPatExp expr) = do - iValRef <- liftIO (makeClosure env expr) - return (Pattern (CutPat iValRef)) -evalPattern1 env (AsPatExp var expr) = do - iValRef <- liftIO (makeClosure env expr) - return (Pattern (AsPat var iValRef)) -evalPattern1 env (OfPatExp expr) = do - iValRef <- liftIO (makeClosure env expr) - iValRefs <- collectionToList iValRef - return (Pattern (OfPat iValRefs)) -evalPattern1 env (ValPatExp expr) = do - return (Pattern (ValPat env expr)) - -eval :: Environment -> Expression -> IOThrowsError Value -eval env expr = do - iValRef <- liftIO (makeClosure env expr) - val <- force iValRef - forceValue val - return val - -forceValue :: Value -> IOThrowsError Value -forceValue (InductiveData cons iValRefs) = do - forceRecursivelyList iValRefs - return (InductiveData cons iValRefs) -forceValue (Tuple iValRefs) = do - forceRecursivelyList iValRefs - return (Tuple iValRefs) -forceValue (Collection innerVals) = do - forceRecursivelyInnerVals innerVals - return (Collection innerVals) -forceValue (Pattern pat) = do - forceRecursivelyPattern pat - return (Pattern pat) -forceValue val = return val - -forceRecursively :: IORef IntermidiateValue -> IOThrowsError Value -forceRecursively iValRef = do - val <- force iValRef - forceValue val - -forceRecursivelyList :: [IORef IntermidiateValue] -> IOThrowsError () -forceRecursivelyList [] = return () -forceRecursivelyList (iValRef:iValRefs) = do - forceRecursively iValRef - forceRecursivelyList iValRefs - -forceRecursivelyInnerVals :: [InnerValue] -> IOThrowsError () -forceRecursivelyInnerVals [] = return () -forceRecursivelyInnerVals (Element iValRef : rest) = do - forceRecursively iValRef - forceRecursivelyInnerVals rest -forceRecursivelyInnerVals (SubCollection iValRef : rest) = do - forceRecursively iValRef - forceRecursivelyInnerVals rest - -forceRecursivelyPattern :: Pattern -> IOThrowsError Pattern -forceRecursivelyPattern WildCard = return WildCard -forceRecursivelyPattern (PatVar var) = return (PatVar var) -forceRecursivelyPattern (CutPat iValRef) = do - forceRecursively iValRef - return (CutPat iValRef) -forceRecursivelyPattern (AsPat var iValRef) = do - forceRecursively iValRef - return (AsPat var iValRef) -forceRecursivelyPattern (OfPat iValRefs) = do - forceRecursivelyList iValRefs - return (OfPat iValRefs) -forceRecursivelyPattern (ValPat onEnv expr) = do - return (ValPat onEnv expr) - --- --- --- - -forceMatchExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> [MatchClause] -> IOThrowsError Value -forceMatchExp env typIValRef tgtIValRef (MatchClause pat expr:rest) = do - typVals <- tupleToList typIValRef - tgtVals <- tupleToList tgtIValRef - patIValRef <- liftIO (makeClosure env pat) - patVals <- tupleToList patIValRef - matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals - case matchs of - [] -> forceMatchExp env typIValRef tgtIValRef rest - (frame:_) -> do iValRef <- liftIO (makeClosure (addFrame frame env) expr) - force iValRef -forceMatchExp _ _ _ _ = throwError (Default "end of match clause") - -forceMatchAllExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value -forceMatchAllExp env typIValRef tgtIValRef (MatchClause pat expr) = do - typVals <- tupleToList typIValRef - tgtVals <- tupleToList tgtIValRef - patIValRef <- liftIO (makeClosure env pat) - patVals <- tupleToList patIValRef - matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals - innerVals <- forceMatchAllExpHelper env matchs expr - return (Collection innerVals) - -forceMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue] -forceMatchAllExpHelper _ [] _ = return [] -forceMatchAllExpHelper env (frame:frames) expr = do - iValRef <- liftIO (makeClosure (addFrame frame env) expr) - force iValRef - rest <- forceMatchAllExpHelper env frames expr - return (Element iValRef:rest) - -patternMatchList :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame] -patternMatchList [] _ _ _ = return [] -patternMatchList frames [] [] [] = return frames -patternMatchList frames (typRef:typRefs) (patRef:patRefs) (tgtRef:tgtRefs) = do - typVal <- force typRef - patVal <- force patRef - newFrames <- patternMatch frames typVal patVal tgtRef - patternMatchList newFrames typRefs patRefs tgtRefs -patternMatchList _ _ _ _ = throwError (Default "numbers of type, pattern, and target are different") - -patternMatchListMap :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame] -patternMatchListMap _ _ _ [] = return [] -patternMatchListMap frames typesIValRefs patIValRefs (tgtIValRef:rest) = do - tgtIValRefs <- tupleToList tgtIValRef - frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs - frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest - return (frames1 ++ frames2) - -patternMatch :: [Frame] -> Value -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame] -patternMatch [] _ _ _ = return [] -patternMatch frames _ (Pattern WildCard) _ = return frames -patternMatch frames (Type bind) (Pattern (PatVar var)) tgtIValRef = do - case getValueFromFrame bind "var-match" of - Nothing -> throwError (Default "no var-match") - Just varMatchFnRef -> do varMatchFn <- force varMatchFnRef - case varMatchFn of - Function funEnv fpat body -> do argsFrame <- makeFrame fpat tgtIValRef - iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body) - iValRefs <- collectionToList iValRef - newFrames <- makeFrameMap (FunPatVar var) iValRefs - return (connectFrames frames newFrames) - _ -> throwError (Default "not function : var-match") -patternMatch frames (Type bind) (InductiveData cons patIValRefs) tgtIValRef = - case getValueFromFrame bind "inductive-match" of - Nothing -> throwError (Default "no inductive-match") - Just inductiveMatchFnRef - -> do inductiveMatchFn <- force inductiveMatchFnRef - case inductiveMatchFn of - DeconstructorFunction deconsInfo - -> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef - Function funEnv fpat body - -> do argsFrame <- makeFrame fpat tgtIValRef - iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body) - val <- force iValRef - case val of - Deconstructor tgtIValRef2 deconsInfo - -> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef2 - _ -> throwError (Default "not function : inductive-match") -patternMatch (frame:_) typVal (Pattern (CutPat patIValRef)) tgtIValRef = do - patVal <- force patIValRef - patternMatch [frame] typVal patVal tgtIValRef -patternMatch frames typVal (Pattern (AsPat name patIValRef)) tgtIValRef = undefined -patternMatch frames typVal (Pattern (OfPat patIValRefs)) tgtIValRef = - let loop patIValRefs2 = case patIValRefs2 of - [] -> return [] - patIValRef:rests -> do patVal <- force patIValRef - newFrames1 <- patternMatch frames typVal patVal tgtIValRef - newFrames2 <- loop rests - return (newFrames1 ++ newFrames2) in - loop patIValRefs -patternMatch frames (Type bind) (Pattern (ValPat onEnv expr)) tgtIValRef = do - case getValueFromFrame bind "equal?" of - Nothing -> throwError (Default "no equal? function") - Just equalFnRef -> do equalFn <- force equalFnRef - case equalFn of - Function funEnv fpat body - -> let loop frames2 = case frames2 of - [] -> return [] - (frame:rests) - -> do iValPatRef <- liftIO (makeClosure (addFrame frame onEnv) expr) - argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef]))) - argsFrame <- makeFrame fpat argsIValRef - iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body) - val <- force iValRef - restFrames <- loop rests - case val of - (InductiveData "true" []) -> return (frame:restFrames) - (InductiveData "false" []) -> return restFrames - _ -> throwError (Default "invalid return value from equal? function") in - loop frames - _ -> throwError (Default "equal? is not function") -patternMatch _ _ _ _ = throwError (Default "invalid pattern : you should add ',' to the head of value") - -doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame] -doDeconstruct [] _ _ _ = throwError (Default "no match decons clause") -doDeconstruct ((pCons, innerTypeIValRef, dcs):deconsInfo) frames (InductiveData cons pats) tgtIValRef = - if pCons == cons - then do innerTypeIValRefs <- tupleToList innerTypeIValRef - let loop dcs2 = case dcs2 of - [] -> throwError (Default "no match primitive pattern") - (env, primePat, expr):rest -> do mFrame <- primitivePatternMatch primePat tgtIValRef - case mFrame of - Nothing -> loop rest - Just pFrame -> do retIValRef <- liftIO (makeClosure (addFrame pFrame env) expr) - retIValRefs <- collectionToList retIValRef - patternMatchListMap frames innerTypeIValRefs pats retIValRefs in - loop dcs - else doDeconstruct deconsInfo frames (InductiveData cons pats) tgtIValRef -doDeconstruct _ _ _ _ = throwError (Default "at doDeconstruct : number of types, patterns, and targets are different") - -connectFrames :: [Frame] -> [Frame] -> [Frame] -connectFrames [] _ = [] -connectFrames (frame:frames) newFrames = - (map (\newFrame -> (appendFrames frame newFrame)) newFrames) ++ (connectFrames frames newFrames) - --- --- --- - -primitivePatternMatch :: PrimePat -> IORef IntermidiateValue -> IOThrowsError (Maybe Frame) -primitivePatternMatch PrimeWildCard _ = return (Just (Frame [])) -primitivePatternMatch (PrimePatCharacter c) iValRef = do - val <- force iValRef - case val of - Character c2 -> if c == c2 - then return (Just (Frame [])) - else return Nothing - _ -> throwError (Default "primitive : not character to primitive character pat") -primitivePatternMatch (PrimePatInteger n) iValRef = do - val <- force iValRef - case val of - Integer n2 -> if n == n2 - then return (Just (Frame [])) - else return Nothing - _ -> throwError (Default "primitive : not integer to primitive integer pat") ---primitivePatternMatch (PrimePatDouble d) iValRef = do --- val <- force iValRef --- case val of --- Integer d2 -> if d == d2 --- then return (Just (Frame [])) --- else return Nothing --- _ -> throwError (Default "primitive : not double to primitive double pat") -primitivePatternMatch (PrimePatVar name) iValRef = return (Just (Frame [(name, iValRef)])) -primitivePatternMatch (InductivePrimePat pCons pPats) iValRef = do - val <- force iValRef - case val of - InductiveData cons iValRefs -> if pCons == cons - then primitivePatternMatchAll pPats iValRefs - else return Nothing - _ -> do valStr <- liftIO (showValue val) - throwError (Default ("primitive : not inductive value to primitive inductive pattern : " ++ valStr)) -primitivePatternMatch (TuplePrimePat pPats) iValRef = do - val <- force iValRef - case val of - Tuple iValRefs -> primitivePatternMatchAll pPats iValRefs - _ -> throwError (Default "primitive : not tuple value to primitive tuple pattern") -primitivePatternMatch EmptyPat iValRef = do - val <- force iValRef - b <- isEmptyCollection val - if b - then return (Just (Frame [])) - else return Nothing -primitivePatternMatch (ConsPat carPat cdrPat) iValRef = do - val <- force iValRef - b <- isEmptyCollection val - if b - then return Nothing - else do (carIValRef, cdrIValRef) <- consDeconstruct val - mCarFrame <- primitivePatternMatch carPat carIValRef - case mCarFrame of - Nothing -> return Nothing - Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrIValRef - case mCdrFrame of - Nothing -> return Nothing - Just cdrFrame -> return (Just (appendFrames carFrame cdrFrame)) -primitivePatternMatch (SnocPat rdcPat racPat) iValRef = do - val <- force iValRef - b <- isEmptyCollection val - if b - then return Nothing - else do (racIValRef, rdcIValRef) <- snocDeconstruct val - mRacFrame <- primitivePatternMatch racPat racIValRef - case mRacFrame of - Nothing -> return Nothing - Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcIValRef - case mRdcFrame of - Just rdcFrame -> return (Just (appendFrames racFrame rdcFrame)) - Nothing -> return Nothing - -primitivePatternMatchAll :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame) -primitivePatternMatchAll [] [] = return (Just (Frame [])) -primitivePatternMatchAll (pat:pats) (iValRef:iValRefs) = do - mFrame <- primitivePatternMatch pat iValRef - case mFrame of - Nothing -> return Nothing - Just frame -> do mRestFrame <- primitivePatternMatchAll pats iValRefs - case mRestFrame of - Nothing -> return Nothing - Just restFrame -> return (Just (appendFrames frame restFrame)) -primitivePatternMatchAll _ _ = throwError (Default "primitivePatternMatchAll : number of patterns and targets are different") - -isEmptyCollection :: Value -> IOThrowsError Bool -isEmptyCollection (Collection []) = return True -isEmptyCollection (Collection (Element _:_)) = return False -isEmptyCollection (Collection (SubCollection subRef:rest)) = do - subVal <- force subRef - b <- isEmptyCollection subVal - if b - then isEmptyCollection (Collection rest) - else return False -isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection") - -consDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue) -consDeconstruct (Collection (Element eRef:rest)) = do - restRef <- liftIO (newIORef (Value (Collection rest))) - return (eRef, restRef) -consDeconstruct (Collection (SubCollection subRef:rest)) = do - subVal <- force subRef - b <- isEmptyCollection subVal - if b - then consDeconstruct (Collection rest) - else do (carRef, cdrRef) <- consDeconstruct subVal - cdrVal <- force cdrRef - case cdrVal of - Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest)))) - return (carRef, restRef) -consDeconstruct (Collection []) = throwError (Default "empty collection") -consDeconstruct _ = throwError (Default "consDeconstruct : not collection") - -snocDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue) -snocDeconstruct (Collection innerVals) = - case reverse innerVals of - Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest)))) - return (eRef, restRef) - SubCollection subRef:rest - -> do subVal <- force subRef - b <- isEmptyCollection subVal - if b - then snocDeconstruct (Collection (reverse rest)) - else do (racRef, rdcRef) <- snocDeconstruct subVal - rdcVal <- force rdcRef - case rdcVal of - Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs)))) - return (racRef, restRef) -snocDeconstruct _ = throwError (Default "snocDeconstruct : not collection") - --- --- --- - -valListToIValRefList :: [Value] -> IO [IORef IntermidiateValue] -valListToIValRefList [] = return [] -valListToIValRefList (val:vals) = do - iValRef <- newIORef (Value val) - iValRefs <- valListToIValRefList vals - return (iValRef:iValRefs) - -iValRefListToValueList :: [IORef IntermidiateValue] -> IO [Value] -iValRefListToValueList [] = return [] -iValRefListToValueList (iValRef:iValRefs) = do - iVal <- readIORef iValRef - case iVal of - Value val -> do vals <- iValRefListToValueList iValRefs - return (val:vals) - -tupleToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue] -tupleToList iValRef = do - val <- force iValRef - case val of - (Tuple iValRefs) -> return iValRefs - val -> return [iValRef] - -tupleToValueList :: Value -> IO [Value] -tupleToValueList (Tuple []) = return [] -tupleToValueList (Tuple (iValRef:iValRefs)) = do - val <- readIORef iValRef - case val of - Value val -> do vals <- tupleToValueList (Tuple iValRefs) - return (val:vals) -tupleToValueList val = return [val] - -makeTupleFromValueList :: [Value] -> IO Value -makeTupleFromValueList vals = do - iValRefs <- makeIValRefList vals - return (Tuple iValRefs) - -makeIValRefList :: [Value] -> IO [IORef IntermidiateValue] -makeIValRefList [] = return [] -makeIValRefList (val:vals) = do - iValRef <- newIORef (Value val) - iValRefs <- makeIValRefList vals - return (iValRef:iValRefs) - -collectionToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue] -collectionToList iValRef = do - val <- force iValRef - let loop val = case val of - (Collection []) -> return [] - (Collection (Element eRef:rest)) -> do restRefs <- loop (Collection rest) - return (eRef : restRefs) - (Collection (SubCollection subRef:rest)) -> do valRefs1 <- collectionToList subRef - valRefs2 <- loop (Collection rest) - return (valRefs1 ++ valRefs2) - _ -> throwError (Default "collectionToList : not collection") in - loop val - -collectionToValueList :: Value -> IO [Value] -collectionToValueList (Collection []) = return [] -collectionToValueList (Collection (Element eRef : rest)) = do - eIVal <- readIORef eRef - case eIVal of - Value e -> do rest <- collectionToValueList (Collection rest) - return (e : rest) -collectionToValueList (Collection (SubCollection subRef : rest)) = do - subIVal <- readIORef subRef - case subIVal 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 - eIVal <- liftIO (readIORef eRef) - restStr <- charCollectionToString (Collection rest) - case eIVal of - Value (Character c) -> return (c : restStr) - _ -> throwError (Default "charCollectionToString : not char collection") - -makeCollectionFromValueList :: [Value] -> IO Value -makeCollectionFromValueList vals = - let loop vals2 = case vals2 of - [] -> return [] - (val:rest) -> do iValRef <- newIORef (Value val) - restRefs <- loop rest - return ((Element iValRef):restRefs) in - do innerVals <- loop vals - return (Collection innerVals) - --- --- Builtin Function --- - -getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value) -getBuiltin name = - case name of - "read" -> Just builtinRead - "write" -> Just builtinWrite - "print" -> Just builtinPrint - "read-char" -> Just builtinReadChar - "write-char" -> Just builtinWriteChar - "memorize" -> Just builtinMemorize - "remember" -> Just builtinRemember - "int-to-float" -> Just builtinIntToFloat - "ceiling" -> Just builtinCeiling - "floor" -> Just builtinFloor - "truncate" -> Just builtinTruncate - "round" -> Just builtinRound - "=" -> Just builtinEqual - "compare-integer" -> Just builtinCompareInteger - "+" -> Just builtinPlus - "-" -> Just builtinMinus - "*" -> Just builtinMultiply - "dev" -> Just builtinDevide - "mod" -> Just builtinMod - "=f" -> Just builtinEqualFloat - "compare-float" -> Just builtinCompareFloat - "+f" -> Just builtinPlusFloat - "-f" -> Just builtinMinusFloat - "*f" -> Just builtinMultiplyFloat - "/f" -> Just builtinDevideFloat --- "pi" -> Just builtinPi - "exp" -> Just builtinExp - "log" -> Just builtinLog - "sqrt" -> Just builtinSqrt - "**" -> Just builtinPower - "log-base" -> Just builtinLogBase - "sin" -> Just builtinSin - "cos" -> Just builtinCos - "tan" -> Just builtinTan - "asin" -> Just builtinAsin - "acos" -> Just builtinAcos - "atan" -> Just builtinAtan - "sinh" -> Just builtinSinh - "cosh" -> Just builtinCosh - "tanh" -> Just builtinTanh - "asinh" -> Just builtinAsinh - "acosh" -> Just builtinAcosh - "atanh" -> Just builtinAtanh - _ -> Nothing - -builtinRead :: [Value] -> IOThrowsError Value -builtinRead [(World memory actions)] = do - str <- liftIO (getExpressionHelper False 0) - val <- readValue str - ret <- liftIO (makeTupleFromValueList [World memory ((Read val):actions), val]) - return ret -builtinRead _ = throwError (Default "invalid args to read") - -builtinWrite :: [Value] -> IOThrowsError Value -builtinWrite [(World memory actions), val] = do - valStr <- liftIO (showValue val) - liftIO (flushStr valStr) - return (World memory ((Write val):actions)) -builtinWrite _ = throwError (Default "invalid args to write") - -builtinPrint :: [Value] -> IOThrowsError Value -builtinPrint [(World memory actions), val] = do - str <- charCollectionToString val - liftIO (flushStr str) - return (World memory ((Print str):actions)) -builtinPrint _ = throwError (Default "invalid args to print") - -builtinReadChar :: [Value] -> IOThrowsError Value -builtinReadChar [(World memory actions)] = do - c <- liftIO getChar - ret <- liftIO (makeTupleFromValueList [World memory ((Read (Character c)):actions), Character c]) - return ret -builtinReadChar _ = throwError (Default "invalid args to read-char") - -builtinWriteChar :: [Value] -> IOThrowsError Value -builtinWriteChar [(World memory actions), (Character c)] = do - liftIO (putChar c) - return (World memory ((Write (Character c)):actions)) -builtinWriteChar _ = throwError (Default "invalid args to write-char") - - -builtinMemorize :: [Value] -> IOThrowsError Value -builtinMemorize [(World memory actions), key, val] = - let newMemory = addToMemory key val memory in - return (World newMemory ((Memorize key val):actions)) - -builtinRemember :: [Value] -> IOThrowsError Value -builtinRemember [(World memory actions), key] = do - mVal <- lookupMemory key memory - case mVal of - Nothing -> throwError (Default "can not remember") - Just val -> do iValRefs <- liftIO (makeIValRefList [(World memory ((Remember key val):actions)), val]) - return (Tuple iValRefs) - -builtinIntToFloat :: [Value] -> IOThrowsError Value -builtinIntToFloat [Integer n] = return (Double (fromInteger n)) -builtinIntToFloat _ = throwError (Default "invalid args to int-to-float") - -builtinCeiling :: [Value] -> IOThrowsError Value -builtinCeiling [Double d] = return (Integer (ceiling d)) -builtinCeiling _ = throwError (Default "invalid args to ceiling") - -builtinFloor :: [Value] -> IOThrowsError Value -builtinFloor [Double d] = return (Integer (floor d)) -builtinFloor _ = throwError (Default "invalid args to floor") - -builtinTruncate :: [Value] -> IOThrowsError Value -builtinTruncate [Double d] = return (Integer (truncate d)) -builtinTruncate _ = throwError (Default "invalid args to truncate") - -builtinRound :: [Value] -> IOThrowsError Value -builtinRound [Double d] = return (Integer (round d)) -builtinRound _ = throwError (Default "invalid args to round") - - -builtinEqual :: [Value] -> IOThrowsError Value -builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2) - then return (InductiveData "true" []) - else return (InductiveData "false" []) -builtinEqual _ = throwError (Default "invalid args to =") - -builtinCompareInteger :: [Value] -> IOThrowsError Value -builtinCompareInteger [(Integer n1), (Integer n2)] = if (n1 == n2) - then return (InductiveData "equal" []) - else if (n1 < n2) - then return (InductiveData "less" []) - else return (InductiveData "greater" []) -builtinCompareInteger _ = throwError (Default "invalid args to compare-integer") - -builtinPlus :: [Value] -> IOThrowsError Value -builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2)) -builtinPlus _ = throwError (Default "invalid args to +") - -builtinMinus :: [Value] -> IOThrowsError Value -builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2)) -builtinMinus _ = throwError (Default "invalid args to -") - -builtinMultiply :: [Value] -> IOThrowsError Value -builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2)) -builtinMultiply _ = throwError (Default "invalid args to *") - -builtinDevide :: [Value] -> IOThrowsError Value -builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2)) -builtinDevide _ = throwError (Default "invalid args to dev") - -builtinMod :: [Value] -> IOThrowsError Value -builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2)) -builtinMod _ = throwError (Default "invalid args to mod") - - -builtinEqualFloat :: [Value] -> IOThrowsError Value -builtinEqualFloat [(Double n1), (Double n2)] = if (n1 == n2) - then return (InductiveData "true" []) - else return (InductiveData "false" []) -builtinEqualFloat _ = throwError (Default "invalid args to =f") - -builtinCompareFloat :: [Value] -> IOThrowsError Value -builtinCompareFloat [(Double n1), (Double n2)] = if (n1 == n2) - then return (InductiveData "equal" []) - else if (n1 < n2) - then return (InductiveData "less" []) - else return (InductiveData "greater" []) -builtinCompareFloat _ = throwError (Default "invalid args to compare-float") - -builtinPlusFloat :: [Value] -> IOThrowsError Value -builtinPlusFloat [(Double n1), (Double n2)] = return (Double (n1 + n2)) -builtinPlusFloat _ = throwError (Default "invalid args to +f") - -builtinMinusFloat :: [Value] -> IOThrowsError Value -builtinMinusFloat [(Double n1), (Double n2)] = return (Double (n1 - n2)) -builtinMinusFloat _ = throwError (Default "invalid args to -f") - -builtinMultiplyFloat :: [Value] -> IOThrowsError Value -builtinMultiplyFloat [(Double n1), (Double n2)] = return (Double (n1 * n2)) -builtinMultiplyFloat _ = throwError (Default "invalid args to *f") - -builtinDevideFloat :: [Value] -> IOThrowsError Value -builtinDevideFloat [(Double n1), (Double n2)] = return (Double (n1 / n2)) -builtinDevideFloat _ = throwError (Default "invalid args to /f") - - -builtinExp :: [Value] -> IOThrowsError Value -builtinExp [Double d] = return (Double (exp d)) -builtinExp _ = throwError (Default "invalid args to exp") - -builtinLog :: [Value] -> IOThrowsError Value -builtinLog [Double d] = return (Double (log d)) -builtinLog _ = throwError (Default "invalid args to log") - -builtinSqrt :: [Value] -> IOThrowsError Value -builtinSqrt [Double d] = return (Double (sqrt d)) -builtinSqrt _ = throwError (Default "invalid args to sqrt") - -builtinPower :: [Value] -> IOThrowsError Value -builtinPower [(Double n1), (Double n2)] = return (Double (n1 ** n2)) -builtinPower _ = throwError (Default "invalid args to **") - -builtinLogBase :: [Value] -> IOThrowsError Value -builtinLogBase [(Double n1), (Double n2)] = return (Double (logBase n1 n2)) -builtinLogBase _ = throwError (Default "invalid args to log-base") - -builtinSin :: [Value] -> IOThrowsError Value -builtinSin [Double d] = return (Double (sin d)) -builtinSin _ = throwError (Default "invalid args to sin") - -builtinCos :: [Value] -> IOThrowsError Value -builtinCos [Double d] = return (Double (cos d)) -builtinCos _ = throwError (Default "invalid args to cos") - -builtinTan :: [Value] -> IOThrowsError Value -builtinTan [Double d] = return (Double (tan d)) -builtinTan _ = throwError (Default "invalid args to tan") - -builtinAsin :: [Value] -> IOThrowsError Value -builtinAsin [Double d] = return (Double (asin d)) -builtinAsin _ = throwError (Default "invalid args to asin") - -builtinAcos :: [Value] -> IOThrowsError Value -builtinAcos [Double d] = return (Double (acos d)) -builtinAcos _ = throwError (Default "invalid args to acos") - -builtinAtan :: [Value] -> IOThrowsError Value -builtinAtan [Double d] = return (Double (atan d)) -builtinAtan _ = throwError (Default "invalid args to atan") - -builtinSinh :: [Value] -> IOThrowsError Value -builtinSinh [Double d] = return (Double (sinh d)) -builtinSinh _ = throwError (Default "invalid args to sinh") - -builtinCosh :: [Value] -> IOThrowsError Value -builtinCosh [Double d] = return (Double (cosh d)) -builtinCosh _ = throwError (Default "invalid args to cosh") - -builtinTanh :: [Value] -> IOThrowsError Value -builtinTanh [Double d] = return (Double (tanh d)) -builtinTanh _ = throwError (Default "invalid args to tanh") - -builtinAsinh :: [Value] -> IOThrowsError Value -builtinAsinh [Double d] = return (Double (asinh d)) -builtinAsinh _ = throwError (Default "invalid args to asinh") - -builtinAcosh :: [Value] -> IOThrowsError Value -builtinAcosh [Double d] = return (Double (acosh d)) -builtinAcosh _ = throwError (Default "invalid args to acosh") - -builtinAtanh :: [Value] -> IOThrowsError Value -builtinAtanh [Double d] = return (Double (atanh d)) -builtinAtanh _ = throwError (Default "invalid args to atanh") - --- --- for Debug : show Expression --- - -showTopExpression :: TopExpression -> String -showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")" -showTopExpression (Test expr) = "(test " ++ show expr ++ ")" -showTopExpression (Load expr) = "(load " ++ show expr ++ ")" -showTopExpression Execute = "(execute)" - -instance Show TopExpression where show = showTopExpression - -showExpression :: Expression -> String -showExpression (CharacterExp c) = "'" ++ show c ++ "'" -showExpression (StringExp s) = "\"" ++ show s ++ "\"" -showExpression (IntegerExp n) = show n -showExpression (SymbolExp name) = name -showExpression (InductiveDataExp s []) = "<" ++ s ++ ">" -showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">" -showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]" -showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}" -showExpression (PatternExp pat) = show pat -showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")" -showExpression (WithExp name expr) = "(with " ++ show name ++ " " ++ show expr ++ ")" -showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")" -showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")" -showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")" -showExpression (DeconstructorExp deconsInfoExp) = "(deconstructor " ++ showDeconsInfoExp deconsInfoExp ++ ")" -showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})" -showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")" -showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")" - -instance Show Expression where show = showExpression - -showInnerExp :: InnerExp -> String -showInnerExp (ElementExp v) = show v -showInnerExp (SubCollectionExp v) = "@" ++ show v - -instance Show InnerExp where show = showInnerExp - -showPatternExp :: PatternExp -> String -showPatternExp WildCardExp = "_" -showPatternExp (PatVarExp s) = "$" ++ s -showPatternExp (CutPatExp p) = "!" ++ show p -showPatternExp (AsPatExp s p) = "(as " ++ s ++ " " ++ show p ++ ")" -showPatternExp (OfPatExp ps) = "(of " ++ show ps ++ ")" -showPatternExp (ValPatExp expr) = "," ++ show expr - -instance Show PatternExp where show = showPatternExp - -showRecursiveBind :: RecursiveBind -> String -showRecursiveBind [] = "{}" -showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}" - -showRecursiveBindHelper :: (String, Expression) -> String -showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]" - -showFunPat :: FunPat -> String -showFunPat (FunPatVar name) = "$" ++ name -showFunPat (FunPatTuple []) = "[]" -showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]" - -instance Show FunPat where show = showFunPat - -showDeconsInfoExp :: DeconsInfoExp -> String -showDeconsInfoExp dcs = "{" ++ unwords (map showDeconsClause dcs) ++ "}" - -showDeconsClause :: (String, Expression, [(PrimePat, Expression)]) -> String -showDeconsClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDeconsClause2 dc2s) ++ "})" - -showDeconsClause2 :: (PrimePat, Expression) -> String -showDeconsClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]" - -showPrimePat :: PrimePat -> String -showPrimePat PrimeWildCard = "_" -showPrimePat (PrimePatVar name) = "$" ++ name -showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">" -showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">" -showPrimePat (TuplePrimePat vs) = "[" ++ unwordsList vs ++ "]" -showPrimePat EmptyPat = "{}" -showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}" -showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}" - -instance Show PrimePat where show = showPrimePat - -showMatchClause :: MatchClause -> String -showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]" - -instance Show MatchClause where show = showMatchClause - -showFrame :: Frame -> String -showFrame (Frame assocs) = - let vars = map fst assocs in - "[" ++ unwords vars ++ "]" - -instance Show Frame where show = showFrame - -showFrames :: [Frame] -> String -showFrames frames = "[" ++ unwordsList frames ++ "]" +welcomeMsg = "Egison, version 1.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" + +data Input = Input String + | Eof + +readPrompt :: String -> IO Input +readPrompt prompt = flushStr prompt >> getExpression + +flushStr :: String -> IO () +flushStr str = putStr str >> hFlush stdout + +getExpressionHelper :: Bool -> Integer -> IO String +getExpressionHelper b n = do c <- getChar + case c of + '(' -> do l <- getExpressionHelper True (n + 1) + return (c : l) + '<' -> do l <- getExpressionHelper True (n + 1) + return (c : l) + '[' -> do l <- getExpressionHelper True (n + 1) + return (c : l) + '{' -> do l <- getExpressionHelper True (n + 1) + return (c : l) + ')' -> do l <- getExpressionHelper True (n - 1) + return (c : l) + '>' -> do l <- getExpressionHelper True (n - 1) + return (c : l) + ']' -> do l <- getExpressionHelper True (n - 1) + return (c : l) + '}' -> do l <- getExpressionHelper True (n - 1) + return (c : l) + '\n' -> if n > 0 + then do l <- getExpressionHelper b n + return (c : l) + else if b + then return "\n" + else getExpressionHelper b n + ' ' -> do l <- getExpressionHelper b n + return (c : l) + '\t' -> do l <- getExpressionHelper b n + return (c : l) + _ -> do l <- getExpressionHelper True n + return (c : l) + +getExpression :: IO Input +getExpression = catch (do str <- getExpressionHelper False 0 + return (Input str)) + (\_ -> return Eof) + + +-- +-- Error Handle +-- + +type IOThrowsError = ErrorT EgiError IO + +data EgiError = Parser ParseError + | UnboundVariable String [Integer] + | WithTopExpression String Expression + | WithExpression String Expression + | Default String + +showError :: EgiError -> String +showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n" +showError (UnboundVariable name nums) = "Error : unbound variable : " ++ name ++ unwordsNums nums ++ "\n" +showError (WithTopExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n" +showError (WithExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n" +showError (Default str) = "Error : " ++ str ++ "\n" + +instance Show EgiError where show = showError + +instance Error EgiError where + noMsg = Default "An error has occured" + strMsg = Default + +type ThrowsError = Either EgiError + +liftThrows :: ThrowsError a -> IOThrowsError a +liftThrows (Left err) = throwError err +liftThrows (Right val) = return val + +runIOThrows :: IOThrowsError String -> IO String +runIOThrows action = runErrorT (trapError action) >>= return . extractValue + +trapError :: (MonadError e m, Show e) => m String -> m String +trapError action = catchError action (return . show) + +extractValue :: ThrowsError a -> a +extractValue (Right val) = val + +readOrThrow :: Parser a -> String -> ThrowsError a +readOrThrow parser input = case parse parser "egison" input of + Left err -> throwError (Parser err) + Right val -> return val + +readTopExpression :: String -> IOThrowsError TopExpression +readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr) + +readTopExpressionList :: String -> IOThrowsError [TopExpression] +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))) + return (name ++ "\n") +executeTopExpression defs (Test expr) = do + topFrame <- makeTopFrame defs + val <- eval [topFrame] expr + ret <- liftIO (showValue val) + return (ret ++ "\n") +executeTopExpression defs (Load filename) = do + str <- liftIO (readFile filename) + topExprs <- readTopExpressionList str + 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" []) + args <- liftIO (newIORef (Value (World []))) + case mainFn of + Function funEnv fpat body + -> do frame <- makeFrame fpat args + objRef <- liftIO (makeClosure (frame:funEnv) body) + cEval objRef + return "" + _ -> throwError (Default "main is not function" ) + + +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 + +main :: IO () +main = do args <- getArgs + case length args of + 0 -> do flushStr welcomeMsg + defsRef <- newIORef [] + runRepl defsRef + _ -> putStrLn "Program takes only 0 argument!" + +-- +-- Data Types +-- + +data TopExpression = Define String Expression + | Test Expression + | Load String + | Execute + +data Expression = CharacterExp Char + | StringExp String + | IntegerExp Integer + | DoubleExp Double + | VariableExp String [Expression] + | InductiveDataExp String [Expression] + | TupleExp [Expression] + | CollectionExp [InnerExp] + | WildCardExp + | PatVarExp String [Expression] + | CutPatExp Expression + | AndPatExp [Expression] + | OrPatExp [Expression] + | PredPatExp String [Expression] + | FunctionExp FunPat Expression + | DoExp Bind Expression + | LetExp RecursiveBind Expression + | LoopExp Expression Expression Expression Expression Expression + | TypeExp RecursiveBind + | TypeRefExp Expression String + | DestructorExp DestructInfoExp + | MatchExp Expression Expression [MatchClause] + | MatchAllExp Expression Expression MatchClause + | ApplyExp Expression Expression + +data InnerExp = ElementExp Expression + | SubCollectionExp Expression + +type Bind = [(FunPat, Expression)] + +data FunPat = FunPatVar String + | FunPatTuple [FunPat] + +type RecursiveBind = [(String, Expression)] + +data MatchClause = MatchClause Expression Expression + +type DestructInfoExp = [(String, Expression, [(PrimePat, Expression)])] + +data PrimePat = PrimeWildCard + | PrimePatCharacter Char + | PrimePatInteger Integer + | PrimePatDouble Double + | PrimePatVar String + | InductivePrimePat String [PrimePat] + | EmptyPat + | ConsPat PrimePat PrimePat + | SnocPat PrimePat PrimePat + +data Object = Closure Environment Expression + | Value Value + +data Value = World [Action] + | Character Char + | Integer Integer + | Double Double + | InductiveData String [ObjectRef] + | Tuple [ObjectRef] + | Collection [InnerValue] + | WildCard + | PatVar String [Integer] + | PredPat String [ObjectRef] + | CutPat ObjectRef + | AndPat [ObjectRef] + | OrPat [ObjectRef] + | Function Environment FunPat Expression + | Macro FunPat Expression + | Loop String String Integer Integer Expression Expression + | Type Frame + | DestructorFunction DestructInfo + | BuiltinFunction ([Value] -> IOThrowsError Value) + +type ObjectRef = IORef Object + +data Action = Read Value + | Write Value + | Print String + +data InnerValue = Element ObjectRef + | SubCollection ObjectRef + +type DestructInfo = [(String, ObjectRef, [(Environment, PrimePat, Expression)])] + +type Environment = [Frame] + +type Frame = [Association] + +type Association = ((String, [Integer]), ObjectRef) + +type Definitions = IORef [(String, Expression)] + +data PClosure = PClosure Frame ObjectRef + +data MAtom = MAtom PClosure ObjectRef ObjectRef + +data MState = MState Frame [MAtom] + +isEqualValue :: Value -> Value -> IOThrowsError Bool +isEqualValue (Character c1) (Character c2) = return (c1 == c2) +isEqualValue (Integer n1) (Integer n2) = return (n1 == n2) +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) + isEqualValueList vals1 vals2 + else return False +isEqualValue (Tuple objRefs1) (Tuple objRefs2) = do + vals1 <- liftIO (objRefListToValueList objRefs1) + vals2 <- liftIO (objRefListToValueList objRefs2) + isEqualValueList vals1 vals2 +isEqualValue val1@(Collection _) val2@(Collection _) = do + vals1 <- liftIO (collectionToValueList val1) + vals2 <- liftIO (collectionToValueList val2) + isEqualValueList vals1 vals2 +isEqualValue _ _ = return False + +isEqualValueList :: [Value] -> [Value] -> IOThrowsError Bool +isEqualValueList [] [] = return True +isEqualValueList (v1:vals1) (v2:vals2) = do + b <- isEqualValue v1 v2 + if b + then isEqualValueList vals1 vals2 + else return False +isEqualValueList _ _ = return False + +objectRefToInteger :: ObjectRef -> IOThrowsError Integer +objectRefToInteger objRef = do + obj <- liftIO (readIORef objRef) + case obj of + Value (Integer n) -> return n + _ -> throwError (Default "objectRefToInteger: not Integer value") +-- +-- Environment +-- +getValueFromFrame :: Frame -> (String,[Integer]) -> Maybe ObjectRef +getValueFromFrame [] _ = Nothing +getValueFromFrame (((var,nums1),objRef):rest) (var2,nums2) = + if var == var2 && nums1 == nums2 + then Just objRef + else getValueFromFrame rest (var2,nums2) + +getValue :: Environment -> (String,[Integer]) -> Maybe ObjectRef +getValue [] _ = Nothing +getValue (frame:env) (var,nums) = + let mObjRef = getValueFromFrame frame (var,nums)in + case mObjRef of + Nothing -> getValue env (var,nums) + Just objRef -> Just objRef + +makeClosure :: Environment -> Expression -> IO ObjectRef +makeClosure env expr = newIORef (Closure env expr) + +makeClosureList :: Environment -> [Expression] -> IO [ObjectRef] +makeClosureList _ [] = return [] +makeClosureList env (expr:exprs) = do + obj <- makeClosure env expr + objs <- makeClosureList env exprs + return (obj:objs) + +makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue] +makeClosureInnerVals _ [] = return [] +makeClosureInnerVals env (ElementExp expr : rest) = do + objRef <- makeClosure env expr + innerValRefs <- makeClosureInnerVals env rest + return (Element objRef : innerValRefs) +makeClosureInnerVals env (SubCollectionExp expr : rest) = do + objRef <- makeClosure env expr + innerValRefs <- makeClosureInnerVals env rest + return (SubCollection objRef : innerValRefs) + +makeDestructInfo :: Environment -> DestructInfoExp -> IO DestructInfo +makeDestructInfo _ [] = return [] +makeDestructInfo env ((cons, typeExp, dcs):deconsInfoExp) = do + typeObjRef <- makeClosure env typeExp + let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in + do deconsInfo <- makeDestructInfo env deconsInfoExp + return ((cons, typeObjRef, dcs2):deconsInfo) + +makeFrameHelper :: [FunPat] -> [ObjectRef] -> IOThrowsError Frame +makeFrameHelper fpats objRefs = + case (fpats, objRefs) of + ([], []) -> return [] + ((fpat:fps), (objRef:ivrs)) -> do frame1 <- makeFrame fpat objRef + frame2 <- makeFrameHelper fps ivrs + return (frame1 ++ frame2) + (_, _) -> throwError (Default "invalid number of argument") + +makeFrame :: FunPat -> ObjectRef -> IOThrowsError Frame +makeFrame (FunPatVar name) objRef = do + return [((name, []), objRef)] +makeFrame (FunPatTuple fpats) objRef = do + val <- cEval1 objRef + case val of + Tuple objRefs -> makeFrameHelper fpats objRefs + _ -> makeFrameHelper fpats [objRef] + +makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO () +makeRecursiveFrameHelper _ _ [] = return () +makeRecursiveFrameHelper env newFrame ((_, objRef):assocs) = do + obj <- readIORef objRef + case obj of + (Closure _ expr) -> writeIORef objRef (Closure (newFrame:env) expr) + makeRecursiveFrameHelper env newFrame assocs + +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 + +makeTopFrame :: Definitions -> IOThrowsError Frame +makeTopFrame defsRef = do + defs <- liftIO (readIORef defsRef) + makeRecursiveFrame [] defs + +-- +-- InnerExp +-- +valListToObjRefList :: [Value] -> IO [ObjectRef] +valListToObjRefList [] = return [] +valListToObjRefList (val:vals) = do + objRef <- newIORef (Value val) + 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) + +tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef] +tupleToObjRefList objRef = do + val <- cEval1 objRef + case val of + (Tuple objRefs) -> return objRefs + val -> return [objRef] + +tupleToValueList :: Value -> IO [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] + +tupleObjRefListToListOfList :: [ObjectRef] -> IOThrowsError [[ObjectRef]] +tupleObjRefListToListOfList [] = return [] +tupleObjRefListToListOfList (objRef:objRefs) = do + objRefs2 <- tupleToObjRefList objRef + objRefss2 <- tupleObjRefListToListOfList objRefs + return (objRefs2:objRefss2) + +makeObjRefList :: [Value] -> IO [ObjectRef] +makeObjRefList [] = return [] +makeObjRefList (val:vals) = do + objRef <- newIORef (Value val) + objRefs <- makeObjRefList vals + return (objRef:objRefs) + +makeTupleFromValueList :: [Value] -> IO Value +makeTupleFromValueList vals = do + objRefs <- makeObjRefList vals + return (Tuple objRefs) + +collectionObjToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef] +collectionObjToObjRefList objRef = do + val <- cEval1 objRef + 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 _ = 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 + eObj <- liftIO (readIORef eRef) + restStr <- charCollectionToString (Collection rest) + case eObj of + Value (Character c) -> return (c : restStr) + _ -> throwError (Default "charCollectionToString : not char collection") + +makeCollectionFromValueList :: [Value] -> IO Value +makeCollectionFromValueList vals = + let loop vals2 = case vals2 of + [] -> return [] + (val:rest) -> do objRef <- newIORef (Value val) + restRefs <- loop rest + return ((Element objRef):restRefs) in + do innerVals <- loop vals + return (Collection innerVals) + +integerValListToIntegerList :: [Value] -> [Integer] +integerValListToIntegerList [] = [] +integerValListToIntegerList ((Integer n):vals) = n:(integerValListToIntegerList vals) + +-- +-- Parser +-- + +lexer = P.makeTokenParser haskellDef + +charLiteral = P.charLiteral lexer +stringLiteral = P.stringLiteral lexer +integer = P.integer lexer +float = P.float lexer +parens = P.parens lexer +angles = P.angles lexer +brackets = P.brackets lexer +braces = P.braces lexer + +headSymbol :: Parser Char +headSymbol = oneOf "+-*/=" + +restSymbol :: Parser Char +restSymbol = oneOf "!?+-*/=" + +word :: Parser String +word = do first <- (letter <|> headSymbol) + rest <- many (letter <|> digit <|> restSymbol) + return (first:rest) + +spaces :: Parser () +spaces = skipMany (oneOf " \n\t") + +spaces1 :: Parser () +spaces1 = skipMany1 (oneOf " \n\t") + +parseTopExpression :: Parser TopExpression +parseTopExpression = do spaces + parens (do try (string "define") + spaces + char '$' + name <- word + spaces + expr <- parseExpression + return (Define name expr) + <|> do try (string "test") + spaces + expr <- parseExpression + spaces + return (Test expr) + <|> do try (string "execute") + return Execute + <|> do try (string "load") + spaces + filename <- stringLiteral + spaces + return (Load filename) + ) "top expression" + +parseExpression :: Parser Expression +parseExpression = do ws <- word + nums <- parseIndexNums + return (VariableExp ws nums) + <|> do c <- charLiteral + return (CharacterExp c) + <|> do str <- stringLiteral + return (StringExp str) + <|> do d <- try float + return (DoubleExp d) + <|> do n <- try integer + return (IntegerExp n) + <|> do try (do char '$' + ws <- word + nums <- parseIndexNums + return (PatVarExp ws nums)) + <|> do char '_' + return WildCardExp + <|> do char '!' + expr <- parseExpression + return (CutPatExp expr) + <|> do char ',' + expr <- parseExpression + return (PredPatExp "equal?" [expr]) + <|> angles (do c <- word + spaces + vs <- sepEndBy parseExpression spaces + return (InductiveDataExp c vs)) + <|> brackets (do vs <- sepEndBy parseExpression spaces + return (TupleExp vs)) + <|> braces (do vs <- sepEndBy parseInnerExp spaces + return (CollectionExp vs)) + <|> parens (do try (do char '&' + spaces1) + exprs <- sepEndBy parseExpression spaces + return (AndPatExp exprs) + <|> do try (do char '|' + spaces1) + exprs <- sepEndBy parseExpression spaces + return (OrPatExp exprs) + <|> do try (do char '?' + spaces1) + name <- word + spaces1 + exprs <- sepEndBy parseExpression spaces + return (PredPatExp name exprs) + <|> do try (do string "lambda" + spaces1) + args <- parseFunPat + spaces + body <- parseExpression + return (FunctionExp args body) + <|> do try (do string "do" + spaces1) + bind <- parseBind + spaces + body <- parseExpression + return (DoExp bind body) + <|> do try (do string "let" + spaces1) + bind <- parseRecursiveBind + spaces + body <- parseExpression + return (LetExp bind body) + <|> do try (do string "loop" + spaces1) + spaces + var1 <- parseExpression + spaces + var2 <- parseExpression + spaces + range <- parseExpression + spaces + body1 <- parseExpression + spaces + body2 <- parseExpression + return (LoopExp var1 var2 range body1 body2) + <|> do try (do string "type" + spaces1) + bind <- parseRecursiveBind + return (TypeExp bind) + <|> do try (do string "type-ref" + spaces1) + typ <- parseExpression + spaces + name <- word + return (TypeRefExp typ name) + <|> do try (do string "destructor" + spaces1) + deconsInfo <- parseDestructInfoExp + return (DestructorExp deconsInfo) + <|> do try (do string "match" + spaces1) + tgt <- parseExpression + spaces + typ <- parseExpression + spaces + clss <- braces (sepEndBy parseMatchClause spaces) + return (MatchExp tgt typ clss) + <|> do try (do string "match-all" + spaces1) + tgt <- parseExpression + spaces + typ <- parseExpression + spaces + cls <- parseMatchClause + spaces + return (MatchAllExp tgt typ cls) + <|> do try (do string "apply" + spaces1) + fn <- parseExpression + spaces + args <- parseExpression + return (ApplyExp fn args) + <|> do fn <- parseExpression + spaces + args <- sepEndBy parseExpression spaces + return (ApplyExp fn (TupleExp args))) + +parseIndexNums :: Parser [Expression] +parseIndexNums = do try (do char '_' + n <- parseExpression + ns <- parseIndexNums + return (n:ns)) + <|> do return [] + +parseInnerExp :: Parser InnerExp +parseInnerExp = do v <- parseExpression + return (ElementExp v) + <|> do char '@' + v <- parseExpression + return (SubCollectionExp v) + +parseFunPat :: Parser FunPat +parseFunPat = do char '$' + name <- word + return (FunPatVar name) + <|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces)) + case fpats of + [fpat] -> return fpat + _ -> return (FunPatTuple fpats)) + +parseBind :: Parser Bind +parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat + spaces + expr <- parseExpression + return (fpat, expr))) + spaces + return bs) + +parseRecursiveBind :: Parser RecursiveBind +parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$' + var <- word + spaces + expr <- parseExpression + return (var, expr))) + spaces + return bs) + +parseDestructInfoExp :: Parser DestructInfoExp +parseDestructInfoExp = braces (sepEndBy parseDestructClause spaces) + +parseDestructClause :: Parser (String, Expression, [(PrimePat, Expression)]) +parseDestructClause = brackets (do patCons <- word + spaces + typExpr <- parseExpression + spaces + dc2s <- braces (sepEndBy parseDestructClause2 spaces) + return (patCons, typExpr, dc2s)) + +parseDestructClause2 :: Parser (PrimePat, Expression) +parseDestructClause2 = brackets (do datPat <- parsePrimePat + spaces + expr <- parseExpression + return (datPat, expr)) + +parsePrimePat :: Parser PrimePat +parsePrimePat = do char '_' + return PrimeWildCard + <|> do c <- try charLiteral + return (PrimePatCharacter c) + <|> do d <- try float + return (PrimePatDouble d) + <|> do n <- try integer + return (PrimePatInteger n) + <|> do char '$' + name <- word + return (PrimePatVar name) + <|> angles (do c <- word + spaces + ps <- sepEndBy parsePrimePat spaces + return (InductivePrimePat c ps)) + <|> try (do char '{' + spaces + char '}' + return EmptyPat) + <|> try (do char '{' + spaces + a <- parsePrimePat + spaces + char '.' + b <- parsePrimePat + char '}' + return (ConsPat a b)) + <|> try (do char '{' + spaces + char '.' + a <- parsePrimePat + spaces + b <- parsePrimePat + char '}' + return (SnocPat a b)) + +parseMatchClause :: Parser MatchClause +parseMatchClause = brackets (do pat <- parseExpression + spaces + body <- parseExpression + return (MatchClause pat body)) + +-- +-- Show +-- +unwordsList :: Show a => [a] -> String +unwordsList = unwords . map show + +unwordsNums :: Show a => [a] -> String +unwordsNums [] = "" +unwordsNums (n:ns) = "_" ++ show n ++ unwordsNums ns + +showTopExpression :: TopExpression -> String +showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")" +showTopExpression (Test expr) = "(test " ++ show expr ++ ")" +showTopExpression (Load expr) = "(load " ++ show expr ++ ")" +showTopExpression Execute = "(execute)" + +instance Show TopExpression where show = showTopExpression + +showExpression :: Expression -> String +showExpression (CharacterExp c) = "'" ++ show c ++ "'" +showExpression (StringExp s) = "\"" ++ show s ++ "\"" +showExpression (IntegerExp n) = show n +showExpression (VariableExp name nums) = name ++ unwordsNums nums +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 (CutPatExp p) = "!" ++ show p +showExpression (AndPatExp ps) = "(& " ++ unwordsList ps ++ ")" +showExpression (OrPatExp ps) = "(| " ++ unwordsList ps ++ ")" +showExpression (PredPatExp name ps) = "(? " ++ name ++ " " ++ unwordsList ps ++ ")" +showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")" +showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")" +showExpression (LoopExp var1 var2 range body1 body2) = "(loop" ++ " " ++ show var1 ++ " " ++ show var2 ++ " " ++ show range ++ " " ++ show body1 ++ " " ++ show body2 ++ ")" +showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")" +showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")" +showExpression (DestructorExp deconsInfoExp) = "(destructor " ++ showDestructInfoExp deconsInfoExp ++ ")" +showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})" +showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")" +showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")" + +instance Show Expression where show = showExpression + +showInnerExp :: InnerExp -> String +showInnerExp (ElementExp v) = show v +showInnerExp (SubCollectionExp v) = "@" ++ show v + +instance Show InnerExp where show = showInnerExp + +showRecursiveBind :: RecursiveBind -> String +showRecursiveBind [] = "{}" +showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}" + +showRecursiveBindHelper :: (String, Expression) -> String +showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]" + +showFunPat :: FunPat -> String +showFunPat (FunPatVar name) = "$" ++ name +showFunPat (FunPatTuple []) = "[]" +showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]" + +instance Show FunPat where show = showFunPat + +showDestructInfoExp :: DestructInfoExp -> String +showDestructInfoExp dcs = "{" ++ unwords (map showDestructClause dcs) ++ "}" + +showDestructClause :: (String, Expression, [(PrimePat, Expression)]) -> String +showDestructClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDestructClause2 dc2s) ++ "})" + +showDestructClause2 :: (PrimePat, Expression) -> String +showDestructClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]" + +showPrimePat :: PrimePat -> String +showPrimePat PrimeWildCard = "_" +showPrimePat (PrimePatVar name) = "$" ++ name +showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">" +showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">" +showPrimePat EmptyPat = "{}" +showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}" +showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}" + +instance Show PrimePat where show = showPrimePat + +showMatchClause :: MatchClause -> String +showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]" + +instance Show MatchClause where show = showMatchClause + +-- +-- read and show Value +-- +readValue :: String -> IOThrowsError Value +readValue exprStr = do + expr <- readExpression exprStr + expressionToValue expr + +readExpression :: String -> IOThrowsError Expression +readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr) + +expressionToValue :: Expression -> IOThrowsError Value +expressionToValue (CharacterExp c) = return (Character c) +expressionToValue (StringExp str) = do + val <- liftIO (makeCollectionFromValueList (map Character str)) + return val +expressionToValue (IntegerExp n) = return (Integer n) +expressionToValue (DoubleExp d) = return (Double d) +expressionToValue (InductiveDataExp con exprs) = do + vals <- expressionToValueMap exprs + objRefs <- liftIO (valListToObjRefList vals) + return (InductiveData con objRefs) +expressionToValue (TupleExp exprs) = do + vals <- expressionToValueMap exprs + case vals of + [val] -> return val + _ -> do objRefs <- liftIO (valListToObjRefList vals) + return (Tuple objRefs) +expressionToValue (CollectionExp innerExps) = do + innerVals <- innerExpToInnerValueMap innerExps + return (Collection innerVals) +expressionToValue expr = throwError (WithExpression "You should give a value as an input of read." expr) + +expressionToValueMap :: [Expression] -> IOThrowsError [Value] +expressionToValueMap [] = return [] +expressionToValueMap (expr:exprs) = do + val <- expressionToValue expr + vals <- expressionToValueMap exprs + return (val:vals) + +innerExpToInnerValueMap :: [InnerExp] -> IOThrowsError [InnerValue] +innerExpToInnerValueMap [] = return [] +innerExpToInnerValueMap (ElementExp expr:rest) = do + val <- expressionToValue expr + objRef <- liftIO (newIORef (Value val)) + innerVals <- innerExpToInnerValueMap rest + return (Element objRef:innerVals) +innerExpToInnerValueMap (SubCollectionExp expr:rest) = do + val <- expressionToValue expr + objRef <- liftIO (newIORef (Value val)) + innerVals <- innerExpToInnerValueMap rest + return (SubCollection objRef:innerVals) + +showValue :: Value -> IO String +showValue (World _) = return "#" +showValue (Character c) = return (show c) +showValue (Integer n) = return (show n) +showValue (Double d) = return (show d) +showValue (InductiveData cons []) = do + return ("<" ++ cons ++ ">") +showValue (InductiveData cons objRefs) = do + vals <- objRefListToValueList objRefs + str <- unwordsVals vals + return ("<" ++ cons ++ " " ++ str ++ ">") +showValue (Tuple []) = do + return ("[]") +showValue (Tuple objRefs) = do + vals <- objRefListToValueList objRefs + str <- unwordsVals vals + return ("[" ++ str ++ "]") +showValue (Collection []) = do + return ("{}") +showValue (Collection innerVals) = do + vals <- collectionToValueList (Collection innerVals) + str <- unwordsVals vals + return ("{" ++ str ++ "}") +showValue WildCard = return "_" +showValue (PatVar name nums) = return ("$" ++ name ++ unwordsNums nums) +showValue (CutPat _) = return "#" +showValue (AndPat _) = return "#" +showValue (OrPat _) = return "#" +showValue (PredPat _ _) = return "#" +showValue (Function _ _ _) = do + return "#" +showValue (Loop _ _ _ _ _ _) = return "#" +showValue (Type _) = do + return "#" +showValue (DestructorFunction _) = do + return "#" +showValue (BuiltinFunction _) = do + return "#" + +unwordsVals :: [Value] -> IO String +unwordsVals [] = return "" +unwordsVals (val:vals) = do + s1 <- showValue val + s2 <- unwordsValsHelper vals + return (s1 ++ s2) + +unwordsValsHelper :: [Value] -> IO String +unwordsValsHelper [] = return "" +unwordsValsHelper (val:vals) = do + s1 <- showValue val + s2 <- unwordsValsHelper vals + return (" " ++ s1 ++ s2) + +showObjectRef :: ObjectRef -> IO String +showObjectRef objRef = do + obj <- readIORef objRef + case obj of +-- Closure env expr -> do envStr <- liftIO (showEnv env) +-- return ("(Closure " ++ envStr ++ " " ++ (show expr) ++ ")") + Closure _ _ -> return "#" + Value _ -> return "#" + +showEnv :: Environment -> IO String +showEnv [] = return "empty-env" +showEnv (frame:_) = do frameStr <- showFrame frame + return ("(Env " ++ frameStr ++ " : " ++ "..." ++ ")") +--showEnv (frame1:(frame2:_)) = do frameStr1 <- showFrame frame1 +-- frameStr2 <- showFrame frame2 +-- return ("(Env " ++ frameStr1 ++ " : " ++ frameStr2 ++ " : ...)") + +showFrame :: Frame -> IO String +showFrame [] = return "[]" +showFrame (((var,nums),objRef):frame) = do + objRefStr <- showObjectRef objRef + frameStr <- showFrame frame + return ("(" ++ var ++ unwordsNums nums ++"," ++ objRefStr ++"):" ++ frameStr) + +-- +-- Evaluation +-- +eval1 :: Environment -> Expression -> IOThrowsError Value +eval1 _ (CharacterExp c) = return (Character c) +eval1 _ (StringExp str) = do + val <- liftIO (makeCollectionFromValueList (map Character str)) + return val +eval1 _ (IntegerExp n) = return (Integer n) +eval1 _ (DoubleExp d) = return (Double d) +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 + _ -> return val + Nothing -> let mBuiltinFn = getBuiltin name in + case mBuiltinFn of + Just builtinFn -> return (BuiltinFunction builtinFn) + Nothing -> throwError (UnboundVariable name nums) +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) + case objRefs of + [objRef] -> do cEval1 objRef + _ -> return (Tuple objRefs) +eval1 env (CollectionExp innerExps) = do + innerVals <- liftIO (makeClosureInnerVals env innerExps) + return (Collection innerVals) +eval1 _ WildCardExp = return WildCard +eval1 env (PatVarExp name numExprs) = do + numVals <- evalList env numExprs + return (PatVar name (integerValListToIntegerList numVals)) +eval1 env (PredPatExp name exprs) = do + objRefs <- liftIO (makeClosureList env exprs) + return (PredPat name objRefs) +eval1 env (CutPatExp expr) = do + objRef <- liftIO (makeClosure env expr) + return (CutPat objRef) +eval1 env (AndPatExp exprs) = do + objRefs <- liftIO (makeClosureList env exprs) + return (AndPat objRefs) +eval1 env (OrPatExp exprs) = do + objRefs <- liftIO (makeClosureList env exprs) + return (OrPat objRefs) +eval1 env (FunctionExp args body) = return (Function env args body) +eval1 env (DoExp [] body) = eval1 env body +eval1 env (DoExp ((fpat,expr):assocs) body) = do + objRef <- liftIO (makeClosure env expr) + frame <- makeFrame fpat objRef + eval1 (frame:env) (DoExp assocs body) +eval1 env (LetExp bind body) = do + 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 + range <- eval env rangeExpr + case range of + Tuple [mObjRef,nObjRef] -> + do m <- objectRefToInteger mObjRef + n <- objectRefToInteger nObjRef + eval1Loop env (Loop var1 var2 m n expr1 expr2) + _ -> throwError (WithExpression "third arg of loop is not a range" expr) +eval1 env (TypeExp bind) = do + frame <- makeRecursiveFrame env bind + return (Type frame) +eval1 env expr@(TypeRefExp typExp name) = do + typVal <- eval1 env typExp + case typVal of + (Type frame) -> let mObjRef = getValueFromFrame frame (name,[]) in + case mObjRef of + Nothing -> throwError (WithExpression ("no method in type" ++ name) expr) + Just objRef -> do val <- cEval1 objRef + return val + _ -> throwError (WithExpression "first arg of typeref is not type" expr) +eval1 env (DestructorExp deconsInfoExp) = do + deconsInfo <- liftIO (makeDestructInfo env deconsInfoExp) + return (DestructorFunction deconsInfo) +eval1 env (MatchExp tgtExp typExp mCs) = do + typObj <- liftIO (makeClosure env typExp) + tgtObj <- liftIO (makeClosure env tgtExp) + evalMatchExp env typObj tgtObj mCs +eval1 env (MatchAllExp tgtExp typExp mC) = do + typObj <- liftIO (makeClosure env typExp) + tgtObj <- liftIO (makeClosure env tgtExp) + evalMatchAllExp env typObj tgtObj mC +eval1 env expr@(ApplyExp fnExp argsExp) = do + fnVal <- eval1 env fnExp + argsObjRef <- liftIO (makeClosure env argsExp) + case fnVal of + BuiltinFunction builtinFn -> do argsVal <- cEval argsObjRef + argsVals <- liftIO (tupleToValueList argsVal) + builtinFn argsVals + Function funEnv fpat body -> do frame <- makeFrame fpat argsObjRef + objRef <- liftIO (makeClosure (frame:funEnv) body) + cEval1 objRef + _ -> throwError (WithExpression "applying non-functional object" expr) + + +eval :: Environment -> Expression -> IOThrowsError Value +eval env expr = do + objRef <- liftIO (makeClosure env expr) + val <- cEval objRef + return val + +evalList :: Environment -> [Expression] -> IOThrowsError [Value] +evalList _ [] = return [] +evalList env (expr:exprs) = do + val <- eval env expr + vals <- evalList env exprs + return (val:vals) + +cEval1 :: ObjectRef -> IOThrowsError Value +cEval1 objRef = do + obj <- liftIO (readIORef objRef) + case obj of + Closure env expr -> + do val <- eval1 env expr + liftIO (writeIORef objRef (Value val)) + return val + Value (Tuple [objRef2]) -> + do val <- cEval1 objRef2 + liftIO (writeIORef objRef (Value val)) + return val + Value val -> return val + +cEval :: ObjectRef -> IOThrowsError Value +cEval objRef = do + val1 <- cEval1 objRef + evalValue val1 + +cEvalList :: [ObjectRef] -> IOThrowsError () +cEvalList [] = return () +cEvalList (objRef:objRefs) = do + cEval objRef + cEvalList objRefs + +evalValue :: Value -> IOThrowsError Value +evalValue (InductiveData cons objRefs) = do + cEvalList objRefs + return (InductiveData cons objRefs) +evalValue (Tuple objRefs) = do + cEvalList objRefs + return (Tuple objRefs) +evalValue (Collection innerVals) = do + evalInnerVals innerVals + return (Collection innerVals) +evalValue val = return val + +eval1Loop :: Environment -> Value -> IOThrowsError Value +eval1Loop env (Loop var1 var2 m n expr1 expr2) = do + mObjRef <- liftIO (newIORef (Value (Integer m))) + if m > n + then do eval1 (([((var2,[]),mObjRef)]):env) expr2 + else do loopObjRef <- liftIO (newIORef (Value (Loop var1 var2 (m + 1) n expr1 expr2))) + eval1 ([((var1,[]),loopObjRef),((var2,[]),mObjRef)]:env) expr1 +eval1Loop _ _ = throwError (Default "eval1Loop") + +evalInnerVals :: [InnerValue] -> IOThrowsError () +evalInnerVals [] = return () +evalInnerVals (Element objRef : rest) = do + cEval objRef + evalInnerVals rest +evalInnerVals (SubCollection objRef : rest) = do + cEval objRef + evalInnerVals rest + +evalMatchExp :: Environment -> ObjectRef -> ObjectRef -> [MatchClause] -> IOThrowsError Value +evalMatchExp env typObjRef tgtObjRef (MatchClause pat expr:rest) = do + patObjRef <- liftIO (makeClosure env pat) + matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])] + case matchs of + [] -> evalMatchExp env typObjRef tgtObjRef rest + (frame:_) -> do objRef <- liftIO (makeClosure (frame:env) expr) + cEval1 objRef +evalMatchExp _ _ _ _ = throwError (Default "end of match clause") + +evalMatchAllExp :: Environment -> ObjectRef -> ObjectRef -> MatchClause -> IOThrowsError Value +evalMatchAllExp env typObjRef tgtObjRef (MatchClause pat expr) = do + patObjRef <- liftIO (makeClosure env pat) + matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])] + innerVals <- evalMatchAllExpHelper env matchs expr + retObjRef <- liftIO (newIORef (Value (Collection innerVals))) + cEval retObjRef + +evalMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue] +evalMatchAllExpHelper _ [] _ = return [] +evalMatchAllExpHelper env (frame:frames) expr = do + objRef <- liftIO (makeClosure (frame:env) expr) + rest <- evalMatchAllExpHelper env frames expr + return (Element objRef:rest) + +-- +-- Pattern Match +-- +patternMatch :: [MState] -> IOThrowsError [Frame] +patternMatch [] = return [] +patternMatch ((MState frame []):rest) = do + frames <- patternMatch rest + return (frame:frames) +patternMatch ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef):atoms)):states) = do + patObj <- liftIO (readIORef patObjRef) + case patObj of + Value (World _) -> throwError (Default "patternMatch: not a pattern") + Value (Character _) -> throwError (Default "patternMatch: not a pattern") + Value (Integer _) -> throwError (Default "patternMatch: not a pattern") + Value (Double _) -> throwError (Default "patternMatch: not a pattern") + Value (Collection _) -> throwError (Default "patternMatch: not a pattern") + Value (Function _ _ _) -> throwError (Default "patternMatch: not a pattern") + Value (Type _) -> throwError (Default "patternMatch: not a pattern") + Value (DestructorFunction _) -> throwError (Default "patternMatch: not a pattern") + Value (BuiltinFunction _) -> throwError (Default "patternMatch: not a pattern") + Value WildCard -> patternMatch ((MState frame atoms):states) + Value (PatVar var nums) -> + do typVal <- cEval1 typObjRef + case typVal of + Type tf -> let mObjRef = getValueFromFrame tf ("var-match",[]) in + case mObjRef of + Nothing -> throwError (Default "no method in type: var-match") + Just fnObjRef -> + do ret <- cApply fnObjRef [tgtObjRef] + objRefs <- collectionToObjRefList ret + patternMatch ((map (\objRef -> (MState (((var,nums),objRef):frame) + (map (\(MAtom (PClosure bf2 pat) tgt typ) -> (MAtom (PClosure (((var,nums),objRef):bf2) pat) tgt typ)) + atoms))) + objRefs) ++ states) + _ -> throwError (Default "patternMatch: patVar not type") + 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) + Value (InductiveData con pats) -> + do typVal <- cEval1 typObjRef + case typVal of + Type tf -> let mObjRef = getValueFromFrame tf ("inductive-match",[]) in + case mObjRef of + Nothing -> throwError (Default "no method in type: var-match") + Just fnObjRef -> + do fnObj <- cEval1 fnObjRef + case fnObj of + DestructorFunction deconInfo -> + do indRet <- inductiveMatch deconInfo con tgtObjRef + case indRet of + (nTypObjRef, nTgtsObjRef) -> + 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) + _ -> throwError (Default "patternMatch: inductive-match is not destructor") + Value (PredPat predName pats) -> + do typVal <- cEval1 typObjRef + case typVal of + Type tf -> let mObjRef = getValueFromFrame tf (predName,[]) in + case mObjRef of + Nothing -> throwError (Default "no method in type: var-match") + Just fnObjRef -> + do ret <- cApply fnObjRef (pats ++ [tgtObjRef]) + case ret of + (InductiveData "true" []) -> patternMatch ((MState frame atoms):states) + (InductiveData "false" []) -> patternMatch states + _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean") + Value (AndPat pats) -> + patternMatch ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states) + Value (OrPat pats) -> + patternMatch ((map (\pat -> (MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))) + pats) ++ states) + Value (CutPat pat) -> + do retFrames <- patternMatch [(MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))] + case retFrames of + [] -> return [] + _ -> do restFrames <- patternMatch states + return (retFrames ++ restFrames) + Closure env expr -> + do patObj2 <- eval1 (bf:env) expr + patObjRef2 <- liftIO (newIORef (Value patObj2)) + patternMatch ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef):atoms)):states) + +cApply :: ObjectRef -> [ObjectRef] -> IOThrowsError Value +cApply fnObjRef argObjRefs = do + fnVal <- cEval1 fnObjRef + case fnVal of + BuiltinFunction builtinFn -> do argVals <- liftIO (objRefListToValueList argObjRefs) + retVal <- builtinFn argVals + return retVal + Function funEnv fpat body -> do objRef <- liftIO (newIORef (Value (Tuple argObjRefs))) + frame <- makeFrame fpat objRef + retObjRef <- liftIO (makeClosure (frame:funEnv) body) + retVal <- cEval1 retObjRef + return retVal + _ -> throwError (Default "cApply: not a function") + +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) + +-- +-- Inductive Match +-- +inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef,ObjectRef) +inductiveMatch [] _ _ = throwError (Default "inductiveMatch: not matched any clauses") +inductiveMatch ((con,_,[]):rest) pcon tgtObjRefRef = + if (con == pcon) + then throwError (Default "inductiveMatch: not matched any clauses") + else inductiveMatch rest pcon tgtObjRefRef +inductiveMatch ((con,typObjRef,((env,ppat,expr):cls)):rest) pcon tgtObjRefRef = + if (con == pcon) + then do mPpmRet <- primitivePatternMatch ppat tgtObjRefRef + case mPpmRet of + Nothing -> inductiveMatch ((con,typObjRef,cls):rest) pcon tgtObjRefRef + Just ppmRet -> do ret <- liftIO (makeClosure (ppmRet:env) expr) + return (typObjRef,ret) + else inductiveMatch rest pcon tgtObjRefRef + +-- +-- Primitive Pattern Match +-- +primitivePatternMatch :: PrimePat -> ObjectRef -> IOThrowsError (Maybe Frame) +primitivePatternMatch PrimeWildCard _ = return (Just []) +primitivePatternMatch (PrimePatCharacter c) objRef = do + val <- cEval1 objRef + case val of + Character c2 -> if c == c2 + then return (Just []) + else return Nothing + _ -> throwError (Default "primitive : not character to primitive character pat") +primitivePatternMatch (PrimePatInteger n) objRef = do + val <- cEval1 objRef + case val of + Integer n2 -> if n == n2 + then return (Just []) + else return Nothing + _ -> throwError (Default "primitive : not integer to primitive integer pat") +--primitivePatternMatch (PrimePatDouble d) objRef = do +-- val <- cEval1 objRef +-- case val of +-- Integer d2 -> if d == d2 +-- then return (Just (Frame [])) +-- else return Nothing +-- _ -> throwError (Default "primitive : not double to primitive double pat") +primitivePatternMatch (PrimePatVar name) objRef = return (Just [((name,[]), objRef)]) +primitivePatternMatch (InductivePrimePat pCons pPats) objRef = do + val <- cEval1 objRef + case val of + InductiveData cons objRefs -> if pCons == cons + then primitivePatternMatchList pPats objRefs + else return Nothing + _ -> do valStr <- liftIO (showValue val) + throwError (Default ("primitive : not inductive value to primitive inductive pattern : " ++ valStr)) +primitivePatternMatch EmptyPat objRef = do + val <- cEval1 objRef + b <- isEmptyCollection val + if b + then return (Just []) + else return Nothing +primitivePatternMatch (ConsPat carPat cdrPat) objRef = do + val <- cEval1 objRef + b <- isEmptyCollection val + if b + then return Nothing + else do (carObjRef, cdrObjRef) <- consDestruct val + mCarFrame <- primitivePatternMatch carPat carObjRef + case mCarFrame of + Nothing -> return Nothing + Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrObjRef + case mCdrFrame of + Nothing -> return Nothing + Just cdrFrame -> return (Just (carFrame ++ cdrFrame)) +primitivePatternMatch (SnocPat rdcPat racPat) objRef = do + val <- cEval1 objRef + b <- isEmptyCollection val + if b + then return Nothing + else do (racObjRef, rdcObjRef) <- snocDestruct val + mRacFrame <- primitivePatternMatch racPat racObjRef + case mRacFrame of + Nothing -> return Nothing + Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcObjRef + case mRdcFrame of + Just rdcFrame -> return (Just (racFrame ++ rdcFrame)) + Nothing -> return Nothing + +primitivePatternMatchList :: [PrimePat] -> [ObjectRef] -> IOThrowsError (Maybe Frame) +primitivePatternMatchList [] [] = return (Just []) +primitivePatternMatchList (pat:pats) (objRef:objRefs) = do + mFrame <- primitivePatternMatch pat objRef + case mFrame of + Nothing -> return Nothing + Just frame -> do mRestFrame <- primitivePatternMatchList pats objRefs + case mRestFrame of + Nothing -> return Nothing + Just restFrame -> return (Just (frame ++ restFrame)) +primitivePatternMatchList _ _ = throwError (Default "primitivePatternMatchList : number of patterns and targets are different") + +isEmptyCollection :: Value -> IOThrowsError Bool +isEmptyCollection (Collection []) = return True +isEmptyCollection (Collection (Element _:_)) = return False +isEmptyCollection (Collection (SubCollection subRef:rest)) = do + subVal <- cEval1 subRef + b <- isEmptyCollection subVal + if b + then isEmptyCollection (Collection rest) + else return False +isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection") + +consDestruct :: Value -> IOThrowsError (ObjectRef, ObjectRef) +consDestruct (Collection (Element eRef:rest)) = do + restRef <- liftIO (newIORef (Value (Collection rest))) + return (eRef, restRef) +consDestruct (Collection (SubCollection subRef:rest)) = do + subVal <- cEval1 subRef + b <- isEmptyCollection subVal + if b + then consDestruct (Collection rest) + else do (carRef, cdrRef) <- consDestruct subVal + cdrVal <- cEval1 cdrRef + case cdrVal of + Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest)))) + return (carRef, restRef) + _ -> undefined +consDestruct (Collection []) = throwError (Default "empty collection") +consDestruct _ = throwError (Default "consDestruct : not collection") + +snocDestruct :: Value -> IOThrowsError (ObjectRef, ObjectRef) +snocDestruct (Collection innerVals) = + case reverse innerVals of + Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest)))) + return (eRef, restRef) + SubCollection subRef:rest + -> do subVal <- cEval1 subRef + b <- isEmptyCollection subVal + if b + then snocDestruct (Collection (reverse rest)) + else do (racRef, rdcRef) <- snocDestruct subVal + rdcVal <- cEval1 rdcRef + case rdcVal of + Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs)))) + return (racRef, restRef) + _ -> undefined + _ -> undefined +snocDestruct _ = throwError (Default "snocDestruct : not collection") + +-- +-- Builtin Functions +-- +getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value) +getBuiltin name = + case name of + "read" -> Just builtinRead + "write" -> Just builtinWrite + "print" -> Just builtinPrint + "read-char" -> Just builtinReadChar + "write-char" -> Just builtinWriteChar + "int-to-float" -> Just builtinIntToFloat + "ceiling" -> Just builtinCeiling + "floor" -> Just builtinFloor + "truncate" -> Just builtinTruncate + "round" -> Just builtinRound + "=" -> Just builtinEqual + "compare-integer" -> Just builtinCompareInteger + "+" -> Just builtinPlus + "-" -> Just builtinMinus + "*" -> Just builtinMultiply + "dev" -> Just builtinDevide + "mod" -> Just builtinMod + "=f" -> Just builtinEqualFloat + "compare-float" -> Just builtinCompareFloat + "+f" -> Just builtinPlusFloat + "-f" -> Just builtinMinusFloat + "*f" -> Just builtinMultiplyFloat + "/f" -> Just builtinDevideFloat +-- "pi" -> Just builtinPi + "exp" -> Just builtinExp + "log" -> Just builtinLog + "sqrt" -> Just builtinSqrt + "**" -> Just builtinPower + "log-base" -> Just builtinLogBase + "sin" -> Just builtinSin + "cos" -> Just builtinCos + "tan" -> Just builtinTan + "asin" -> Just builtinAsin + "acos" -> Just builtinAcos + "atan" -> Just builtinAtan + "sinh" -> Just builtinSinh + "cosh" -> Just builtinCosh + "tanh" -> Just builtinTanh + "asinh" -> Just builtinAsinh + "acosh" -> Just builtinAcosh + "atanh" -> Just builtinAtanh + _ -> Nothing + +builtinRead :: [Value] -> IOThrowsError Value +builtinRead [(World actions)] = do + str <- liftIO (getExpressionHelper False 0) + val <- readValue str + ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val]) + return ret +builtinRead _ = throwError (Default "invalid args to read") + +builtinWrite :: [Value] -> IOThrowsError Value +builtinWrite [(World actions), val] = do + valStr <- liftIO (showValue val) + liftIO (flushStr valStr) + return (World ((Write val):actions)) +builtinWrite _ = throwError (Default "invalid args to write") + +builtinPrint :: [Value] -> IOThrowsError Value +builtinPrint [(World actions), val] = do + str <- charCollectionToString val + liftIO (flushStr str) + return (World ((Print str):actions)) +builtinPrint _ = throwError (Default "invalid args to print") + +builtinReadChar :: [Value] -> IOThrowsError Value +builtinReadChar [(World actions)] = do + c <- liftIO getChar + ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c]) + return ret +builtinReadChar _ = throwError (Default "invalid args to read-char") + +builtinWriteChar :: [Value] -> IOThrowsError Value +builtinWriteChar [(World actions), (Character c)] = do + liftIO (putChar c) + return (World ((Write (Character c)):actions)) +builtinWriteChar _ = throwError (Default "invalid args to write-char") + + +builtinIntToFloat :: [Value] -> IOThrowsError Value +builtinIntToFloat [Integer n] = return (Double (fromInteger n)) +builtinIntToFloat _ = throwError (Default "invalid args to int-to-float") + +builtinCeiling :: [Value] -> IOThrowsError Value +builtinCeiling [Double d] = return (Integer (ceiling d)) +builtinCeiling _ = throwError (Default "invalid args to ceiling") + +builtinFloor :: [Value] -> IOThrowsError Value +builtinFloor [Double d] = return (Integer (floor d)) +builtinFloor _ = throwError (Default "invalid args to floor") + +builtinTruncate :: [Value] -> IOThrowsError Value +builtinTruncate [Double d] = return (Integer (truncate d)) +builtinTruncate _ = throwError (Default "invalid args to truncate") + +builtinRound :: [Value] -> IOThrowsError Value +builtinRound [Double d] = return (Integer (round d)) +builtinRound _ = throwError (Default "invalid args to round") + + +builtinEqual :: [Value] -> IOThrowsError Value +builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2) + then return (InductiveData "true" []) + else return (InductiveData "false" []) +builtinEqual _ = throwError (Default "invalid args to =") + +builtinCompareInteger :: [Value] -> IOThrowsError Value +builtinCompareInteger [(Integer n1), (Integer n2)] = if (n1 == n2) + then return (InductiveData "equal" []) + else if (n1 < n2) + then return (InductiveData "less" []) + else return (InductiveData "greater" []) +builtinCompareInteger _ = throwError (Default "invalid args to compare-integer") + +builtinPlus :: [Value] -> IOThrowsError Value +builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2)) +builtinPlus _ = throwError (Default "invalid args to +") + +builtinMinus :: [Value] -> IOThrowsError Value +builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2)) +builtinMinus _ = throwError (Default "invalid args to -") + +builtinMultiply :: [Value] -> IOThrowsError Value +builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2)) +builtinMultiply _ = throwError (Default "invalid args to *") + +builtinDevide :: [Value] -> IOThrowsError Value +builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2)) +builtinDevide _ = throwError (Default "invalid args to dev") + +builtinMod :: [Value] -> IOThrowsError Value +builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2)) +builtinMod _ = throwError (Default "invalid args to mod") + + +builtinEqualFloat :: [Value] -> IOThrowsError Value +builtinEqualFloat [(Double n1), (Double n2)] = if (n1 == n2) + then return (InductiveData "true" []) + else return (InductiveData "false" []) +builtinEqualFloat _ = throwError (Default "invalid args to =f") + +builtinCompareFloat :: [Value] -> IOThrowsError Value +builtinCompareFloat [(Double n1), (Double n2)] = if (n1 == n2) + then return (InductiveData "equal" []) + else if (n1 < n2) + then return (InductiveData "less" []) + else return (InductiveData "greater" []) +builtinCompareFloat _ = throwError (Default "invalid args to compare-float") + +builtinPlusFloat :: [Value] -> IOThrowsError Value +builtinPlusFloat [(Double n1), (Double n2)] = return (Double (n1 + n2)) +builtinPlusFloat _ = throwError (Default "invalid args to +f") + +builtinMinusFloat :: [Value] -> IOThrowsError Value +builtinMinusFloat [(Double n1), (Double n2)] = return (Double (n1 - n2)) +builtinMinusFloat _ = throwError (Default "invalid args to -f") + +builtinMultiplyFloat :: [Value] -> IOThrowsError Value +builtinMultiplyFloat [(Double n1), (Double n2)] = return (Double (n1 * n2)) +builtinMultiplyFloat _ = throwError (Default "invalid args to *f") + +builtinDevideFloat :: [Value] -> IOThrowsError Value +builtinDevideFloat [(Double n1), (Double n2)] = return (Double (n1 / n2)) +builtinDevideFloat _ = throwError (Default "invalid args to /f") + + +builtinExp :: [Value] -> IOThrowsError Value +builtinExp [Double d] = return (Double (exp d)) +builtinExp _ = throwError (Default "invalid args to exp") + +builtinLog :: [Value] -> IOThrowsError Value +builtinLog [Double d] = return (Double (log d)) +builtinLog _ = throwError (Default "invalid args to log") + +builtinSqrt :: [Value] -> IOThrowsError Value +builtinSqrt [Double d] = return (Double (sqrt d)) +builtinSqrt _ = throwError (Default "invalid args to sqrt") + +builtinPower :: [Value] -> IOThrowsError Value +builtinPower [(Double n1), (Double n2)] = return (Double (n1 ** n2)) +builtinPower _ = throwError (Default "invalid args to **") + +builtinLogBase :: [Value] -> IOThrowsError Value +builtinLogBase [(Double n1), (Double n2)] = return (Double (logBase n1 n2)) +builtinLogBase _ = throwError (Default "invalid args to log-base") + +builtinSin :: [Value] -> IOThrowsError Value +builtinSin [Double d] = return (Double (sin d)) +builtinSin _ = throwError (Default "invalid args to sin") + +builtinCos :: [Value] -> IOThrowsError Value +builtinCos [Double d] = return (Double (cos d)) +builtinCos _ = throwError (Default "invalid args to cos") + +builtinTan :: [Value] -> IOThrowsError Value +builtinTan [Double d] = return (Double (tan d)) +builtinTan _ = throwError (Default "invalid args to tan") + +builtinAsin :: [Value] -> IOThrowsError Value +builtinAsin [Double d] = return (Double (asin d)) +builtinAsin _ = throwError (Default "invalid args to asin") + +builtinAcos :: [Value] -> IOThrowsError Value +builtinAcos [Double d] = return (Double (acos d)) +builtinAcos _ = throwError (Default "invalid args to acos") + +builtinAtan :: [Value] -> IOThrowsError Value +builtinAtan [Double d] = return (Double (atan d)) +builtinAtan _ = throwError (Default "invalid args to atan") + +builtinSinh :: [Value] -> IOThrowsError Value +builtinSinh [Double d] = return (Double (sinh d)) +builtinSinh _ = throwError (Default "invalid args to sinh") + +builtinCosh :: [Value] -> IOThrowsError Value +builtinCosh [Double d] = return (Double (cosh d)) +builtinCosh _ = throwError (Default "invalid args to cosh") + +builtinTanh :: [Value] -> IOThrowsError Value +builtinTanh [Double d] = return (Double (tanh d)) +builtinTanh _ = throwError (Default "invalid args to tanh") + +builtinAsinh :: [Value] -> IOThrowsError Value +builtinAsinh [Double d] = return (Double (asinh d)) +builtinAsinh _ = throwError (Default "invalid args to asinh") + +builtinAcosh :: [Value] -> IOThrowsError Value +builtinAcosh [Double d] = return (Double (acosh d)) +builtinAcosh _ = throwError (Default "invalid args to acosh") + +builtinAtanh :: [Value] -> IOThrowsError Value +builtinAtanh [Double d] = return (Double (atanh d)) +builtinAtanh _ = throwError (Default "invalid args to atanh") + +-- +-- For debug +-- +debug :: String -> ObjectRef -> IOThrowsError () +debug tag objRef = do + val <- cEval objRef + valStr <- liftIO $ showValue val + liftIO $ putStr $ tag ++ ": " + liftIO $ putStrLn valStr + +debug2 :: String -> ObjectRef -> IOThrowsError () +debug2 tag objRef = do + objStr <- liftIO $ showObjectRef objRef + liftIO $ putStr $ tag ++ ": " + liftIO $ putStrLn objStr + 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: 0.4.0.0 +Version: 1.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison @@ -45,7 +45,7 @@ Data-Dir: etc/ -Data-files: lib/base.egi lib/number.egi lib/collection.egi lib/poker-hands.egi sample/number-test.egi sample/collection-test.egi sample/io-test.egi elisp/egison-mode.el +Data-files: lib/base.egi lib/number.egi lib/collection.egi lib/graph.egi lib/poker-hands.egi sample/number-test.egi sample/collection-test.egi sample/graph-test.egi sample/io-test.egi sample/poker-hands-test.egi elisp/egison-mode.el -- Extra files to be distributed with the package, such as examples or -- a README. 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 @@ -12,18 +12,18 @@ "\\" "\\" "\\" - "\\" + "\\" + "\\" "\\" "\\" - "\\" "\\\." "\\\," "\\\!" + "|" + "\\\&" "@" "\\<_\\>" - "\\" - "\\" )) "Subdued expressions to highlight in Egison modes.") diff --git a/etc/lib/base.egi b/etc/lib/base.egi --- a/etc/lib/base.egi +++ b/etc/lib/base.egi @@ -4,7 +4,7 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[true [] {[ {[]}] [_ {}]}] @@ -40,7 +40,7 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[less [] {[ {[]}] [_ {}]}] diff --git a/etc/lib/collection.egi b/etc/lib/collection.egi --- a/etc/lib/collection.egi +++ b/etc/lib/collection.egi @@ -3,7 +3,7 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[nil [] {[{} {[]}] [_ {}]}] @@ -14,25 +14,25 @@ {[{.$xs $x} {[x xs]}] [_ {}]}] [join [(List a) (List a)] - {[$tgt (let {[$loop - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] [{x @as} bs]) - (loop xs))}]}))]} - (loop tgt))]}] + {[$tgt (let {[$loop-fn + (lambda [$ts] + (match ts (List a) + {[ {[{} {}]}] + [ + {[{} ts] + @(map (lambda [$as $bs] [{x @as} bs]) + (loop-fn xs))}]}))]} + (loop-fn tgt))]}] [nioj [(List a) (List a)] - {[$tgt (let {[$loop - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] [{@as x} bs]) - (loop xs))}]}))]} - (loop tgt))]}]})] + {[$tgt (let {[$loop-fn + (lambda [$ts] + (match ts (List a) + {[ {[{} {}]}] + [ + {[{} ts] + @(map (lambda [$as $bs] [{@as x} bs]) + (loop-fn xs))}]}))]} + (loop-fn tgt))]}]})] [$equal? (lambda [$val $tgt] (match [val tgt] [(List a) (List a)] {[[ ] ] @@ -91,6 +91,12 @@ {@subs @(map (lambda [$sub] {x @sub}) subs)})]}))) +(define $size + (lambda [$xs] + (match xs (List Something) + {[ 0] + [ (+ 1 (size rs))]}))) + (define $car (lambda [$xs] (match xs (List Something) @@ -114,15 +120,15 @@ (define $unique (lambda [$a] (lambda [$xs] - (let {[$loop (lambda [$xs $ys] - (match xs (List a) - {[ ys] - [ - (match ((member? a) x ys) Bool - {[ (loop rs ys)] - [ (loop rs {@ys x})] - [_ {}]})]}))]} - (loop xs {}))))) + (let {[$loop-fn (lambda [$xs $ys] + (match xs (List a) + {[ ys] + [ + (match ((member? a) x ys) Bool + {[ (loop-fn rs ys)] + [ (loop-fn rs {@ys x})] + [_ {}]})]}))]} + (loop-fn xs {}))))) (define $subcollection? (lambda [$a] @@ -145,13 +151,13 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[nil [] {[{} {[]}] [_ {}]}] [cons [a (Multiset a)] {[$tgt (map (lambda [$t] [t ((remove a) tgt t)]) - tgt)]}] + ((unique a) tgt))]}] [join [(Multiset a) (Multiset a)] {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)]) (subcollections tgt))]}]})] @@ -166,7 +172,7 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[nil [] {[{} {[]}] [_ {}]}] diff --git a/etc/lib/graph.egi b/etc/lib/graph.egi new file mode 100644 --- /dev/null +++ b/etc/lib/graph.egi @@ -0,0 +1,41 @@ +(define $Node Integer) + +(define $NodeInfo + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (destructor + {[node [Node (Multiset Node) (Multiset Node)] + {[ {[n in out]}]}]})] + [$equal? (lambda [$val $tgt] + (match [val tgt] [NodeInfo NodeInfo] + {[[ ] ] + [[_ _] ]}))]})) + +(define $Graph (Multiset NodeInfo)) + + +(define $hamilton-cycle + (lambda [$g] + (let {[$n (size g)]} + (match-all g Graph + [ _> + (loop $l $i [3 n] + _> + l> + _> + _>)> + (loop $l $i [1 n] {a_i @l} {})])))) + +(define $hamilton-path + (lambda [$g] + (let {[$n (size g)]} + (match-all g Graph + [ _> + (loop $l $i [3 n] + _> + l> + + >)> + (loop $l $i [1 n] {a_i @l} {})])))) + diff --git a/etc/lib/number.egi b/etc/lib/number.egi --- a/etc/lib/number.egi +++ b/etc/lib/number.egi @@ -12,12 +12,12 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[o [] {[0 {[]}] [_ {}]}] [s [Nat] - {[$tgt (match (compare-number tgt 0) Order + {[$tgt (match (compare-integer tgt 0) Order {[ {(- tgt 1)}] [_ {}]})]}]})] [$equal? (lambda [$val $tgt] (= val tgt))]})) diff --git a/etc/lib/poker-hands.egi b/etc/lib/poker-hands.egi --- a/etc/lib/poker-hands.egi +++ b/etc/lib/poker-hands.egi @@ -2,7 +2,7 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[spade [] {[ {[]}] [_ {}]}] @@ -34,7 +34,7 @@ (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[card [Suit (Mod 13)] {[ {[s n]}]}]})] [$equal? (lambda [$val $tgt] @@ -62,9 +62,9 @@ [ - ! - ! - !>>>>> + + ! + !>>>>> ] [ ! diff --git a/etc/sample/collection-test.egi b/etc/sample/collection-test.egi --- a/etc/sample/collection-test.egi +++ b/etc/sample/collection-test.egi @@ -1,3 +1,8 @@ +(load "./etc/lib/base.egi") +(load "./etc/lib/number.egi") +(load "./etc/lib/collection.egi") +(load "./etc/lib/poker-hands.egi") + (test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer)) [ @@ -15,43 +20,23 @@ (test (match-all {1 2 3 4 5} (Multiset Integer) [> [m n]])) -(test (match (with $loop {1 @loop}) (List Integer) - {[> [m n]] - [_ ]})) - (test (let {[$pat >]} (match {1} (Multiset Integer) {[pat ] [_ ]}))) (test (match {1} (Multiset Integer) - {[(of { >}) ] - [_ ]})) - -(test (let {[$loop loop})>]} - (match {1 1 1 1} (Multiset Integer) - {[loop ] - [_ ]}))) - -(test (match {1 1 1 1} (Multiset Integer) - {[(with $loop loop})>) ] - [_ ]})) - -(test (match {1 1 1 1} (Multiset Integer) - {[ loop})>)> ] + {[(| >) ] [_ ]})) -(test (match {0 1 0 1} (List Integer) - {[(of { }))> - }))>}) - ] - [_ ]})) - (test (match-all { } (List Something) [ [xs ys]])) (test (match-all {1 2 3} (List Integer) [ [hs ts]])) +(test (match-all {1 2 3} (List Integer) + [ [hs ts]])) + (test (match-all {1 2 3} (Multiset Integer) [ [hs ts]])) @@ -61,12 +46,6 @@ (test (match-all {1 2 3} (List Integer) [> [hs x ts]])) -(test (match-all {1 2 3} (Multiset Integer) - [> [hs x ts]])) - -(test (match-all {1 2 3} (Set Integer) - [> [hs x ts]])) - (test ((remove-collection Suit) { } { })) (test (subcollections { })) @@ -99,12 +78,26 @@ {[>>>>> + >>>>> ] [_ ]})) +(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer) + [>>> + [x y z]])) + +(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer) + [>>> + [x y z]])) + (test (match {5 2 1 3 4} (Multiset Integer) {[] [_ ]})) -(test (match-all {1 2 3 4 5} (Multiset Integer) - [ [n rest]])) - (test (let {[$f (lambda [$x] (+ (g x) 10))] [$g (lambda [$x] (+ x 1))]} (f 0))) + (define $Stick (lambda [$a] (type {[$var-match (lambda [$tgt] {tgt})] [$inductive-match - (deconstructor + (destructor {[nil [] {[$tgt (match-all tgt (List a) [ []])]}] [cons [a (List a)] @@ -145,21 +136,66 @@ (test (match-all {1 2 3 4} (Stick Integer) [> [xs w ys]])) (test (match-all {1 2 3} (Stick Integer) [,{3 2 1} ])) -(test (match {2 7 7 2 7} (Multiset Integer) - {[>> - (match tmp1 (Multiset Integer) - {[ - (match tmp2 (Multiset Integer) - {[ - (match tmp3 (Multiset Integer) - {[ ]})]})]})] - [_ ]})) - (test (match-all {1 2 3 4 5} (List Integer) [>>> [m n]])) (test (match-all {1 2 3 4} (List Integer) [> ns])) + +(define $combination + (lambda [$xs $k] + (match k Nat + {[ {{}}] + [ + (concat (match-all xs (List Something) + [> + (map (lambda [$ys] + {x @ys}) + (combination rs k1))]))]}))) + +(test (combination {1 2 3 4 5} 3)) + +> ... >> + +(... [$n Integer (squence 1 k (lambda [$i] (+ i 1)))] + > _) + +(define $loop-pat + (lambda [$k $i] + (match i Integer + {[,k >] + [_ >]}))) + +(define $loop-pat + (lambda [$k] + (| ))) + +(define $isStraight? + (lambda [$Ns] + (match Ns (Multiset Integer) + {[ + ] + [_ ]}))) + +(define $isStraight? + (lambda [$Ns] + (match Ns (Multiset Integer) + {[ + ] + [_ ]}))) + +(test (isStraight? {1 2})) + + +(define andAnd + (lambda ($c) + (match c Circuit + {[ + > + $rr>> + + + rr>>] + [_ c]}))) diff --git a/etc/sample/graph-test.egi b/etc/sample/graph-test.egi new file mode 100644 --- /dev/null +++ b/etc/sample/graph-test.egi @@ -0,0 +1,42 @@ + (define $g { + + + + }) + +(define $g2 { + + + + }) + + +(test (match-all g Graph + [ _> + _> + _> + _>>> + [n1 n2 n3]])) + +(test (match-all g Graph + [ _> + _> + _> + _> + _> + _>>>>> + [n1 n2 n3 n4 n5]])) + +(test (match-all g2 Graph + [ _> + _> + _> + _> + + >>>>> + [n1 n2 n3 n4 n5]])) + + +(test (hamilton-cycle g2)) + +(test (hamilton-path g2)) diff --git a/etc/sample/number-test.egi b/etc/sample/number-test.egi --- a/etc/sample/number-test.egi +++ b/etc/sample/number-test.egi @@ -1,3 +1,7 @@ +(load "./etc/lib/base.egi") +(load "./etc/lib/number.egi") +(load "./etc/lib/collection.egi") + (define $fib (lambda [$n] (match n Nat @@ -20,8 +24,8 @@ (match ns (List Integer) {[> n] [ - (let {[$r (min Rs)]} - (match (compare-number n r) Order + (let {[$r (min rs)]} + (match (compare-integer n r) Order {[ n] [_ r]}))]}))) @@ -32,5 +36,7 @@ {[> n] [ - (gcd {n @(map (lambda [$r] (mod r n)) - rs)})]})))) + (gcd {(min ns2) @(map (lambda [$r] (mod r (min ns2))) + rs)})]})))) + +(test (gcd {10 20 40 35})) diff --git a/etc/sample/poker-hands-test.egi b/etc/sample/poker-hands-test.egi new file mode 100644 --- /dev/null +++ b/etc/sample/poker-hands-test.egi @@ -0,0 +1,23 @@ +(test (poker-hands { 4> + 2> + 5> + 1> + 3>})) + +(test (poker-hands { 1> + 2> + 1> + 1> + 2>})) + +(test (poker-hands { 4> + 2> + 5> + 1> + 3>})) + +(test (poker-hands { 4> + 10> + 5> + 1> + 3>}))