egison-0.1: Egison.hs
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 ++ "]"