egison (empty) → 0.1
raw patch · 6 files changed
+1905/−0 lines, 6 filesdep +basedep +haskell98dep +mtlsetup-changed
Dependencies added: base, haskell98, mtl, parsec
Files
- Egison.hs +1310/−0
- LICENSE +18/−0
- Setup.hs +2/−0
- egison.cabal +68/−0
- sample/list-test.egi +429/−0
- sample/nat-test.egi +78/−0
+ Egison.hs view
@@ -0,0 +1,1310 @@+module Main where+import System.Environment+import Control.Monad.Error+import Data.IORef+import Text.ParserCombinators.Parsec hiding (spaces)+import qualified Text.Parsec.Token as P+import Text.Parsec.Language (haskellDef)+import IO hiding (try)++main :: IO ()+main = do args <- getArgs+ case length args of+ 0 -> do flushStr "Egison, version 0.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+ defsRef <- newIORef []+ runRepl defsRef+ _ -> putStrLn "Program takes only 0 argument!"++type Definitions = IORef [(String, Expression)]+ +runRepl :: Definitions -> IO ()+runRepl defs = do input <- (readPrompt "> ")+ case input of+ Eof -> flushStr "\nLeaving Egison.\nByebye. See you again! (^^)/\n"+ Input str -> runIOThrows ((liftThrows (readTopExpression str)) >>= executeTopExpression defs) >>= putStrLn >> runRepl defs+-- Input str -> runIOThrows (liftThrows (liftM show (readTopExpression str))) >>= putStrLn >> runRepl defs+ +executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String+executeTopExpression defs (Define name expr) = do+ liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))+ return name+executeTopExpression defs (Test expr) = do+ topFrame <- makeTopFrame defs+ val <- eval (Environment [topFrame]) expr+ liftIO (showValue val)+executeTopExpression defs Execute = do+ topFrame <- makeTopFrame defs+ val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp []))+ liftIO (showValue val)++readPrompt :: String -> IO Input+readPrompt prompt = flushStr prompt >> getExpression++flushStr :: String -> IO ()+flushStr str = putStr str >> hFlush stdout++data Input = Input String+ | Eof++getExpression :: IO Input+getExpression = catch (do str <- (getExpressionHelper 0)+ return (Input str))+ (\_ -> return Eof)+++getExpressionHelper :: Integer -> IO String+getExpressionHelper n = do c <- getChar+ case c of+ '(' -> do l <- getExpressionHelper (n + 1)+ return (c : l)+ '<' -> do l <- getExpressionHelper (n + 1)+ return (c : l)+ '[' -> do l <- getExpressionHelper (n + 1)+ return (c : l)+ '{' -> do l <- getExpressionHelper (n + 1)+ return (c : l)+ ')' -> do l <- getExpressionHelper (n - 1)+ return (c : l)+ '>' -> do l <- getExpressionHelper (n - 1)+ return (c : l)+ ']' -> do l <- getExpressionHelper (n - 1)+ return (c : l)+ '}' -> do l <- getExpressionHelper (n - 1)+ return (c : l)+ '\n' -> if n > 0+ then do l <- getExpressionHelper n+ return (c : l)+ else return "\n"+ _ -> do l <- getExpressionHelper n+ return (c : l)+ ++type IOThrowsError = ErrorT EgiError IO++data EgiError = Parser ParseError+ | NotFunction String+ | UnboundVariable String String+ | Default String++showError :: EgiError -> String+showError (Parser parseErr) = "Parse error at " ++ show parseErr+showError (NotFunction str) = "Error : " ++ str+showError (UnboundVariable str name) = "Error : " ++ str ++ name+showError (Default str) = "Error : " ++ str++instance Show EgiError where show = showError++instance Error EgiError where+ noMsg = Default "An error has occured"+ strMsg = Default++liftThrows :: ThrowsError a -> IOThrowsError a+liftThrows (Left err) = throwError err+liftThrows (Right val) = return val++runIOThrows :: IOThrowsError String -> IO String+runIOThrows action = runErrorT (trapError action) >>= return . extractValue++readTopExpression :: String -> ThrowsError TopExpression+readTopExpression = readOrThrow parseTopExpression++readTopExpressionList :: String -> ThrowsError [TopExpression]+readTopExpressionList = readOrThrow (endBy parseTopExpression spaces)+ +readOrThrow :: Parser a -> String -> ThrowsError a+readOrThrow parser input = case parse parser "egison" input of+ Left err -> throwError (Parser err)+ Right val -> return val++type ThrowsError = Either EgiError++trapError :: (MonadError e m, Show e) => m String -> m String+trapError action = catchError action (return . show)++extractValue :: ThrowsError a -> a+extractValue (Right val) = val++--+-- Data Types+--++data TopExpression = Define String Expression+ | Test Expression+ | Execute++data Expression = CharacterExp Char+ | StringExp String+ | NumberExp Integer+ | DoubleExp Double+ | SymbolExp String+ | InductiveDataExp String [Expression]+ | TupleExp [Expression]+ | CollectionExp [InnerExp]+ | PatternExp PatternExp+ | FunctionExp FunPat Expression+ | LetExp Bind Expression+ | TypeExp Bind+ | TypeRefExp Expression String+ | DeconstructorExp DeconsInfoExp+ | MatchExp Expression Expression [MatchClause]+ | MatchMapExp Expression Expression MatchClause+ | ApplyExp Expression Expression++data InnerExp = ElementExp Expression+ | SubCollectionExp Expression++data PatternExp = WildCardExp+ | PatVarExp String+ | CutPatExp Expression+ | AsPatExp String Expression+ | OfPatExp Expression+ | OnPatExp [String] Expression+ | ValPatExp Expression++data FunPat = FunPatVar String+ | FunPatTuple [FunPat]++type Bind = [(String, Expression)]++type DeconsInfoExp = [(String, Expression, [(PrimePat, Expression)])]++data MatchClause = MatchClause Expression Expression++data PrimePat = PrimeWildCard+ | PrimePatVar String+ | InductivePrimePat String [PrimePat]+ | EmptyPat+ | ConsPat PrimePat PrimePat+ | SnocPat PrimePat PrimePat++type Association = (String, IORef IntermidiateValue)++data Frame = Frame [Association]++data Environment = Environment [Frame]++data IntermidiateValue = Closure Environment Expression+ | Value Value++data Value = World+ | Character Char+ | Number Integer+ | Double Double+ | InductiveData String [IORef IntermidiateValue]+ | Tuple [IORef IntermidiateValue]+ | Collection [InnerValue]+ | Pattern Pattern+ | Function Environment FunPat Expression+ | Type Frame+ | Deconstructor (IORef IntermidiateValue) DeconsInfo+ | DeconstructorFunction DeconsInfo+ | BuiltinFunction ([Value] -> IOThrowsError Value)++data InnerValue = Element (IORef IntermidiateValue)+ | SubCollection (IORef IntermidiateValue)++data Pattern = WildCard+ | PatVar String+ | CutPat (IORef IntermidiateValue)+ | AsPat String (IORef IntermidiateValue)+ | OfPat [IORef IntermidiateValue]+ | OnPat [String] Environment Expression+ | ValPat (IORef IntermidiateValue)++type DeconsInfo = [(String, IORef IntermidiateValue, [(Environment, PrimePat, Expression)])]++--+-- Parser+--++lexer = P.makeTokenParser haskellDef++charLiteral = P.charLiteral lexer+stringLiteral = P.stringLiteral lexer+integer = P.integer lexer+float = P.float lexer++headSymbol :: Parser Char+headSymbol = oneOf ":+-*/="++restSymbol :: Parser Char+restSymbol = oneOf "!?:+-*/="++word :: Parser String+word = do first <- (letter <|> headSymbol)+ rest <- many (letter <|> digit <|> restSymbol)+ return (first:rest)++spaces :: Parser ()+spaces = skipMany (oneOf " \n\t")+ +parseTopExpression :: Parser TopExpression+parseTopExpression = try (do char '('+ spaces+ string "define"+ spaces+ char '$'+ name <- word+ spaces+ expr <- parseExpression+ spaces+ char ')'+ return (Define name expr))+ <|> try (do char '('+ spaces+ string "test"+ spaces+ expr <- parseExpression+ spaces+ char ')'+ return (Test expr))+ <|> try (do char '('+ spaces+ string "execute"+ spaces+ char ')'+ return Execute)++parseExpression :: Parser Expression+parseExpression = do ws <- word+ return (SymbolExp ws)+ <|> do c <- charLiteral+ return (CharacterExp c)+ <|> do str <- stringLiteral+ return (StringExp str)+ <|> do n <- integer+ return (NumberExp n)+-- <|> try (do d <- float+-- return (DoubleExp d))+ <|> do char '<'+ spaces+ c <- word+ spaces+ vs <- sepEndBy parseExpression spaces+ char '>'+ return (InductiveDataExp c vs)+ <|> do char '['+ spaces+ vs <- sepEndBy parseExpression spaces+ char ']'+ return (TupleExp vs)+ <|> do char '{'+ spaces+ vs <- sepEndBy parseInnerExp spaces+ char '}'+ return (CollectionExp vs)+ <|> try (do pat <- parsePatternExp+ return (PatternExp pat))+ <|> try (do char '('+ spaces+ string "lambda"+ spaces+ args <- parseFunPat+ spaces+ body <- parseExpression+ spaces+ char ')'+ return (FunctionExp args body))+ <|> try (do char '('+ spaces+ string "let"+ spaces+ bind <- parseBind+ spaces+ body <- parseExpression+ spaces+ char ')'+ return (LetExp bind body))+ <|> try (do char '('+ spaces+ string "type"+ spaces+ bind <- parseBind+ spaces+ char ')'+ return (TypeExp bind))+ <|> try (do char '('+ spaces+ string "type-ref"+ spaces+ typ <- parseExpression+ spaces+ name <- word+ spaces+ char ')'+ return (TypeRefExp typ name))+ <|> try (do char '('+ spaces+ string "deconstructor"+ spaces+ deconsInfo <- parseDeconsInfoExp+ spaces+ char ')'+ return (DeconstructorExp deconsInfo))+ <|> try (do char '('+ spaces+ string "match"+ spaces+ tgt <- parseExpression+ spaces+ typ <- parseExpression+ spaces+ char '{'+ spaces+ clss <- sepEndBy parseMatchClause spaces+ char '}'+ spaces+ char ')'+ return (MatchExp tgt typ clss))+ <|> try (do char '('+ spaces+ string "match-map"+ spaces+ tgt <- parseExpression+ spaces+ typ <- parseExpression+ spaces+ cls <- parseMatchClause+ spaces+ char ')'+ return (MatchMapExp tgt typ cls))+ <|> try (do char '('+ spaces+ string "apply"+ spaces+ fn <- parseExpression+ spaces+ args <- parseExpression+ spaces+ char ')'+ return (ApplyExp fn args))+ <|> do char '('+ spaces+ fn <- parseExpression+ spaces+ args <- sepEndBy parseExpression spaces+ char ')'+ return (ApplyExp fn (TupleExp args))++parseInnerExp :: Parser InnerExp+parseInnerExp = do v <- parseExpression+ return (ElementExp v)+ <|> do char '@'+ v <- parseExpression+ return (SubCollectionExp v)++parseFunPat :: Parser FunPat+parseFunPat = do char '$'+ name <- word+ return (FunPatVar name)+ <|> try (do char '['+ spaces+ fpat <- parseFunPat+ spaces+ char ']'+ return fpat)+ <|> try (do char '['+ spaces+ fpats <- sepEndBy parseFunPat spaces+ char ']'+ return (FunPatTuple fpats))+ +parseBind :: Parser Bind+parseBind = do char '{'+ spaces+ bs <- sepEndBy (do char '['+ spaces+ char '$'+ var <- word+ spaces+ expr <- parseExpression+ spaces+ char ']'+ return (var, expr))+ spaces+ char '}'+ return bs++parseDeconsInfoExp :: Parser DeconsInfoExp+parseDeconsInfoExp = do char '{'+ spaces+ deconsInfoExp <- sepEndBy parseDeconsClause spaces+ spaces+ char '}'+ return deconsInfoExp++parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)]) +parseDeconsClause = do char '['+ spaces+ patCons <- word+ spaces+ typExpr <- parseExpression+ spaces+ char '{'+ spaces+ dc2s <- sepEndBy parseDeconsClause2 spaces+ char '}'+ spaces+ char ']'+ return (patCons, typExpr, dc2s)++parseDeconsClause2 :: Parser (PrimePat, Expression)+parseDeconsClause2 = do char '['+ spaces+ datPat <- parsePrimePat+ spaces+ expr <- parseExpression + spaces+ char ']'+ return (datPat, expr)++parsePrimePat :: Parser PrimePat+parsePrimePat = do char '_'+ return PrimeWildCard+ <|> do char '$'+ name <- word+ return (PrimePatVar name)+ <|> do char '<'+ spaces+ c <- word+ spaces+ ps <- sepEndBy parsePrimePat spaces+ char '>'+ return (InductivePrimePat c ps)+ <|> try (do char '{'+ spaces+ char '}'+ return EmptyPat)+ <|> try (do char '{'+ spaces+ a <- parsePrimePat+ spaces+ char '.'+ b <- parsePrimePat+ spaces+ char '}'+ return (ConsPat a b))+ <|> try (do char '{'+ spaces+ char '.'+ a <- parsePrimePat+ spaces+ b <- parsePrimePat+ spaces+ char '}'+ return (SnocPat a b))+ +parseMatchClause :: Parser MatchClause+parseMatchClause = do char '['+ spaces+ pat <- parseExpression+ spaces+ body <- parseExpression+ spaces+ char ']'+ return (MatchClause pat body)++parsePatternExp :: Parser PatternExp+parsePatternExp = do char '_'+ return WildCardExp+ <|> do char '$'+ name <- word+ return (PatVarExp name)+ <|> do char '!'+ expr <- parseExpression+ return (CutPatExp expr)+ <|> do char ','+ expr <- parseExpression+ return (ValPatExp expr)+ <|> try (do char '('+ spaces+ string "as"+ spaces+ char '$'+ name <- word+ spaces+ expr <- parseExpression+ spaces+ char ')'+ return (AsPatExp name expr))+ <|> try (do char '('+ spaces+ string "of"+ spaces+ expr <- parseExpression+ spaces+ char '}'+ return (OfPatExp expr))+ <|> try (do char '('+ spaces+ string "on"+ spaces+ var <- (char '$' >> word)+ spaces+ expr <- parseExpression+ spaces+ char ')'+ return (OnPatExp [var] expr))+ <|> try (do char '('+ spaces+ string "on"+ spaces+ char '['+ spaces+ vars <- sepEndBy (char '$' >> word) spaces+ char ']'+ spaces+ expr <- parseExpression+ spaces+ char ')'+ return (OnPatExp vars expr))+ +--+-- Environment+--+getValueFromFrame :: Frame -> String -> Maybe (IORef IntermidiateValue)+getValueFromFrame (Frame []) _ = Nothing+getValueFromFrame (Frame ((var, iValRef):rest)) name =+ if name == var+ then Just iValRef+ else getValueFromFrame (Frame rest) name++getValue :: Environment -> String -> IOThrowsError (IORef IntermidiateValue)+getValue (Environment []) name = throwError (UnboundVariable "Unbound Variable : " name)+getValue (Environment (frame : env)) name =+ let mValRef = getValueFromFrame frame name in+ case mValRef of+ Nothing -> getValue (Environment env) name+ Just iValRef -> return iValRef++makeClosure :: Environment -> Expression -> IO (IORef IntermidiateValue)+makeClosure env expr = newIORef (Closure env expr)+ +makeClosureList :: Environment -> [Expression] -> IO [IORef IntermidiateValue]+makeClosureList _ [] = return []+makeClosureList env (expr : exprs) = do+ iVal <- makeClosure env expr+ iVals <- makeClosureList env exprs+ return (iVal:iVals)++makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue]+makeClosureInnerVals _ [] = return []+makeClosureInnerVals env (ElementExp expr : rest) = do+ iValRef <- makeClosure env expr+ innerValRefs <- makeClosureInnerVals env rest+ return (Element iValRef : innerValRefs)+makeClosureInnerVals env (SubCollectionExp expr : rest) = do + iValRef <- makeClosure env expr+ innerValRefs <- makeClosureInnerVals env rest+ return (SubCollection iValRef : innerValRefs)++makeDeconsInfo :: Environment -> DeconsInfoExp -> IO DeconsInfo+makeDeconsInfo _ [] = return []+makeDeconsInfo env ((cons, typeExp, dcs):deconsInfoExp) = do+ typeIValRef <- makeClosure env typeExp+ let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in+ do deconsInfo <- makeDeconsInfo env deconsInfoExp+ return ((cons, typeIValRef, dcs2):deconsInfo)+ +makeFrame :: FunPat -> IORef IntermidiateValue -> IOThrowsError Frame+makeFrame (FunPatVar name) iValRef = do+ return (Frame [(name, iValRef)])+makeFrame (FunPatTuple []) iValRef = do+ val <- force iValRef+ case val of+ Tuple [] -> return (Frame [])+ _ -> throwError (Default "invalid number of argument")+makeFrame (FunPatTuple fpats) iValRef = do+ val <- force iValRef+ let loop fpats2 iValRefs2 = case (fpats2, iValRefs2) of+ ([], []) -> return (Frame [])+ ((fpat2:fps), (iValRef2:ivrs)) -> do frame1 <- makeFrame fpat2 iValRef2+ frame2 <- loop fps ivrs+ return (appendFrames frame1 frame2)+ (_, _) -> throwError (Default "invalid number of argument") in+ case val of+ Tuple iValRefs2 -> loop fpats iValRefs2+ _ -> loop fpats [iValRef]++makeFrameMap :: FunPat -> [IORef IntermidiateValue] -> IOThrowsError [Frame]+makeFrameMap _ [] = return []+makeFrameMap fpat (iValRef:iValRefs) = do+ frame <- makeFrame fpat iValRef+ frames <- makeFrameMap fpat iValRefs+ return (frame:frames)+ +appendFrames :: Frame -> Frame -> Frame+appendFrames (Frame frame1) (Frame frame2) = Frame (frame1 ++ frame2)+ +makeRecursiveFrame :: Environment -> Bind -> IOThrowsError Frame+makeRecursiveFrame env bind =+ let vars = map fst bind in+ let exprs = map snd bind in+ do iValRefs <- liftIO (makeClosureList (Environment []) exprs)+ let newFrame = Frame (zip vars iValRefs) in+ do liftIO (makeRecursiveFrameHelper env newFrame newFrame)+ return newFrame++makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO ()+makeRecursiveFrameHelper _ _ (Frame []) = return ()+makeRecursiveFrameHelper env newFrame (Frame ((_, iValRef):assocs)) = do+ iVal <- readIORef iValRef+ case iVal of+ (Closure _ expr) -> writeIORef iValRef (Closure (addFrame newFrame env) expr)+ makeRecursiveFrameHelper env newFrame (Frame assocs)++makeTopFrame :: Definitions -> IOThrowsError Frame+makeTopFrame defsRef = do+ defs <- liftIO (readIORef defsRef)+ makeRecursiveFrame (Environment []) defs++addFrame :: Frame -> Environment -> Environment+addFrame frame (Environment frames) = Environment (frame:frames)+ +--+--+--++showValue :: Value -> IO String+showValue (Character c) = return (show c)+showValue (Number n) = return (show n)+showValue (Double d) = return (show d)+showValue (InductiveData cons []) = do+ return ("<" ++ cons ++ ">")+showValue (InductiveData cons iValRefs) = do+ vals <- iValListToValueList iValRefs+ str <- unwordsVals vals+ return ("<" ++ cons ++ " " ++ str ++ ">")+showValue (Tuple []) = do+ return ("[]")+showValue (Tuple iValRefs) = do+ vals <- iValListToValueList iValRefs+ str <- unwordsVals vals+ return ("[" ++ str ++ "]")+showValue (Collection []) = do+ return ("{}")+showValue (Collection innerVals) = do+ vals <- collectionToValueList (Collection innerVals)+ str <- unwordsVals vals+ return ("{" ++ str ++ "}")+showValue (Pattern patVal) = do+ showPattern patVal+showValue (Function _ _ _) = do+ return "#<function>"+showValue (Type _) = do+ return "#<type>"+showValue (DeconstructorFunction _) = do+ return "#<deconstructor-function>"+showValue (BuiltinFunction _) = do+ return "#<builtin-function>"++showPattern :: Pattern -> IO String+showPattern WildCard = return "_"+showPattern (PatVar name) = return ("$" ++ name)+showPattern _ = undefined+ +unwordsList :: Show a => [a] -> String+unwordsList = unwords . map show++unwordsVals :: [Value] -> IO String+unwordsVals [] = return ""+unwordsVals (val:vals) = do+ s1 <- showValue val+ s2 <- unwordsValsHelper vals+ return (s1 ++ s2)+ +unwordsValsHelper :: [Value] -> IO String+unwordsValsHelper [] = return ""+unwordsValsHelper (val:vals) = do+ s1 <- showValue val+ s2 <- unwordsValsHelper vals+ return (" " ++ s1 ++ s2)++--+-- Eval+--++force :: IORef IntermidiateValue -> IOThrowsError Value+force iValRef = do+ iVal <- liftIO (readIORef iValRef)+ case iVal of+ Closure env expr -> do val <- eval1 env expr+ liftIO (writeIORef iValRef (Value val))+ return val+ Value val -> return val++eval1 :: Environment -> Expression -> IOThrowsError Value+eval1 _ (CharacterExp c) = return (Character c)+eval1 _ (StringExp str) = do+ val <- liftIO (makeCollectionFromValueList (map Character str))+ return val+eval1 _ (NumberExp n) = return (Number n)+eval1 _ (DoubleExp d) = return (Double d)+eval1 env (SymbolExp name) = do+ let mBuiltinFn = getBuiltin name in+ case mBuiltinFn of+ Just builtinFn -> return (BuiltinFunction builtinFn)+ Nothing -> do iValRef <- getValue env name+ val <- force iValRef+ return val+eval1 env (InductiveDataExp con exprs) = do+ iValRefs <- liftIO (makeClosureList env exprs)+ return (InductiveData con iValRefs)+eval1 env (TupleExp exprs) = do+ iValRefs <- liftIO (makeClosureList env exprs)+ case iValRefs of+ [iValRef] -> do force iValRef+ _ -> return (Tuple iValRefs)+eval1 env (CollectionExp innerExps) = do+ innerVals <- liftIO (makeClosureInnerVals env innerExps)+ return (Collection innerVals)+eval1 env (PatternExp patExp) = evalPattern1 env patExp+eval1 env (FunctionExp args body) = return (Function env args body)+eval1 (Environment frames) (LetExp bind body) = do+ frame <- makeRecursiveFrame (Environment frames) bind+ iValRef <- liftIO (newIORef (Closure (Environment (frame:frames)) body))+ force iValRef+eval1 env (TypeExp bind) = do+ frame <- makeRecursiveFrame env bind+ return (Type frame)+eval1 env (TypeRefExp typExp name) = do+ typVal <- eval1 env typExp+ case typVal of+ (Type frame) -> let mIValRef = getValueFromFrame frame name in+ case mIValRef of+ Nothing -> throwError (Default ("no method in type : " ++ name))+ Just iValRef -> do val <- force iValRef+ return val+ _ -> throwError (Default "first arg of typeref is not type")+eval1 env (DeconstructorExp deconsInfoExp) = do+ deconsInfo <- liftIO (makeDeconsInfo env deconsInfoExp)+ return (DeconstructorFunction deconsInfo)+eval1 env (MatchExp tgtExp typExp mCs) = do+ typIVal <- liftIO (makeClosure env typExp)+ tgtIVal <- liftIO (makeClosure env tgtExp)+ forceMatchExp env typIVal tgtIVal mCs+eval1 env (MatchMapExp tgtExp typExp mC) = do+ typIVal <- liftIO (makeClosure env typExp)+ tgtIVal <- liftIO (makeClosure env tgtExp)+ forceMatchMapExp env typIVal tgtIVal mC +eval1 env (ApplyExp fnExp argsExp) = do+ fnVal <- eval1 env fnExp+ argsIValRef <- liftIO (makeClosure env argsExp)+ case fnVal of+ BuiltinFunction builtinFn -> do argsVal <- forceRecursively argsIValRef+ argsVals <- liftIO (tupleToValueList argsVal)+ builtinFn argsVals+ Function (Environment funEnv) fpat body -> do frame <- makeFrame fpat argsIValRef+ iValRef <- liftIO (makeClosure (Environment (frame:funEnv)) body)+ force iValRef+ DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo)+ _ -> throwError (NotFunction "Applying non-functional object.") ++evalPattern1 :: Environment -> PatternExp -> IOThrowsError Value+evalPattern1 _ WildCardExp = return (Pattern WildCard)+evalPattern1 _ (PatVarExp name) = return (Pattern (PatVar name))+evalPattern1 env (CutPatExp expr) = do+ iValRef <- liftIO (makeClosure env expr)+ return (Pattern (CutPat iValRef))+evalPattern1 env (AsPatExp var expr) = do+ iValRef <- liftIO (makeClosure env expr)+ return (Pattern (AsPat var iValRef))+evalPattern1 env (OfPatExp expr) = do+ iValRef <- liftIO (makeClosure env expr)+ iValRefs <- tupleToList iValRef+ return (Pattern (OfPat iValRefs))+evalPattern1 env (OnPatExp vars expr) = do+ return (Pattern (OnPat vars env expr))+evalPattern1 env (ValPatExp expr) = do+ iValRef <- liftIO (makeClosure env expr)+ return (Pattern (ValPat iValRef))++eval :: Environment -> Expression -> IOThrowsError Value+eval env expr = do+ iValRef <- liftIO (makeClosure env expr)+ val <- force iValRef+ forceValue val+ return val++forceValue :: Value -> IOThrowsError Value+forceValue (InductiveData cons iValRefs) = do+ forceRecursivelyList iValRefs+ return (InductiveData cons iValRefs)+forceValue (Tuple iValRefs) = do+ forceRecursivelyList iValRefs+ return (Tuple iValRefs)+forceValue (Collection innerVals) = do+ forceRecursivelyInnerVals innerVals+ return (Collection innerVals)+forceValue (Pattern pat) = do+ forceRecursivelyPattern pat+ return (Pattern pat)+forceValue val = return val+ +forceRecursively :: IORef IntermidiateValue -> IOThrowsError Value+forceRecursively iValRef = do+ val <- force iValRef+ forceValue val+ +forceRecursivelyList :: [IORef IntermidiateValue] -> IOThrowsError ()+forceRecursivelyList [] = return ()+forceRecursivelyList (iValRef:iValRefs) = do+ forceRecursively iValRef+ forceRecursivelyList iValRefs+ +forceRecursivelyInnerVals :: [InnerValue] -> IOThrowsError ()+forceRecursivelyInnerVals [] = return ()+forceRecursivelyInnerVals (Element iValRef : rest) = do+ forceRecursively iValRef+ forceRecursivelyInnerVals rest+forceRecursivelyInnerVals (SubCollection iValRef : rest) = do+ forceRecursively iValRef+ forceRecursivelyInnerVals rest++forceRecursivelyPattern :: Pattern -> IOThrowsError Pattern+forceRecursivelyPattern WildCard = return WildCard+forceRecursivelyPattern (PatVar var) = return (PatVar var)+forceRecursivelyPattern (CutPat iValRef) = do+ forceRecursively iValRef+ return (CutPat iValRef)+forceRecursivelyPattern (AsPat var iValRef) = do+ forceRecursively iValRef+ return (AsPat var iValRef)+forceRecursivelyPattern (OfPat iValRefs) = do+ forceRecursivelyList iValRefs+ return (OfPat iValRefs)+forceRecursivelyPattern (OnPat vars env expr) = return (OnPat vars env expr)+forceRecursivelyPattern (ValPat iValRef) = do+ forceRecursively iValRef+ return (ValPat iValRef)+ +---+---+---++forceMatchExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> [MatchClause] -> IOThrowsError Value+forceMatchExp env typIValRef tgtIValRef (MatchClause pat expr:rest) = do+ typVals <- tupleToList typIValRef+ tgtVals <- tupleToList tgtIValRef+ patIValRef <- liftIO (makeClosure env pat)+ patVals <- tupleToList patIValRef+ matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals+ case matchs of+ [] -> forceMatchExp env typIValRef tgtIValRef rest+ (frame:_) -> do iValRef <- liftIO (makeClosure (addFrame frame env) expr)+ force iValRef+forceMatchExp _ _ _ _ = throwError (Default "end of match clause") ++forceMatchMapExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value+forceMatchMapExp env typIValRef tgtIValRef (MatchClause pat expr) = do+ typVals <- tupleToList typIValRef+ tgtVals <- tupleToList tgtIValRef+ patIValRef <- liftIO (makeClosure env pat)+ patVals <- tupleToList patIValRef+ matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals+ innerVals <- forceMatchMapExpHelper env matchs expr+ return (Collection innerVals)++forceMatchMapExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue]+forceMatchMapExpHelper _ [] _ = return []+forceMatchMapExpHelper env (frame:frames) expr = do+ iValRef <- liftIO (makeClosure (addFrame frame env) expr)+ force iValRef+ rest <- forceMatchMapExpHelper env frames expr+ return (Element iValRef:rest)++patternMatchList :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]+patternMatchList [] _ _ _ = return []+patternMatchList frames [] [] [] = return frames+patternMatchList frames (typRef:typRefs) (patRef:patRefs) (tgtRef:tgtRefs) = do+ typVal <- force typRef+ patVal <- force patRef+ newFrames <- patternMatch frames typVal patVal tgtRef+ patternMatchList newFrames typRefs patRefs tgtRefs+patternMatchList _ _ _ _ = throwError (Default "numbers of type, pattern, and target are different") ++patternMatch :: [Frame] -> Value -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame]+patternMatch [] _ _ _ = return []+patternMatch frames _ (Pattern WildCard) _ = return frames+patternMatch frames (Type bind) (Pattern (PatVar var)) tgtIValRef = do+ case getValueFromFrame bind "var-match" of+ Nothing -> throwError (Default "no var-match")+ Just varMatchFnRef -> do varMatchFn <- force varMatchFnRef+ case varMatchFn of+ Function funEnv fpat body -> do argsFrame <- makeFrame fpat tgtIValRef+ iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)+ iValRefs <- collectionToList iValRef+ newFrames <- makeFrameMap (FunPatVar var) iValRefs+ return (connectFrames frames newFrames)+ _ -> throwError (Default "not function : var-match")+patternMatch frames (Type bind) (InductiveData cons patIValRefs) tgtIValRef =+ case getValueFromFrame bind "inductive-match" of+ Nothing -> throwError (Default "no inductive-match")+ Just inductiveMatchFnRef+ -> do inductiveMatchFn <- force inductiveMatchFnRef+ case inductiveMatchFn of+ DeconstructorFunction deconsInfo+ -> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef+ Function funEnv fpat body+ -> do argsFrame <- makeFrame fpat tgtIValRef+ iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)+ val <- force iValRef+ case val of+ Deconstructor tgtIValRef2 deconsInfo+ -> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef2+ _ -> throwError (Default "not function : inductive-match")+patternMatch (frame:_) typVal (Pattern (CutPat patIValRef)) tgtIValRef = do+ patVal <- force patIValRef+ patternMatch [frame] typVal patVal tgtIValRef+patternMatch (frame:frames) typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef = do+ onFrame <- extractAssocs frame vars+ patIValRef <- liftIO (makeClosure (addFrame onFrame onEnv) expr)+ patVal <- force patIValRef+ newFrames1 <- patternMatch [frame] typVal patVal tgtIValRef+ newFrames2 <- patternMatch frames typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef+ return (newFrames1 ++ newFrames2)+patternMatch frames (Type bind) (Pattern (ValPat iValPatRef)) tgtIValRef = do+ case getValueFromFrame bind "=" of+ Nothing -> throwError (Default "no = function")+ Just valMatchFnRef -> do valMatchFn <- force valMatchFnRef+ case valMatchFn of+ Function funEnv fpat body -> do argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef])))+ argsFrame <- makeFrame fpat argsIValRef+ iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)+ val <- force iValRef+ case val of+ (InductiveData "true" []) -> return frames+ (InductiveData "false" []) -> return []+ _ -> throwError (Default "invalid return value from = function")+ _ -> throwError (Default "= is not function")+patternMatch _ _ _ _ = throwError (Default "invalid pattern")++doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame]+doDeconstruct [] _ _ _ = throwError (Default "no match decons clause")+doDeconstruct ((pCons, innerTypeIValRef, dcs):deconsInfo) frames (InductiveData cons pats) tgtIValRef =+ if pCons == cons+ then do innerTypeIValRefs <- tupleToList innerTypeIValRef+ let loop dcs2 = case dcs2 of+ [] -> throwError (Default "no match primitive pattern")+ (env, primePat, expr):rest -> do mFrame <- primitivePatternMatch primePat tgtIValRef+ case mFrame of+ Nothing -> loop rest+ Just pFrame -> do retIValRef <- liftIO (makeClosure (addFrame pFrame env) expr)+ retIValRefs <- collectionToList retIValRef+ patternMatchListMap frames innerTypeIValRefs pats retIValRefs in+ loop dcs+ else doDeconstruct deconsInfo frames (InductiveData cons pats) tgtIValRef+doDeconstruct _ _ _ _ = throwError (Default "at doDeconstruct : number of types, patterns, and targets are different")++patternMatchListMap :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]+patternMatchListMap _ _ _ [] = return []+patternMatchListMap frames typesIValRefs patIValRefs (tgtIValRef:rest) = do+ tgtIValRefs <- tupleToList tgtIValRef+ frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs+ frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest+ return (frames1 ++ frames2)+ +connectFrames :: [Frame] -> [Frame] -> [Frame]+connectFrames [] _ = []+connectFrames (frame:frames) newFrames =+ (map (\newFrame -> (appendFrames frame newFrame)) newFrames) ++ (connectFrames frames newFrames)++extractAssocs :: Frame -> [String] -> IOThrowsError Frame+extractAssocs _ [] = return (Frame [])+extractAssocs frame (var:vars) =+ let mValRef = getValueFromFrame frame var in+ case mValRef of+ Nothing -> throwError (Default "extractAssocs")+ Just iValRef -> do newFrame <- extractAssocs frame vars+ case newFrame of+ Frame assocs -> return (Frame ((var, iValRef):assocs))+ +---+---+---+ +primitivePatternMatch :: PrimePat -> IORef IntermidiateValue -> IOThrowsError (Maybe Frame)+primitivePatternMatch PrimeWildCard _ = return (Just (Frame []))+primitivePatternMatch (PrimePatVar name) iValRef = return (Just (Frame [(name, iValRef)]))+primitivePatternMatch (InductivePrimePat pCons pPats) iValRef = do+ val <- force iValRef+ case val of+ InductiveData cons iValRefs -> if pCons == cons+ then primitivePatternMatchMap pPats iValRefs+ else return Nothing+ _ -> throwError (Default "primitive : not inductive value to primitive inductive pattern")+primitivePatternMatch EmptyPat iValRef = do+ val <- force iValRef+ b <- isEmptyCollection val+ if b+ then return (Just (Frame []))+ else return Nothing+primitivePatternMatch (ConsPat carPat cdrPat) iValRef = do+ val <- force iValRef+ b <- isEmptyCollection val+ if b+ then return Nothing+ else do (carIValRef, cdrIValRef) <- consDeconstruct val+ mCarFrame <- primitivePatternMatch carPat carIValRef+ case mCarFrame of+ Nothing -> return Nothing+ Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrIValRef+ case mCdrFrame of+ Nothing -> return Nothing+ Just cdrFrame -> return (Just (appendFrames carFrame cdrFrame))+primitivePatternMatch (SnocPat rdcPat racPat) iValRef = do+ val <- force iValRef+ b <- isEmptyCollection val+ if b+ then return Nothing+ else do (racIValRef, rdcIValRef) <- snocDeconstruct val+ mRacFrame <- primitivePatternMatch racPat racIValRef+ case mRacFrame of+ Nothing -> return Nothing+ Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcIValRef+ case mRdcFrame of+ Just rdcFrame -> return (Just (appendFrames racFrame rdcFrame))+ Nothing -> return Nothing+ +primitivePatternMatchMap :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame)+primitivePatternMatchMap [] [] = return (Just (Frame []))+primitivePatternMatchMap (pat:pats) (iValRef:iValRefs) = do+ mFrame <- primitivePatternMatch pat iValRef+ case mFrame of+ Nothing -> return Nothing+ Just frame -> do mRestFrame <- primitivePatternMatchMap pats iValRefs+ case mRestFrame of+ Nothing -> return Nothing+ Just restFrame -> return (Just (appendFrames frame restFrame))+primitivePatternMatchMap _ _ = throwError (Default "primitivePatternMatchMap : number of patterns and targets are different") ++isEmptyCollection :: Value -> IOThrowsError Bool+isEmptyCollection (Collection []) = return True+isEmptyCollection (Collection (Element _:_)) = return False+isEmptyCollection (Collection (SubCollection subRef:rest)) = do+ subVal <- force subRef+ b <- isEmptyCollection subVal+ if b+ then isEmptyCollection (Collection rest)+ else return False+isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection")++consDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue)+consDeconstruct (Collection (Element eRef:rest)) = do+ restRef <- liftIO (newIORef (Value (Collection rest)))+ return (eRef, restRef)+consDeconstruct (Collection (SubCollection subRef:rest)) = do+ subVal <- force subRef+ b <- isEmptyCollection subVal+ if b+ then consDeconstruct (Collection rest)+ else do (carRef, cdrRef) <- consDeconstruct subVal+ cdrVal <- force cdrRef+ case cdrVal of+ Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest))))+ return (carRef, restRef)+consDeconstruct (Collection []) = throwError (Default "empty collection") +consDeconstruct _ = throwError (Default "consDeconstruct : not collection") ++snocDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue)+snocDeconstruct (Collection innerVals) =+ case reverse innerVals of+ Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest))))+ return (eRef, restRef)+ SubCollection subRef:rest+ -> do subVal <- force subRef+ b <- isEmptyCollection subVal+ if b+ then snocDeconstruct (Collection (reverse rest))+ else do (racRef, rdcRef) <- snocDeconstruct subVal+ rdcVal <- force rdcRef+ case rdcVal of+ Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs))))+ return (racRef, restRef)+snocDeconstruct _ = throwError (Default "snocDeconstruct : not collection") ++---+---+---++iValListToValueList :: [IORef IntermidiateValue] -> IO [Value]+iValListToValueList [] = return []+iValListToValueList (iValRef:iValRefs) = do+ iVal <- readIORef iValRef+ case iVal of+ Value val -> do vals <- iValListToValueList iValRefs+ return (val:vals)+ +tupleToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]+tupleToList iValRef = do+ val <- force iValRef+ case val of+ (Tuple iValRefs) -> return iValRefs+ val -> return [iValRef]++tupleToValueList :: Value -> IO [Value]+tupleToValueList (Tuple []) = return []+tupleToValueList (Tuple (iValRef:iValRefs)) = do+ val <- readIORef iValRef+ case val of+ Value val -> do vals <- tupleToValueList (Tuple iValRefs)+ return (val:vals)+tupleToValueList val = return [val] + +collectionToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]+collectionToList iValRef = do+ val <- force iValRef+ let loop val = case val of+ (Collection []) -> return []+ (Collection (Element eRef:rest)) -> do restRefs <- loop (Collection rest)+ return (eRef : restRefs)+ (Collection (SubCollection subRef:rest)) -> do valRefs1 <- collectionToList subRef+ valRefs2 <- loop (Collection rest)+ return (valRefs1 ++ valRefs2)+ _ -> throwError (Default "collectionToList : not collection") in+ loop val++collectionToValueList :: Value -> IO [Value]+collectionToValueList (Collection []) = return []+collectionToValueList (Collection (Element eRef : rest)) = do+ eIVal <- readIORef eRef+ case eIVal of+ Value e -> do rest <- collectionToValueList (Collection rest)+ return (e : rest)+collectionToValueList (Collection (SubCollection subRef : rest)) = do+ subIVal <- readIORef subRef+ case subIVal of+ Value subVal -> do vals1 <- collectionToValueList subVal+ vals2 <- collectionToValueList (Collection rest)+ return (vals1 ++ vals2)++makeCollectionFromValueList :: [Value] -> IO Value+makeCollectionFromValueList vals =+ let loop vals2 = case vals2 of+ [] -> return []+ (val:rest) -> do iValRef <- newIORef (Value val)+ restRefs <- loop rest+ return ((Element iValRef):restRefs) in+ do innerVals <- loop vals+ return (Collection innerVals)++---+--- Builtin Function+---++getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value)+getBuiltin name =+ case name of+ "+" -> Just builtinPlus+ "-" -> Just builtinMinus+ "*" -> Just builtinMultiply+ _ -> Nothing+ +builtinPlus :: [Value] -> IOThrowsError Value+builtinPlus [(Number n1), (Number n2)] = return (Number (n1 + n2))+builtinPlus _ = throwError (Default "invalid args to +")++builtinMinus :: [Value] -> IOThrowsError Value+builtinMinus [(Number n1), (Number n2)] = return (Number (n1 - n2))+builtinMinus _ = throwError (Default "invalid args to -")++builtinMultiply :: [Value] -> IOThrowsError Value+builtinMultiply [(Number n1), (Number n2)] = return (Number (n1 * n2))+builtinMultiply _ = throwError (Default "invalid args to *")++---+--- for Debug : show Expression+---++showTopExpression :: TopExpression -> String+showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")"+showTopExpression (Test expr) = "(test " ++ show expr ++ ")"+showTopExpression Execute = "(execute)"++instance Show TopExpression where show = showTopExpression++showExpression :: Expression -> String+showExpression (CharacterExp c) = show c+showExpression (NumberExp n) = show n+showExpression (SymbolExp name) = name+showExpression (InductiveDataExp s []) = "<" ++ s ++ ">"+showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">"+showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]"+showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}"+showExpression (PatternExp pat) = show pat+showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"+showExpression (LetExp bind expr) = "(let " ++ showBind bind ++ " " ++ show expr ++ ")"+showExpression (TypeExp bind) = "(type " ++ showBind bind ++ ")"+showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")"+showExpression (DeconstructorExp deconsInfoExp) = "(deconstructor " ++ showDeconsInfoExp deconsInfoExp ++ ")"+showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})"+showExpression (MatchMapExp tgt typ cls) = "(match-map " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")"+showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")"++instance Show Expression where show = showExpression++showInnerExp :: InnerExp -> String+showInnerExp (ElementExp v) = show v+showInnerExp (SubCollectionExp v) = "@" ++ show v++instance Show InnerExp where show = showInnerExp++showPatternExp :: PatternExp -> String+showPatternExp WildCardExp = "_"+showPatternExp (PatVarExp s) = "$" ++ s+showPatternExp (CutPatExp p) = "!" ++ show p+showPatternExp (AsPatExp s p) = "(as " ++ s ++ " " ++ show p ++ ")"+showPatternExp (OfPatExp ps) = "(of " ++ show ps ++ ")"+showPatternExp (OnPatExp vars pat) = "(on [" ++ unwords (map (\var -> "$" ++ var) vars) ++ "] " ++ show pat ++ ")"+showPatternExp (ValPatExp expr) = "," ++ show expr++instance Show PatternExp where show = showPatternExp++showBind :: Bind -> String+showBind [] = "{}"+showBind bind = "{" ++ unwords (map showBindHelper bind) ++ "}"++showBindHelper :: (String, Expression) -> String+showBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]"++showFunPat :: FunPat -> String+showFunPat (FunPatVar name) = "$" ++ name+showFunPat (FunPatTuple []) = "[]"+showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]"++instance Show FunPat where show = showFunPat++showDeconsInfoExp :: DeconsInfoExp -> String+showDeconsInfoExp dcs = "{" ++ unwords (map showDeconsClause dcs) ++ "}"++showDeconsClause :: (String, Expression, [(PrimePat, Expression)]) -> String+showDeconsClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDeconsClause2 dc2s) ++ "})"++showDeconsClause2 :: (PrimePat, Expression) -> String+showDeconsClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"++showPrimePat :: PrimePat -> String+showPrimePat PrimeWildCard = "_"+showPrimePat (PrimePatVar name) = "$" ++ name+showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">"+showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">"+showPrimePat EmptyPat = "{}"+showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}"+showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}"++instance Show PrimePat where show = showPrimePat++showMatchClause :: MatchClause -> String+showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"++instance Show MatchClause where show = showMatchClause++showFrame :: Frame -> String+showFrame (Frame assocs) =+ let vars = map fst assocs in+ "[" ++ unwords vars ++ "]"++instance Show Frame where show = showFrame++showFrames :: [Frame] -> String+showFrames frames = "[" ++ unwordsList frames ++ "]"
+ LICENSE view
@@ -0,0 +1,18 @@+Copyright (c) 2011, Satoshi Egi++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the Software+is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,+INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR+A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE+OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ egison.cabal view
@@ -0,0 +1,68 @@+-- egison.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: egison++-- 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.1++-- A short (one-line) description of the package.+Synopsis: Programming Language Egison++-- A longer description of the package.+Description: Feature of this programming language is the strong+ pattern match facility. This package include sample Egison programming+ codes "*-test.egi" in "sample/" directory. You can download ELisp file+ "egison-mode.el" from the home page of Egison.++-- URL for the project homepage or repository.+Homepage: http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/++-- The license under which the package is released.+License: MIT++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Satoshi Egi++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: egisatoshi@gmail.com++-- A copyright notice.+-- Copyright: ++Category: Compilers/Interpreters++Build-type: Simple++Data-Dir: sample++Data-files: nat-test.egi list-test.egi++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.4+++Executable egison+ -- .hs or .lhs file containing the Main module.+ Main-is: Egison.hs+ + -- Packages needed in order to build this package.+ Build-depends: base >= 4.0 && < 5, haskell98, mtl, parsec+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +
+ sample/list-test.egi view
@@ -0,0 +1,429 @@+(define $Something+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ }))++(define $Suit+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[spade []+ {[<spade> {[]}]+ [_ {}]}]+ [heart []+ {[<heart> {[]}]+ [_ {}]}]+ [club []+ {[<club> {[]}]+ [_ {}]}]+ [diamond []+ {[<diamond> {[]}]+ [_ {}]}]+ })]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Card Card]+ {[[<spade> <spade>] <true>]+ [[<heart> <heart>] <true>]+ [[<club> <club>] <true>]+ [[<diamond> <diamond>] <true>]+ [[_ _] <false>]}))]+ }))++(test (match-map <club> Suit [<club> <ok>]))++(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[<o> {[]}]+ [_ {}]+ }]+ [s [Nat]+ {[<s $x> {x}]+ [_ {}]+ }]+ })]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Nat Nat]+ {[[<o> <o>] <true>]+ [[<s $n1> <s $n2>] (= n1 n2)]+ [[_ _] <false>]}))]+ }))++(define $monus+ (lambda [$m $n]+ (match [m n] [Nat Nat]+ {[[_ <o>] m]+ [[<o> _] <o>]+ [[<s $m1> <s $n1>] (monus m1 n1)]})))++(test (monus <s <s <o>>> <s <o>>))++(define $mod+ (lambda [$m $n]+ (match (monus m n) Nat+ {[<o> m]+ [$m1 (mod m1 n)]})))++(test (mod <s <s <s <s <o>>>>> <s <s <s <o>>>>))++(define $Mod+ (lambda [$m]+ (let {[$Loop+ (type {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[<o> {[]}]+ [_ {}]+ }]+ [s [Loop]+ {[<s $x> {x}]+ [<o> {m}]+ }]})]+ [$= (lambda [$val $tgt]+ ((type-ref Nat =) (mod val m) tgt))]})]}+ (type+ {[$var-match (lambda [$tgt] {(mod tgt m)})]+ [$inductive-match+ (lambda [$tgt]+ ((type-ref Loop inductive-match) (mod tgt m)))]+ [$= (lambda [$val $tgt]+ ((type-ref Nat =) (mod val m) (mod tgt m)))]}))))++(test (match <s <s <s <s <o>>>>> (Mod <s <s <s <o>>>>)+ {[<o> <not-ok>]+ [<s <o>> <ok>]+ [<s <s <o>>> <not-ok>]}))++(define $List+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (List a)]+ {[{$x .$xs} {[x xs]}]+ [_ {}]+ }]+ [snoc [a (List a)]+ {[{.$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))]+ }]+ [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))]+ }]+ })]+ [$= (lambda [$val $tgt]+ (match [val tgt] [(List a) (List a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons (on [$x] ,x) (on [$xs] ,xs)>]+ <true>]+ [[_ _] <false>]}))]+ })))++(test ((type-ref (List Nat) =) {<o> <s <o>>} {<o> <s <o>>}))++(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<snoc $x $xs> [x xs]]))++(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<nioj $xs $ys> [xs ys]]))++(define $map+ (lambda [$fn $ls]+ (match ls (List Something)+ {[<nil> {}]+ [<cons $x $xs> {(fn x) @(map fn xs)}]})))++(test (map (lambda [$a] <s a>) {<o> <s <o>>}))++(test (match {} (List Something)+ {[<join $hs $ts> [hs ts]]}))++(test (match-map {<x> <y>} (List Something)+ [<join $hs $ts> [hs ts]]))++(test (match-map {<x> <y> <z> <w>} (List Something)+ [<join $hs <cons $x $ts>> [hs x ts]]))++(define $remove+ (lambda [$a]+ (lambda [$xs $x]+ (match xs (List a)+ {[<nil> {}]+ [<cons x $rs> rs]+ [<cons $y $rs> {y @((remove a) rs x)}]}))))++(test ((remove Nat) {<o> <s <o>>} <o>))++(define $remove-collection+ (lambda [$a]+ (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> xs]+ [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))++(test ((remove-collection Nat) {<o> <s <o>> <s <s <o>>>} {<o> <s <s <o>>>}))++(define $subcollection+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {{}}]+ [<cons $x $rs>+ (let {[$subs (subcollection rs)]}+ {@subs @(map (lambda [$sub] {x @sub})+ subs)})]+ })))++(test (subcollection {<o> <s <o>> <s <s <o>>>}))++(define $Multiset+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (Multiset a)]+ {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])+ tgt)]+ }]+ [join [(Multiset a) (Multiset a)]+ {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])+ (subcollections tgt))]+ }]+ })]+ [$= (lambda [$val $tgt]+ (match [val tgt] [(Multiset a) (Multiset a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons (on [$x] x) (on [$xs] xs)>]+ <true>]+ [[_ _] <false>]}))]+ })))++(define $one-pair+ (lambda [$ns]+ (match ns (Multiset Nat)+ {[<cons $m+ <cons (on [$m] m)+ _>>+ <ok>]+ [_ <nothing>]+ })))++(test (one-pair {<o> <s <o>> <o>}))++(define $full-house+ (lambda [$ns]+ (match ns (Multiset Nat)+ {[<cons $m+ <cons (on [$m] m)+ <cons (on [$m] m)+ !<cons $n+ !<cons (on [$n] n)+ !<nil>+ >>>>>+ <full-house>]+ [_ <nothing>]+ })))++(test (full-house {<o> <o> <s <o>> <o> <s <o>>}))++(define $thirteen <s <s <s <s <s <s <s <s <s <s <s <s <s <o>>>>>>>>>>>>>>)++(define $Card+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[card [Suit (Mod thirteen)]+ {[<card $s $n> {[s n]}]}]})]+ [$= <undefined>]}))++(define $poker-hands+ (lambda [$Cs]+ (match Cs (Multiset Card)+ {[<cons <card $S $n>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>+ !<nil>+ >>>>>+ <straight-flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <four-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ !<cons <card _ (on [$n] ,n)>+ !<nil>+ >>>>>+ <full-house>]+ [<cons <card $S _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<nil>+ >>>>>+ <flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,(- n 1))>+ <cons <card _ (on [$n] ,(- n 2))>+ <cons <card _ (on [$n] ,(- n 3))>+ <cons <card _ (on [$n] ,(- n 4))>+ !<nil>+ >>>>>+ <straight>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <three-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <two-pair>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <one-pair>]+ [<cons _+ !<cons _+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <nothing>]})))++(define $poker-hands-without-strait+ (lambda [$Cs]+ (match Cs (Multiset Card)+ {[<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <four-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ !<cons <card _ (on [$n] ,n)>+ !<nil>+ >>>>>+ <full-house>]+ [<cons <card $S _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<nil>+ >>>>>+ <flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <three-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <two-pair>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <one-pair>]+ [<cons _+ !<cons _+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <nothing>]})))++(test (poker-hands-without-strait {<card <diamond> <o>>+ <card <club> <s <o>>>+ <card <club> <o>>+ <card <heart> <o>>+ <card <diamond> <s <o>>>}))++(define $car+ (lambda [$as]+ (match as (List Something)+ {[<cons $a _> a]})))++(define $reverse+ (lambda [$as]+ (match as (List Something)+ {[<nil> {}]+ [<cons $a $rs>+ {@(reverse rs) a}]})))
+ sample/nat-test.egi view
@@ -0,0 +1,78 @@+(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[<o> {[]}]+ [_ {}]+ }]+ [s [Nat]+ {[<s $x> {x}]+ [_ {}]+ }]+ })]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Nat Nat]+ {[[<o> <o>] <true>]+ [[<s $n1> <s $n2>] (= n1 n2)]+ [[_ _] <false>]}))]+ }))++(test ((type-ref Nat =) <o> <o>))++(define $++ (lambda [$m $n]+ (match m Nat+ {[<o> n]+ [<s $m1> <s (+ m1 n)>]})))++(define $*+ (lambda [$m $n]+ (match m Nat+ {[<o> <o>]+ [<s <o>> n]+ [<s $m1> (+ n (* m1 n))]})))+ +(define $fact+ (lambda [$n]+ (match n Nat+ {[<o> <s <o>>]+ [<s $n1> (* n (fact n1))]})))++(test (fact <s <s <s <o>>>>))++(define $fib+ (lambda [$n]+ (match n Nat+ {[<o> <s <o>>]+ [<s <o>> <s <o>>]+ [<s <s $n1>> (+ (fib <s n1>) (fib n1))]})))++(test (fib <s <s <s <s <s <s <o>>>>>>>))++(define $val-match-test+ (lambda [$n]+ (match n Nat+ {[,(+ <s <o>> <s <s <o>>>) <ok>]+ [$n1 n1]})))++(test (val-match-test <s <s <s <o>>>>))++(define $on-pat-test+ (lambda [$m $n]+ (match [m n] [Nat Nat]+ {[[$m1 (on [$m1] <s m1>)] m1]+ [[_ _] <not-ok>]})))++(test (on-pat-test <o> <s <o>>))++(define $on-pat-test2+ (lambda [$m $n]+ (match [m n] [Nat Nat]+ {[[$m1 <s (on [$m1] m1)>] m1]+ [[_ _] <not-ok>]})))++(test (on-pat-test2 <o> <s <o>>))+