module Main where import System.Environment import Control.Monad.Error import Data.IORef import Text.ParserCombinators.Parsec hiding (spaces) import qualified Text.Parsec.Token as P import Text.Parsec.Language (haskellDef) import IO hiding (try) main :: IO () main = do args <- getArgs case length args of 0 -> do flushStr "Egison, version 0.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" 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 "\nLeaving Egison.\nByebye. See you again! (^^)/\n" Input str -> runIOThrows ((liftThrows (readTopExpression str)) >>= executeTopExpression defs) >>= putStrLn >> runRepl defs -- Input str -> runIOThrows (liftThrows (liftM show (readTopExpression str))) >>= putStrLn >> runRepl defs executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String executeTopExpression defs (Define name expr) = do liftIO (modifyIORef defs (\ls -> ((name, expr) : ls))) return name executeTopExpression defs (Test expr) = do topFrame <- makeTopFrame defs val <- eval (Environment [topFrame]) expr liftIO (showValue val) executeTopExpression defs Execute = do topFrame <- makeTopFrame defs val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp [])) liftIO (showValue val) 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 0) return (Input str)) (\_ -> return Eof) getExpressionHelper :: Integer -> IO String getExpressionHelper n = do c <- getChar case c of '(' -> do l <- getExpressionHelper (n + 1) return (c : l) '<' -> do l <- getExpressionHelper (n + 1) return (c : l) '[' -> do l <- getExpressionHelper (n + 1) return (c : l) '{' -> do l <- getExpressionHelper (n + 1) return (c : l) ')' -> do l <- getExpressionHelper (n - 1) return (c : l) '>' -> do l <- getExpressionHelper (n - 1) return (c : l) ']' -> do l <- getExpressionHelper (n - 1) return (c : l) '}' -> do l <- getExpressionHelper (n - 1) return (c : l) '\n' -> if n > 0 then do l <- getExpressionHelper n return (c : l) else return "\n" _ -> do l <- getExpressionHelper n return (c : l) type IOThrowsError = ErrorT EgiError IO data EgiError = Parser ParseError | NotFunction String | UnboundVariable String String | Default String showError :: EgiError -> String showError (Parser parseErr) = "Parse error at " ++ show parseErr showError (NotFunction str) = "Error : " ++ str showError (UnboundVariable str name) = "Error : " ++ str ++ name showError (Default str) = "Error : " ++ str instance Show EgiError where show = showError instance Error EgiError where noMsg = Default "An error has occured" strMsg = Default 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 readTopExpression :: String -> ThrowsError TopExpression readTopExpression = readOrThrow parseTopExpression readTopExpressionList :: String -> ThrowsError [TopExpression] readTopExpressionList = readOrThrow (endBy parseTopExpression spaces) readOrThrow :: Parser a -> String -> ThrowsError a readOrThrow parser input = case parse parser "egison" input of Left err -> throwError (Parser err) Right val -> return val type ThrowsError = Either EgiError trapError :: (MonadError e m, Show e) => m String -> m String trapError action = catchError action (return . show) extractValue :: ThrowsError a -> a extractValue (Right val) = val -- -- Data Types -- data TopExpression = Define String Expression | Test Expression | Execute data Expression = CharacterExp Char | StringExp String | NumberExp Integer | DoubleExp Double | SymbolExp String | InductiveDataExp String [Expression] | TupleExp [Expression] | CollectionExp [InnerExp] | PatternExp PatternExp | FunctionExp FunPat Expression | LetExp Bind Expression | TypeExp Bind | TypeRefExp Expression String | DeconstructorExp DeconsInfoExp | MatchExp Expression Expression [MatchClause] | MatchMapExp Expression Expression MatchClause | ApplyExp Expression Expression data InnerExp = ElementExp Expression | SubCollectionExp Expression data PatternExp = WildCardExp | PatVarExp String | CutPatExp Expression | AsPatExp String Expression | OfPatExp Expression | OnPatExp [String] Expression | ValPatExp Expression data FunPat = FunPatVar String | FunPatTuple [FunPat] type Bind = [(String, Expression)] type DeconsInfoExp = [(String, Expression, [(PrimePat, Expression)])] data MatchClause = MatchClause Expression Expression data PrimePat = PrimeWildCard | PrimePatVar String | InductivePrimePat String [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 data Value = World | Character Char | Number 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) data InnerValue = Element (IORef IntermidiateValue) | SubCollection (IORef IntermidiateValue) data Pattern = WildCard | PatVar String | CutPat (IORef IntermidiateValue) | AsPat String (IORef IntermidiateValue) | OfPat [IORef IntermidiateValue] | OnPat [String] Environment Expression | ValPat (IORef IntermidiateValue) 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 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") parseTopExpression :: Parser TopExpression parseTopExpression = try (do char '(' spaces string "define" spaces char '$' name <- word spaces expr <- parseExpression spaces char ')' return (Define name expr)) <|> try (do char '(' spaces string "test" spaces expr <- parseExpression spaces char ')' return (Test expr)) <|> try (do char '(' spaces string "execute" spaces char ')' return Execute) parseExpression :: Parser Expression parseExpression = do ws <- word return (SymbolExp ws) <|> do c <- charLiteral return (CharacterExp c) <|> do str <- stringLiteral return (StringExp str) <|> do n <- integer return (NumberExp n) -- <|> try (do d <- float -- return (DoubleExp d)) <|> do char '<' spaces c <- word spaces vs <- sepEndBy parseExpression spaces char '>' return (InductiveDataExp c vs) <|> do char '[' spaces vs <- sepEndBy parseExpression spaces char ']' return (TupleExp vs) <|> do char '{' spaces vs <- sepEndBy parseInnerExp spaces char '}' return (CollectionExp vs) <|> try (do pat <- parsePatternExp return (PatternExp pat)) <|> try (do char '(' spaces string "lambda" spaces args <- parseFunPat spaces body <- parseExpression spaces char ')' return (FunctionExp args body)) <|> try (do char '(' spaces string "let" spaces bind <- parseBind spaces body <- parseExpression spaces char ')' return (LetExp bind body)) <|> try (do char '(' spaces string "type" spaces bind <- parseBind spaces char ')' return (TypeExp bind)) <|> try (do char '(' spaces string "type-ref" spaces typ <- parseExpression spaces name <- word spaces char ')' return (TypeRefExp typ name)) <|> try (do char '(' spaces string "deconstructor" spaces deconsInfo <- parseDeconsInfoExp spaces char ')' return (DeconstructorExp deconsInfo)) <|> try (do char '(' spaces string "match" spaces tgt <- parseExpression spaces typ <- parseExpression spaces char '{' spaces clss <- sepEndBy parseMatchClause spaces char '}' spaces char ')' return (MatchExp tgt typ clss)) <|> try (do char '(' spaces string "match-map" spaces tgt <- parseExpression spaces typ <- parseExpression spaces cls <- parseMatchClause spaces char ')' return (MatchMapExp tgt typ cls)) <|> try (do char '(' spaces string "apply" spaces fn <- parseExpression spaces args <- parseExpression spaces char ')' return (ApplyExp fn args)) <|> do char '(' spaces fn <- parseExpression spaces args <- sepEndBy parseExpression spaces char ')' 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) <|> try (do char '[' spaces fpat <- parseFunPat spaces char ']' return fpat) <|> try (do char '[' spaces fpats <- sepEndBy parseFunPat spaces char ']' return (FunPatTuple fpats)) parseBind :: Parser Bind parseBind = do char '{' spaces bs <- sepEndBy (do char '[' spaces char '$' var <- word spaces expr <- parseExpression spaces char ']' return (var, expr)) spaces char '}' return bs parseDeconsInfoExp :: Parser DeconsInfoExp parseDeconsInfoExp = do char '{' spaces deconsInfoExp <- sepEndBy parseDeconsClause spaces spaces char '}' return deconsInfoExp parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)]) parseDeconsClause = do char '[' spaces patCons <- word spaces typExpr <- parseExpression spaces char '{' spaces dc2s <- sepEndBy parseDeconsClause2 spaces char '}' spaces char ']' return (patCons, typExpr, dc2s) parseDeconsClause2 :: Parser (PrimePat, Expression) parseDeconsClause2 = do char '[' spaces datPat <- parsePrimePat spaces expr <- parseExpression spaces char ']' return (datPat, expr) parsePrimePat :: Parser PrimePat parsePrimePat = do char '_' return PrimeWildCard <|> do char '$' name <- word return (PrimePatVar name) <|> do char '<' spaces c <- word spaces ps <- sepEndBy parsePrimePat spaces char '>' return (InductivePrimePat c ps) <|> try (do char '{' spaces char '}' return EmptyPat) <|> try (do char '{' spaces a <- parsePrimePat spaces char '.' b <- parsePrimePat spaces char '}' return (ConsPat a b)) <|> try (do char '{' spaces char '.' a <- parsePrimePat spaces b <- parsePrimePat spaces char '}' return (SnocPat a b)) parseMatchClause :: Parser MatchClause parseMatchClause = do char '[' spaces pat <- parseExpression spaces body <- parseExpression spaces char ']' 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) <|> try (do char '(' spaces string "as" spaces char '$' name <- word spaces expr <- parseExpression spaces char ')' return (AsPatExp name expr)) <|> try (do char '(' spaces string "of" spaces expr <- parseExpression spaces char '}' return (OfPatExp expr)) <|> try (do char '(' spaces string "on" spaces var <- (char '$' >> word) spaces expr <- parseExpression spaces char ')' return (OnPatExp [var] expr)) <|> try (do char '(' spaces string "on" spaces char '[' spaces vars <- sepEndBy (char '$' >> word) spaces char ']' spaces expr <- parseExpression spaces char ')' return (OnPatExp vars 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 -> IOThrowsError (IORef IntermidiateValue) getValue (Environment []) name = throwError (UnboundVariable "Unbound Variable : " name) getValue (Environment (frame : env)) name = let mValRef = getValueFromFrame frame name in case mValRef of Nothing -> getValue (Environment env) name Just iValRef -> return 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 -> Bind -> 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) -- -- -- showValue :: Value -> IO String showValue (Character c) = return (show c) showValue (Number n) = return (show n) showValue (Double d) = return (show d) showValue (InductiveData cons []) = do return ("<" ++ cons ++ ">") showValue (InductiveData cons iValRefs) = do vals <- iValListToValueList iValRefs str <- unwordsVals vals return ("<" ++ cons ++ " " ++ str ++ ">") showValue (Tuple []) = do return ("[]") showValue (Tuple iValRefs) = do vals <- iValListToValueList 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 (BuiltinFunction _) = do return "#" showPattern :: Pattern -> IO String showPattern WildCard = return "_" showPattern (PatVar name) = return ("$" ++ name) showPattern _ = undefined 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 _ (NumberExp n) = return (Number n) eval1 _ (DoubleExp d) = return (Double d) eval1 env (SymbolExp name) = do let mBuiltinFn = getBuiltin name in case mBuiltinFn of Just builtinFn -> return (BuiltinFunction builtinFn) Nothing -> do iValRef <- getValue env name val <- force iValRef return val 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 (Environment frames) (LetExp bind body) = do frame <- makeRecursiveFrame (Environment frames) bind iValRef <- liftIO (newIORef (Closure (Environment (frame:frames)) body)) force iValRef eval1 env (TypeExp bind) = do frame <- makeRecursiveFrame env bind return (Type frame) eval1 env (TypeRefExp typExp name) = do typVal <- eval1 env typExp case typVal of (Type frame) -> let mIValRef = getValueFromFrame frame name in case mIValRef of Nothing -> throwError (Default ("no method in type : " ++ name)) Just iValRef -> do val <- force iValRef return val _ -> throwError (Default "first arg of typeref is not type") 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 (MatchMapExp tgtExp typExp mC) = do typIVal <- liftIO (makeClosure env typExp) tgtIVal <- liftIO (makeClosure env tgtExp) forceMatchMapExp env typIVal tgtIVal mC eval1 env (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 (Environment funEnv) fpat body -> do frame <- makeFrame fpat argsIValRef iValRef <- liftIO (makeClosure (Environment (frame:funEnv)) body) force iValRef DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo) _ -> throwError (NotFunction "Applying non-functional object.") 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 <- tupleToList iValRef return (Pattern (OfPat iValRefs)) evalPattern1 env (OnPatExp vars expr) = do return (Pattern (OnPat vars env expr)) evalPattern1 env (ValPatExp expr) = do iValRef <- liftIO (makeClosure env expr) return (Pattern (ValPat iValRef)) 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 (OnPat vars env expr) = return (OnPat vars env expr) forceRecursivelyPattern (ValPat iValRef) = do forceRecursively iValRef return (ValPat iValRef) --- --- --- 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") forceMatchMapExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value forceMatchMapExp 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 <- forceMatchMapExpHelper env matchs expr return (Collection innerVals) forceMatchMapExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue] forceMatchMapExpHelper _ [] _ = return [] forceMatchMapExpHelper env (frame:frames) expr = do iValRef <- liftIO (makeClosure (addFrame frame env) expr) force iValRef rest <- forceMatchMapExpHelper 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") 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 (frame:frames) typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef = do onFrame <- extractAssocs frame vars patIValRef <- liftIO (makeClosure (addFrame onFrame onEnv) expr) patVal <- force patIValRef newFrames1 <- patternMatch [frame] typVal patVal tgtIValRef newFrames2 <- patternMatch frames typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef return (newFrames1 ++ newFrames2) patternMatch frames (Type bind) (Pattern (ValPat iValPatRef)) tgtIValRef = do case getValueFromFrame bind "=" of Nothing -> throwError (Default "no = function") Just valMatchFnRef -> do valMatchFn <- force valMatchFnRef case valMatchFn of Function funEnv fpat body -> do argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef]))) argsFrame <- makeFrame fpat argsIValRef iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body) val <- force iValRef case val of (InductiveData "true" []) -> return frames (InductiveData "false" []) -> return [] _ -> throwError (Default "invalid return value from = function") _ -> throwError (Default "= is not function") patternMatch _ _ _ _ = throwError (Default "invalid pattern") 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") 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) connectFrames :: [Frame] -> [Frame] -> [Frame] connectFrames [] _ = [] connectFrames (frame:frames) newFrames = (map (\newFrame -> (appendFrames frame newFrame)) newFrames) ++ (connectFrames frames newFrames) extractAssocs :: Frame -> [String] -> IOThrowsError Frame extractAssocs _ [] = return (Frame []) extractAssocs frame (var:vars) = let mValRef = getValueFromFrame frame var in case mValRef of Nothing -> throwError (Default "extractAssocs") Just iValRef -> do newFrame <- extractAssocs frame vars case newFrame of Frame assocs -> return (Frame ((var, iValRef):assocs)) --- --- --- primitivePatternMatch :: PrimePat -> IORef IntermidiateValue -> IOThrowsError (Maybe Frame) primitivePatternMatch PrimeWildCard _ = return (Just (Frame [])) 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 primitivePatternMatchMap pPats iValRefs else return Nothing _ -> throwError (Default "primitive : not inductive value to primitive inductive 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 primitivePatternMatchMap :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame) primitivePatternMatchMap [] [] = return (Just (Frame [])) primitivePatternMatchMap (pat:pats) (iValRef:iValRefs) = do mFrame <- primitivePatternMatch pat iValRef case mFrame of Nothing -> return Nothing Just frame -> do mRestFrame <- primitivePatternMatchMap pats iValRefs case mRestFrame of Nothing -> return Nothing Just restFrame -> return (Just (appendFrames frame restFrame)) primitivePatternMatchMap _ _ = throwError (Default "primitivePatternMatchMap : 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") --- --- --- iValListToValueList :: [IORef IntermidiateValue] -> IO [Value] iValListToValueList [] = return [] iValListToValueList (iValRef:iValRefs) = do iVal <- readIORef iValRef case iVal of Value val -> do vals <- iValListToValueList 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] 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) 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 "+" -> Just builtinPlus "-" -> Just builtinMinus "*" -> Just builtinMultiply _ -> Nothing builtinPlus :: [Value] -> IOThrowsError Value builtinPlus [(Number n1), (Number n2)] = return (Number (n1 + n2)) builtinPlus _ = throwError (Default "invalid args to +") builtinMinus :: [Value] -> IOThrowsError Value builtinMinus [(Number n1), (Number n2)] = return (Number (n1 - n2)) builtinMinus _ = throwError (Default "invalid args to -") builtinMultiply :: [Value] -> IOThrowsError Value builtinMultiply [(Number n1), (Number n2)] = return (Number (n1 * n2)) builtinMultiply _ = throwError (Default "invalid args to *") --- --- for Debug : show Expression --- showTopExpression :: TopExpression -> String showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")" showTopExpression (Test expr) = "(test " ++ show expr ++ ")" showTopExpression Execute = "(execute)" instance Show TopExpression where show = showTopExpression showExpression :: Expression -> String showExpression (CharacterExp c) = show c showExpression (NumberExp 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 (LetExp bind expr) = "(let " ++ showBind bind ++ " " ++ show expr ++ ")" showExpression (TypeExp bind) = "(type " ++ showBind 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 (MatchMapExp tgt typ cls) = "(match-map " ++ 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 (OnPatExp vars pat) = "(on [" ++ unwords (map (\var -> "$" ++ var) vars) ++ "] " ++ show pat ++ ")" showPatternExp (ValPatExp expr) = "," ++ show expr instance Show PatternExp where show = showPatternExp showBind :: Bind -> String showBind [] = "{}" showBind bind = "{" ++ unwords (map showBindHelper bind) ++ "}" showBindHelper :: (String, Expression) -> String showBindHelper (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 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 ++ "]"