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