module Main where import System.Environment import Control.Monad.Error import Data.IORef --import qualified Data.HashMap as Hash import Text.Parsec hiding (spaces) import Text.Parsec.String (Parser) import qualified Text.Parsec.Token as P import Text.Parsec.Language (haskellDef) import IO hiding (try) import Paths_egison welcomeMsg :: String welcomeMsg = "Egison, version 1.0.6 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" byebyeMsg :: String byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n" 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 defsRef (Define name expr) = do liftIO (modifyIORef defsRef (\ls -> ((name, expr) : ls))) return (name ++ "\n") executeTopExpression defs (Test expr) = do topFrame <- makeTopFrame defs val <- eval [topFrame] expr ret <- showValue val return (ret ++ "\n") executeTopExpression defs (Load libname) = do filename <- liftIO (getDataFileName libname) mStr <- liftIO (readEgisonFile filename) case mStr of Nothing -> throwError (Default "load error") Just str -> do 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 (LoadFile filename) = do mStr <- liftIO (readEgisonFile filename) case mStr of Nothing -> throwError (Default "load-file error") Just str -> do 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") readEgisonFile :: String -> IO (Maybe String) readEgisonFile filename = catch (do str <- (readFile filename) return (Just str)) (\_ -> return Nothing) runRepl :: Definitions -> IO () runRepl defsRef = do input <- (readPrompt "> ") case input of Eof -> flushStr byebyeMsg Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defsRef) >>= flushStr >> runRepl defsRef -- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs loadBasicLibrary :: Definitions -> Definitions loadBasicLibrary defsRef = undefined main :: IO () main = do args <- getArgs case length args of 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 | LoadFile String | Execute data Expression = CharacterExp Char | StringExp String | IntegerExp Integer | DoubleExp Double | VariableExp String [Expression] | SymbolExp String [Expression] | OmitExp Expression | InductiveDataExp String [Expression] | TupleExp [InnerExp] | CollectionExp [InnerExp] | WildCardExp | PatVarExp String [Expression] | CutPatExp Expression | AndPatExp [Expression] | OrPatExp [Expression] | PredPatExp String [Expression] | FunctionExp FunPat Expression | MacroExp 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] | Symbol String [ObjectRef] | WildCard | PatVar String [Integer] | PredPat String [ObjectRef] | CutPat ObjectRef | AndPat [ObjectRef] | OrPat [ObjectRef] | Function Environment FunPat Expression | Expression 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 <- cEvalList objRefs1 vals2 <- cEvalList objRefs2 isEqualValueList vals1 vals2 else return False isEqualValue (Tuple objRefs1) (Tuple objRefs2) = do vals1 <- cEvalList objRefs1 vals2 <- cEvalList objRefs2 isEqualValueList vals1 vals2 isEqualValue (Collection innerVals1) (Collection innerVals2) = do vals1 <- innerValueListToValueList innerVals1 vals2 <- innerValueListToValueList innerVals2 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 -> do 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) objRefListToInnerVals :: [ObjectRef] -> IO [InnerValue] objRefListToInnerVals [] = return [] objRefListToInnerVals (objRef:objRefs) = do innerVals <- objRefListToInnerVals objRefs return ((Element objRef):innerVals) innerValueListToObjRefList :: [InnerValue] -> IOThrowsError [ObjectRef] innerValueListToObjRefList [] = return [] innerValueListToObjRefList (Element eRef:rest) = do restRefs <- innerValueListToObjRefList rest return (eRef:restRefs) innerValueListToObjRefList (SubCollection subRef:rest) = do subVal <- cEval1 subRef case subVal of Collection inners -> innerValueListToObjRefList (inners ++ rest) innerValueListToValueList :: [InnerValue] -> IOThrowsError [Value] innerValueListToValueList innerVals = do objRefs <- innerValueListToObjRefList innerVals cEvalList objRefs tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef] tupleToObjRefList objRef = do val <- cEval1 objRef case val of Tuple objRefs -> return objRefs val -> return [objRef] tupleToValueList :: Value -> IOThrowsError [Value] tupleToValueList (Tuple []) = return [] tupleToValueList (Tuple objRefs) = cEvalList objRefs 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 innerVals) = innerValueListToObjRefList innerVals collectionToObjRefList _ = throwError (Default "collectionObjToObjRefList : not a collection") 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-file") spaces filename <- stringLiteral spaces return (LoadFile filename) <|> 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 try (do char '#' ws <- word nums <- parseIndexNums return (SymbolExp ws nums)) <|> do char '~' expr <- parseExpression return (OmitExp expr) <|> 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 parseInnerExp 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 "macro" spaces1) args <- parseFunPat spaces body <- parseExpression return (MacroExp 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 parseInnerExp 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 (LoadFile expr) = "(load-file " ++ 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 innerExps) = do innerVals <- innerExpToInnerValueMap innerExps vals <- innerValueListToValueList innerVals case vals of [val] -> return val _ -> do objRefs <- liftIO $ makeObjRefList 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 -> IOThrowsError 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 <- cEvalList objRefs str <- unwordsVals vals return ("<" ++ cons ++ " " ++ str ++ ">") showValue (Tuple []) = do return ("[]") showValue (Tuple objRefs) = do vals <- cEvalList objRefs str <- unwordsVals vals return ("[" ++ str ++ "]") showValue (Collection []) = do return ("{}") showValue (Collection innerVals) = do vals <- innerValueListToValueList 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] -> IOThrowsError String unwordsVals [] = return "" unwordsVals (val:vals) = do s1 <- showValue val s2 <- unwordsValsHelper vals return (s1 ++ s2) unwordsValsHelper :: [Value] -> IOThrowsError 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 innerExps) = do innerVals <- liftIO (makeClosureInnerVals env innerExps) objRefs <- innerValueListToObjRefList innerVals case objRefs of [objRef] -> 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 <- 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 [Value] cEvalList [] = return [] cEvalList (objRef:objRefs) = do val <- cEval objRef vals <- cEvalList objRefs return (val:vals) 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 <- patternMatch1 [(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 -- patternMatch1 :: [MState] -> IOThrowsError [Frame] patternMatch1 [] = return [] patternMatch1 ((MState frame []):_) = do return [frame] patternMatch1 ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef):atoms)):states) = do patObj <- liftIO (readIORef patObjRef) case patObj of Value (World _) -> throwError (Default "patternMatch1: not a pattern") Value (Character _) -> throwError (Default "patternMatch1: not a pattern") Value (Integer _) -> throwError (Default "patternMatch1: not a pattern") Value (Double _) -> throwError (Default "patternMatch1: not a pattern") Value (Collection _) -> throwError (Default "patternMatch1: not a pattern") Value (Function _ _ _) -> throwError (Default "patternMatch1: not a pattern") Value (Type _) -> throwError (Default "patternMatch1: not a pattern") Value (DestructorFunction _) -> throwError (Default "patternMatch1: not a pattern") Value (BuiltinFunction _) -> throwError (Default "patternMatch1: not a pattern") Value WildCard -> patternMatch1 ((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 patternMatch1 ((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 "patternMatch1: patVar not type") Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of 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 patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) pats inTgtObjRefs inTypObjRefs) ++ atoms))) inTgtObjRefss) ++ states) _ -> throwError (Default "patternMatch1: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef 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" []) -> patternMatch1 ((MState frame atoms):states) (InductiveData "false" []) -> patternMatch1 states _ -> throwError (Default "patternMatch1: return value of pred-pattern is not boolean") Value (AndPat pats) -> patternMatch1 ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states) Value (OrPat pats) -> patternMatch1 ((map (\pat -> (MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))) pats) ++ states) Value (CutPat pat) -> do retFrames <- patternMatch1 [(MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))] case retFrames of [] -> return [] _ -> do restFrames <- patternMatch1 states return (retFrames ++ restFrames) Closure env expr -> do patObj2 <- eval1 (bf:env) expr patObjRef2 <- liftIO (newIORef (Value patObj2)) patternMatch1 ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef):atoms)):states) 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 <- cEvalList 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 <- 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 <-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 <- 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