egison-0.3.0.2: Egison.hs
module Main where
import System.Environment
import Control.Monad.Error
import Data.IORef
import Text.Parsec hiding (spaces)
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellDef)
import IO hiding (try)
welcomeMsg :: String
welcomeMsg = "Egison, version 0.3.0.2 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"
byebyeMsg :: String
byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n"
main :: IO ()
main = do args <- getArgs
case length args of
0 -> do flushStr welcomeMsg
defsRef <- newIORef []
runRepl defsRef
_ -> putStrLn "Program takes only 0 argument!"
type Definitions = IORef [(String, Expression)]
runRepl :: Definitions -> IO ()
runRepl defs = do input <- (readPrompt "> ")
case input of
Eof -> flushStr byebyeMsg
Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defs) >>= flushStr >> runRepl defs
-- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs
readPrompt :: String -> IO Input
readPrompt prompt = flushStr prompt >> getExpression
flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout
data Input = Input String
| Eof
getExpression :: IO Input
getExpression = catch (do str <- getExpressionHelper False 0
return (Input str))
(\_ -> return Eof)
getExpressionHelper :: Bool -> Integer -> IO String
getExpressionHelper b n = do c <- getChar
case c of
'(' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
'<' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
'[' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
'{' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
')' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
'>' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
']' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
'}' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
'\n' -> if n > 0
then do l <- getExpressionHelper b n
return (c : l)
else if b
then return "\n"
else getExpressionHelper b n
' ' -> do l <- getExpressionHelper b n
return (c : l)
'\t' -> do l <- getExpressionHelper b n
return (c : l)
_ -> do l <- getExpressionHelper True n
return (c : l)
type IOThrowsError = ErrorT EgiError IO
data EgiError = Parser ParseError
| UnboundVariable String
| WithTopExpression String Expression
| WithExpression String Expression
| Default String
showError :: EgiError -> String
showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n"
showError (UnboundVariable name) = "Error : unbound variable : " ++ name ++ "\n"
showError (WithTopExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"
showError (WithExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"
showError (Default str) = "Error : " ++ str ++ "\n"
instance Show EgiError where show = showError
instance Error EgiError where
noMsg = Default "An error has occured"
strMsg = Default
type ThrowsError = Either EgiError
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val
runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runErrorT (trapError action) >>= return . extractValue
trapError :: (MonadError e m, Show e) => m String -> m String
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
readTopExpression :: String -> IOThrowsError TopExpression
readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr)
readTopExpressionList :: String -> IOThrowsError [TopExpression]
readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str)
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "egison" input of
Left err -> throwError (Parser err)
Right val -> return val
executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String
executeTopExpression defs (Define name expr) = do
liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))
return (name ++ "\n")
executeTopExpression defs (Test expr) = do
topFrame <- makeTopFrame defs
val <- eval (Environment [topFrame]) expr
ret <- liftIO (showValue val)
return (ret ++ "\n")
executeTopExpression defs (Load filename) = do
str <- liftIO (readFile filename)
topExprs <- readTopExpressionList str
let loop topExprs2 = case topExprs2 of
[] -> return (filename ++ " loaded\n")
topExpr:rest -> do executeTopExpression defs topExpr
loop rest
in loop topExprs
executeTopExpression defs Execute = do
topFrame <- makeTopFrame defs
mainFn <- eval (Environment [topFrame]) (SymbolExp "main")
args <- liftIO (newIORef (Value (World [])))
case mainFn of
Function funEnv fpat body
-> do frame <- makeFrame fpat args
iValRef <- liftIO (makeClosure (addFrame frame funEnv) body)
forceRecursively iValRef
return ""
_ -> throwError (Default "main is not function" )
--
-- Data Types
--
data TopExpression = Define String Expression
| Test Expression
| Load String
| Execute
data Expression = CharacterExp Char
| StringExp String
| IntegerExp Integer
| DoubleExp Double
| SymbolExp String
| InductiveDataExp String [Expression]
| TupleExp [Expression]
| CollectionExp [InnerExp]
| PatternExp PatternExp
| FunctionExp FunPat Expression
| WithExp String Expression
| DoExp Bind Expression
| LetExp RecursiveBind Expression
| TypeExp RecursiveBind
| TypeRefExp Expression String
| DeconstructorExp DeconsInfoExp
| MatchExp Expression Expression [MatchClause]
| MatchAllExp Expression Expression MatchClause
| ApplyExp Expression Expression
data InnerExp = ElementExp Expression
| SubCollectionExp Expression
data PatternExp = WildCardExp
| PatVarExp String
| CutPatExp Expression
| AsPatExp String Expression
| OfPatExp Expression
| ValPatExp Expression
data FunPat = FunPatVar String
| FunPatTuple [FunPat]
type Bind = [(FunPat, Expression)]
type RecursiveBind = [(String, Expression)]
type DeconsInfoExp = [(String, Expression, [(PrimePat, Expression)])]
data MatchClause = MatchClause Expression Expression
data PrimePat = PrimeWildCard
| PrimePatCharacter Char
| PrimePatInteger Integer
| PrimePatDouble Double
| PrimePatVar String
| InductivePrimePat String [PrimePat]
| TuplePrimePat [PrimePat]
| EmptyPat
| ConsPat PrimePat PrimePat
| SnocPat PrimePat PrimePat
type Association = (String, IORef IntermidiateValue)
data Frame = Frame [Association]
data Environment = Environment [Frame]
data IntermidiateValue = Closure Environment Expression
| Value Value
data Value = World [Action]
| Character Char
| Integer Integer
| Double Double
| InductiveData String [IORef IntermidiateValue]
| Tuple [IORef IntermidiateValue]
| Collection [InnerValue]
| Pattern Pattern
| Function Environment FunPat Expression
| Type Frame
| Deconstructor (IORef IntermidiateValue) DeconsInfo
| DeconstructorFunction DeconsInfo
| BuiltinFunction ([Value] -> IOThrowsError Value)
data Action = Read Value
| Write Value
| Memorize Value
| Remember Value
data InnerValue = Element (IORef IntermidiateValue)
| SubCollection (IORef IntermidiateValue)
data Pattern = WildCard
| PatVar String
| CutPat (IORef IntermidiateValue)
| AsPat String (IORef IntermidiateValue)
| OfPat [IORef IntermidiateValue]
| ValPat Environment Expression
type DeconsInfo = [(String, IORef IntermidiateValue, [(Environment, PrimePat, Expression)])]
--
-- Parser
--
lexer = P.makeTokenParser haskellDef
charLiteral = P.charLiteral lexer
stringLiteral = P.stringLiteral lexer
integer = P.integer lexer
float = P.float lexer
parens = P.parens lexer
angles = P.angles lexer
brackets = P.brackets lexer
braces = P.braces lexer
headSymbol :: Parser Char
headSymbol = oneOf ":+-*/="
restSymbol :: Parser Char
restSymbol = oneOf "!?:+-*/="
word :: Parser String
word = do first <- (letter <|> headSymbol)
rest <- many (letter <|> digit <|> restSymbol)
return (first:rest)
spaces :: Parser ()
spaces = skipMany (oneOf " \n\t")
spaces1 :: Parser ()
spaces1 = skipMany1 (oneOf " \n\t")
parseTopExpression :: Parser TopExpression
parseTopExpression = do spaces
parens (do try (string "define")
spaces
char '$'
name <- word
spaces
expr <- parseExpression
return (Define name expr)
<|> do try (string "test")
spaces
expr <- parseExpression
spaces
return (Test expr)
<|> do try (string "execute")
return Execute
<|> do try (string "load")
spaces
filename <- stringLiteral
spaces
return (Load filename)
) <?> "top expression"
parseExpression :: Parser Expression
parseExpression = do ws <- word
return (SymbolExp ws)
<|> do c <- charLiteral
return (CharacterExp c)
<|> do str <- stringLiteral
return (StringExp str)
<|> do d <- try float
return (DoubleExp d)
<|> do n <- try integer
return (IntegerExp n)
<|> angles (do c <- word
spaces
vs <- sepEndBy parseExpression spaces
return (InductiveDataExp c vs))
<|> brackets (do vs <- sepEndBy parseExpression spaces
return (TupleExp vs))
<|> braces (do vs <- sepEndBy parseInnerExp spaces
return (CollectionExp vs))
<|> try (do pat <- parsePatternExp
return (PatternExp pat))
<|> parens (do try (do string "lambda"
spaces1)
args <- parseFunPat
spaces
body <- parseExpression
return (FunctionExp args body)
<|> do try (do string "with"
spaces1)
char '$'
name <- word
spaces
expr <- parseExpression
return (WithExp name expr)
<|> do try (do string "do"
spaces1)
bind <- parseBind
spaces
body <- parseExpression
return (DoExp bind body)
<|> do try (do string "let"
spaces1)
bind <- parseRecursiveBind
spaces
body <- parseExpression
return (LetExp bind body)
<|> do try (do string "type"
spaces1)
bind <- parseRecursiveBind
return (TypeExp bind)
<|> do try (do string "type-ref"
spaces1)
typ <- parseExpression
spaces
name <- word
return (TypeRefExp typ name)
<|> do try (do string "deconstructor"
spaces1)
deconsInfo <- parseDeconsInfoExp
return (DeconstructorExp deconsInfo)
<|> do try (do string "match"
spaces1)
tgt <- parseExpression
spaces
typ <- parseExpression
spaces
clss <- braces (sepEndBy parseMatchClause spaces)
return (MatchExp tgt typ clss)
<|> do try (do string "match-all"
spaces1)
tgt <- parseExpression
spaces
typ <- parseExpression
spaces
cls <- parseMatchClause
spaces
return (MatchAllExp tgt typ cls)
<|> do try (do string "apply"
spaces1)
fn <- parseExpression
spaces
args <- parseExpression
return (ApplyExp fn args)
<|> do fn <- parseExpression
spaces
args <- sepEndBy parseExpression spaces
return (ApplyExp fn (TupleExp args)))
parseInnerExp :: Parser InnerExp
parseInnerExp = do v <- parseExpression
return (ElementExp v)
<|> do char '@'
v <- parseExpression
return (SubCollectionExp v)
parseFunPat :: Parser FunPat
parseFunPat = do char '$'
name <- word
return (FunPatVar name)
<|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces))
case fpats of
[fpat] -> return fpat
_ -> return (FunPatTuple fpats))
parseBind :: Parser Bind
parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat
spaces
expr <- parseExpression
return (fpat, expr)))
spaces
return bs)
parseRecursiveBind :: Parser RecursiveBind
parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$'
var <- word
spaces
expr <- parseExpression
return (var, expr)))
spaces
return bs)
parseDeconsInfoExp :: Parser DeconsInfoExp
parseDeconsInfoExp = braces (sepEndBy parseDeconsClause spaces)
parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)])
parseDeconsClause = brackets (do patCons <- word
spaces
typExpr <- parseExpression
spaces
dc2s <- braces (sepEndBy parseDeconsClause2 spaces)
return (patCons, typExpr, dc2s))
parseDeconsClause2 :: Parser (PrimePat, Expression)
parseDeconsClause2 = brackets (do datPat <- parsePrimePat
spaces
expr <- parseExpression
return (datPat, expr))
parsePrimePat :: Parser PrimePat
parsePrimePat = do char '_'
return PrimeWildCard
<|> do c <- try charLiteral
return (PrimePatCharacter c)
<|> do d <- try float
return (PrimePatDouble d)
<|> do n <- try integer
return (PrimePatInteger n)
<|> do char '$'
name <- word
return (PrimePatVar name)
<|> angles (do c <- word
spaces
ps <- sepEndBy parsePrimePat spaces
return (InductivePrimePat c ps))
<|> brackets (do ps <- sepEndBy parsePrimePat spaces
return (TuplePrimePat ps))
<|> try (do char '{'
spaces
char '}'
return EmptyPat)
<|> try (do char '{'
spaces
a <- parsePrimePat
spaces
char '.'
b <- parsePrimePat
char '}'
return (ConsPat a b))
<|> try (do char '{'
spaces
char '.'
a <- parsePrimePat
spaces
b <- parsePrimePat
char '}'
return (SnocPat a b))
parseMatchClause :: Parser MatchClause
parseMatchClause = brackets (do pat <- parseExpression
spaces
body <- parseExpression
return (MatchClause pat body))
parsePatternExp :: Parser PatternExp
parsePatternExp = do char '_'
return WildCardExp
<|> do char '$'
name <- word
return (PatVarExp name)
<|> do char '!'
expr <- parseExpression
return (CutPatExp expr)
<|> do char ','
expr <- parseExpression
return (ValPatExp expr)
<|> parens (do try (do string "as"
spaces1)
char '$'
name <- word
spaces
expr <- parseExpression
return (AsPatExp name expr)
<|> do try (do string "of"
spaces1)
expr <- parseExpression
return (OfPatExp expr)
)
--
-- Environment
--
getValueFromFrame :: Frame -> String -> Maybe (IORef IntermidiateValue)
getValueFromFrame (Frame []) _ = Nothing
getValueFromFrame (Frame ((var, iValRef):rest)) name =
if name == var
then Just iValRef
else getValueFromFrame (Frame rest) name
getValue :: Environment -> String -> Maybe (IORef IntermidiateValue)
getValue (Environment []) name = Nothing
getValue (Environment (frame : env)) name =
let mValRef = getValueFromFrame frame name in
case mValRef of
Nothing -> getValue (Environment env) name
Just iValRef -> Just iValRef
makeClosure :: Environment -> Expression -> IO (IORef IntermidiateValue)
makeClosure env expr = newIORef (Closure env expr)
makeClosureList :: Environment -> [Expression] -> IO [IORef IntermidiateValue]
makeClosureList _ [] = return []
makeClosureList env (expr : exprs) = do
iVal <- makeClosure env expr
iVals <- makeClosureList env exprs
return (iVal:iVals)
makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue]
makeClosureInnerVals _ [] = return []
makeClosureInnerVals env (ElementExp expr : rest) = do
iValRef <- makeClosure env expr
innerValRefs <- makeClosureInnerVals env rest
return (Element iValRef : innerValRefs)
makeClosureInnerVals env (SubCollectionExp expr : rest) = do
iValRef <- makeClosure env expr
innerValRefs <- makeClosureInnerVals env rest
return (SubCollection iValRef : innerValRefs)
makeDeconsInfo :: Environment -> DeconsInfoExp -> IO DeconsInfo
makeDeconsInfo _ [] = return []
makeDeconsInfo env ((cons, typeExp, dcs):deconsInfoExp) = do
typeIValRef <- makeClosure env typeExp
let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in
do deconsInfo <- makeDeconsInfo env deconsInfoExp
return ((cons, typeIValRef, dcs2):deconsInfo)
makeFrame :: FunPat -> IORef IntermidiateValue -> IOThrowsError Frame
makeFrame (FunPatVar name) iValRef = do
return (Frame [(name, iValRef)])
makeFrame (FunPatTuple []) iValRef = do
val <- force iValRef
case val of
Tuple [] -> return (Frame [])
_ -> throwError (Default "invalid number of argument")
makeFrame (FunPatTuple fpats) iValRef = do
val <- force iValRef
let loop fpats2 iValRefs2 = case (fpats2, iValRefs2) of
([], []) -> return (Frame [])
((fpat2:fps), (iValRef2:ivrs)) -> do frame1 <- makeFrame fpat2 iValRef2
frame2 <- loop fps ivrs
return (appendFrames frame1 frame2)
(_, _) -> throwError (Default "invalid number of argument") in
case val of
Tuple iValRefs2 -> loop fpats iValRefs2
_ -> loop fpats [iValRef]
makeFrameMap :: FunPat -> [IORef IntermidiateValue] -> IOThrowsError [Frame]
makeFrameMap _ [] = return []
makeFrameMap fpat (iValRef:iValRefs) = do
frame <- makeFrame fpat iValRef
frames <- makeFrameMap fpat iValRefs
return (frame:frames)
appendFrames :: Frame -> Frame -> Frame
appendFrames (Frame frame1) (Frame frame2) = Frame (frame1 ++ frame2)
makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame
makeRecursiveFrame env bind =
let vars = map fst bind in
let exprs = map snd bind in
do iValRefs <- liftIO (makeClosureList (Environment []) exprs)
let newFrame = Frame (zip vars iValRefs) in
do liftIO (makeRecursiveFrameHelper env newFrame newFrame)
return newFrame
makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO ()
makeRecursiveFrameHelper _ _ (Frame []) = return ()
makeRecursiveFrameHelper env newFrame (Frame ((_, iValRef):assocs)) = do
iVal <- readIORef iValRef
case iVal of
(Closure _ expr) -> writeIORef iValRef (Closure (addFrame newFrame env) expr)
makeRecursiveFrameHelper env newFrame (Frame assocs)
makeTopFrame :: Definitions -> IOThrowsError Frame
makeTopFrame defsRef = do
defs <- liftIO (readIORef defsRef)
makeRecursiveFrame (Environment []) defs
addFrame :: Frame -> Environment -> Environment
addFrame frame (Environment frames) = Environment (frame:frames)
--
-- read and show Value
--
readValue :: String -> IOThrowsError Value
readValue exprStr = do
expr <- readExpression exprStr
expressionToValue expr
readExpression :: String -> IOThrowsError Expression
readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr)
expressionToValue :: Expression -> IOThrowsError Value
expressionToValue (CharacterExp c) = return (Character c)
expressionToValue (StringExp str) = do
val <- liftIO (makeCollectionFromValueList (map Character str))
return val
expressionToValue (IntegerExp n) = return (Integer n)
expressionToValue (DoubleExp d) = return (Double d)
expressionToValue (InductiveDataExp con exprs) = do
vals <- expressionToValueMap exprs
iValRefs <- liftIO (valListToIValRefList vals)
return (InductiveData con iValRefs)
expressionToValue (TupleExp exprs) = do
vals <- expressionToValueMap exprs
case vals of
[val] -> return val
_ -> do iValRefs <- liftIO (valListToIValRefList vals)
return (Tuple iValRefs)
expressionToValue (CollectionExp innerExps) = do
innerVals <- innerExpToInnerValueMap innerExps
return (Collection innerVals)
expressionToValue expr@(PatternExp _) = throwError (WithExpression "not implemented yet :" expr)
expressionToValue expr = throwError (WithExpression "read expression is not value :" expr)
expressionToValueMap :: [Expression] -> IOThrowsError [Value]
expressionToValueMap [] = return []
expressionToValueMap (expr:exprs) = do
val <- expressionToValue expr
vals <- expressionToValueMap exprs
return (val:vals)
innerExpToInnerValueMap :: [InnerExp] -> IOThrowsError [InnerValue]
innerExpToInnerValueMap [] = return []
innerExpToInnerValueMap (ElementExp expr:rest) = do
val <- expressionToValue expr
iValRef <- liftIO (newIORef (Value val))
innerVals <- innerExpToInnerValueMap rest
return (Element iValRef:innerVals)
innerExpToInnerValueMap (SubCollectionExp expr:rest) = do
val <- expressionToValue expr
iValRef <- liftIO (newIORef (Value val))
innerVals <- innerExpToInnerValueMap rest
return (SubCollection iValRef:innerVals)
showValue :: Value -> IO String
showValue (World _) = return "#<world>"
showValue (Character c) = return (show c)
showValue (Integer n) = return (show n)
showValue (Double d) = return (show d)
showValue (InductiveData cons []) = do
return ("<" ++ cons ++ ">")
showValue (InductiveData cons iValRefs) = do
vals <- iValRefListToValueList iValRefs
str <- unwordsVals vals
return ("<" ++ cons ++ " " ++ str ++ ">")
showValue (Tuple []) = do
return ("[]")
showValue (Tuple iValRefs) = do
vals <- iValRefListToValueList iValRefs
str <- unwordsVals vals
return ("[" ++ str ++ "]")
showValue (Collection []) = do
return ("{}")
showValue (Collection innerVals) = do
vals <- collectionToValueList (Collection innerVals)
str <- unwordsVals vals
return ("{" ++ str ++ "}")
showValue (Pattern patVal) = do
showPattern patVal
showValue (Function _ _ _) = do
return "#<function>"
showValue (Type _) = do
return "#<type>"
showValue (DeconstructorFunction _) = do
return "#<deconstructor-function>"
showValue (Deconstructor _ _) = do
return "#<deconstructor>"
showValue (BuiltinFunction _) = do
return "#<builtin-function>"
showPattern :: Pattern -> IO String
showPattern WildCard = return "_"
showPattern (PatVar name) = return ("$" ++ name)
showPattern (CutPat _) = return "#<cut-pat>"
showPattern (AsPat _ _) = return "#<as-pat>"
showPattern (OfPat _) = return "#<of-pat>"
showPattern (ValPat _ _) = return "#<val-pat>"
unwordsList :: Show a => [a] -> String
unwordsList = unwords . map show
unwordsVals :: [Value] -> IO String
unwordsVals [] = return ""
unwordsVals (val:vals) = do
s1 <- showValue val
s2 <- unwordsValsHelper vals
return (s1 ++ s2)
unwordsValsHelper :: [Value] -> IO String
unwordsValsHelper [] = return ""
unwordsValsHelper (val:vals) = do
s1 <- showValue val
s2 <- unwordsValsHelper vals
return (" " ++ s1 ++ s2)
--
-- Eval
--
force :: IORef IntermidiateValue -> IOThrowsError Value
force iValRef = do
iVal <- liftIO (readIORef iValRef)
case iVal of
Closure env expr -> do val <- eval1 env expr
liftIO (writeIORef iValRef (Value val))
return val
Value val -> return val
eval1 :: Environment -> Expression -> IOThrowsError Value
eval1 _ (CharacterExp c) = return (Character c)
eval1 _ (StringExp str) = do
val <- liftIO (makeCollectionFromValueList (map Character str))
return val
eval1 _ (IntegerExp n) = return (Integer n)
eval1 _ (DoubleExp d) = return (Double d)
eval1 env (SymbolExp name) =
let mIValRef = getValue env name in
case mIValRef of
Just iValRef -> force iValRef
Nothing -> let mBuiltinFn = getBuiltin name in
case mBuiltinFn of
Just builtinFn -> return (BuiltinFunction builtinFn)
Nothing -> throwError (UnboundVariable name)
eval1 env (InductiveDataExp con exprs) = do
iValRefs <- liftIO (makeClosureList env exprs)
return (InductiveData con iValRefs)
eval1 env (TupleExp exprs) = do
iValRefs <- liftIO (makeClosureList env exprs)
case iValRefs of
[iValRef] -> do force iValRef
_ -> return (Tuple iValRefs)
eval1 env (CollectionExp innerExps) = do
innerVals <- liftIO (makeClosureInnerVals env innerExps)
return (Collection innerVals)
eval1 env (PatternExp patExp) = evalPattern1 env patExp
eval1 env (FunctionExp args body) = return (Function env args body)
eval1 env (WithExp name expr) = eval1 env (LetExp [(name, expr)] (SymbolExp name))
eval1 env (DoExp [] body) = eval1 env body
eval1 env (DoExp ((fpat,expr):assocs) body) = do
iValRef <- liftIO (makeClosure env expr)
frame <- makeFrame fpat iValRef
eval1 (addFrame frame env) (DoExp assocs body)
eval1 env (LetExp bind body) = do
frame <- makeRecursiveFrame env bind
iValRef <- liftIO (newIORef (Closure (addFrame frame env) body))
force iValRef
eval1 env (TypeExp bind) = do
frame <- makeRecursiveFrame env bind
return (Type frame)
eval1 env expr@(TypeRefExp typExp name) = do
typVal <- eval1 env typExp
case typVal of
(Type frame) -> let mIValRef = getValueFromFrame frame name in
case mIValRef of
Nothing -> throwError (WithExpression ("no method in type : " ++ name) expr)
Just iValRef -> do val <- force iValRef
return val
_ -> throwError (WithExpression "first arg of typeref is not type :" expr)
eval1 env (DeconstructorExp deconsInfoExp) = do
deconsInfo <- liftIO (makeDeconsInfo env deconsInfoExp)
return (DeconstructorFunction deconsInfo)
eval1 env (MatchExp tgtExp typExp mCs) = do
typIVal <- liftIO (makeClosure env typExp)
tgtIVal <- liftIO (makeClosure env tgtExp)
forceMatchExp env typIVal tgtIVal mCs
eval1 env (MatchAllExp tgtExp typExp mC) = do
typIVal <- liftIO (makeClosure env typExp)
tgtIVal <- liftIO (makeClosure env tgtExp)
forceMatchAllExp env typIVal tgtIVal mC
eval1 env expr@(ApplyExp fnExp argsExp) = do
fnVal <- eval1 env fnExp
argsIValRef <- liftIO (makeClosure env argsExp)
case fnVal of
BuiltinFunction builtinFn -> do argsVal <- forceRecursively argsIValRef
argsVals <- liftIO (tupleToValueList argsVal)
builtinFn argsVals
Function funEnv fpat body -> do frame <- makeFrame fpat argsIValRef
iValRef <- liftIO (makeClosure (addFrame frame funEnv) body)
force iValRef
DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo)
_ -> throwError (WithExpression "applying non-functional object :" expr)
evalPattern1 :: Environment -> PatternExp -> IOThrowsError Value
evalPattern1 _ WildCardExp = return (Pattern WildCard)
evalPattern1 _ (PatVarExp name) = return (Pattern (PatVar name))
evalPattern1 env (CutPatExp expr) = do
iValRef <- liftIO (makeClosure env expr)
return (Pattern (CutPat iValRef))
evalPattern1 env (AsPatExp var expr) = do
iValRef <- liftIO (makeClosure env expr)
return (Pattern (AsPat var iValRef))
evalPattern1 env (OfPatExp expr) = do
iValRef <- liftIO (makeClosure env expr)
iValRefs <- collectionToList iValRef
return (Pattern (OfPat iValRefs))
evalPattern1 env (ValPatExp expr) = do
return (Pattern (ValPat env expr))
eval :: Environment -> Expression -> IOThrowsError Value
eval env expr = do
iValRef <- liftIO (makeClosure env expr)
val <- force iValRef
forceValue val
return val
forceValue :: Value -> IOThrowsError Value
forceValue (InductiveData cons iValRefs) = do
forceRecursivelyList iValRefs
return (InductiveData cons iValRefs)
forceValue (Tuple iValRefs) = do
forceRecursivelyList iValRefs
return (Tuple iValRefs)
forceValue (Collection innerVals) = do
forceRecursivelyInnerVals innerVals
return (Collection innerVals)
forceValue (Pattern pat) = do
forceRecursivelyPattern pat
return (Pattern pat)
forceValue val = return val
forceRecursively :: IORef IntermidiateValue -> IOThrowsError Value
forceRecursively iValRef = do
val <- force iValRef
forceValue val
forceRecursivelyList :: [IORef IntermidiateValue] -> IOThrowsError ()
forceRecursivelyList [] = return ()
forceRecursivelyList (iValRef:iValRefs) = do
forceRecursively iValRef
forceRecursivelyList iValRefs
forceRecursivelyInnerVals :: [InnerValue] -> IOThrowsError ()
forceRecursivelyInnerVals [] = return ()
forceRecursivelyInnerVals (Element iValRef : rest) = do
forceRecursively iValRef
forceRecursivelyInnerVals rest
forceRecursivelyInnerVals (SubCollection iValRef : rest) = do
forceRecursively iValRef
forceRecursivelyInnerVals rest
forceRecursivelyPattern :: Pattern -> IOThrowsError Pattern
forceRecursivelyPattern WildCard = return WildCard
forceRecursivelyPattern (PatVar var) = return (PatVar var)
forceRecursivelyPattern (CutPat iValRef) = do
forceRecursively iValRef
return (CutPat iValRef)
forceRecursivelyPattern (AsPat var iValRef) = do
forceRecursively iValRef
return (AsPat var iValRef)
forceRecursivelyPattern (OfPat iValRefs) = do
forceRecursivelyList iValRefs
return (OfPat iValRefs)
forceRecursivelyPattern (ValPat onEnv expr) = do
return (ValPat onEnv expr)
---
---
---
forceMatchExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> [MatchClause] -> IOThrowsError Value
forceMatchExp env typIValRef tgtIValRef (MatchClause pat expr:rest) = do
typVals <- tupleToList typIValRef
tgtVals <- tupleToList tgtIValRef
patIValRef <- liftIO (makeClosure env pat)
patVals <- tupleToList patIValRef
matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals
case matchs of
[] -> forceMatchExp env typIValRef tgtIValRef rest
(frame:_) -> do iValRef <- liftIO (makeClosure (addFrame frame env) expr)
force iValRef
forceMatchExp _ _ _ _ = throwError (Default "end of match clause")
forceMatchAllExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value
forceMatchAllExp env typIValRef tgtIValRef (MatchClause pat expr) = do
typVals <- tupleToList typIValRef
tgtVals <- tupleToList tgtIValRef
patIValRef <- liftIO (makeClosure env pat)
patVals <- tupleToList patIValRef
matchs <- patternMatchList [(Frame [])] typVals patVals tgtVals
innerVals <- forceMatchAllExpHelper env matchs expr
return (Collection innerVals)
forceMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue]
forceMatchAllExpHelper _ [] _ = return []
forceMatchAllExpHelper env (frame:frames) expr = do
iValRef <- liftIO (makeClosure (addFrame frame env) expr)
force iValRef
rest <- forceMatchAllExpHelper env frames expr
return (Element iValRef:rest)
patternMatchList :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]
patternMatchList [] _ _ _ = return []
patternMatchList frames [] [] [] = return frames
patternMatchList frames (typRef:typRefs) (patRef:patRefs) (tgtRef:tgtRefs) = do
typVal <- force typRef
patVal <- force patRef
newFrames <- patternMatch frames typVal patVal tgtRef
patternMatchList newFrames typRefs patRefs tgtRefs
patternMatchList _ _ _ _ = throwError (Default "numbers of type, pattern, and target are different")
patternMatchListMap :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]
patternMatchListMap _ _ _ [] = return []
patternMatchListMap frames typesIValRefs patIValRefs (tgtIValRef:rest) = do
tgtIValRefs <- tupleToList tgtIValRef
frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs
frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest
return (frames1 ++ frames2)
patternMatch :: [Frame] -> Value -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame]
patternMatch [] _ _ _ = return []
patternMatch frames _ (Pattern WildCard) _ = return frames
patternMatch frames (Type bind) (Pattern (PatVar var)) tgtIValRef = do
case getValueFromFrame bind "var-match" of
Nothing -> throwError (Default "no var-match")
Just varMatchFnRef -> do varMatchFn <- force varMatchFnRef
case varMatchFn of
Function funEnv fpat body -> do argsFrame <- makeFrame fpat tgtIValRef
iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)
iValRefs <- collectionToList iValRef
newFrames <- makeFrameMap (FunPatVar var) iValRefs
return (connectFrames frames newFrames)
_ -> throwError (Default "not function : var-match")
patternMatch frames (Type bind) (InductiveData cons patIValRefs) tgtIValRef =
case getValueFromFrame bind "inductive-match" of
Nothing -> throwError (Default "no inductive-match")
Just inductiveMatchFnRef
-> do inductiveMatchFn <- force inductiveMatchFnRef
case inductiveMatchFn of
DeconstructorFunction deconsInfo
-> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef
Function funEnv fpat body
-> do argsFrame <- makeFrame fpat tgtIValRef
iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)
val <- force iValRef
case val of
Deconstructor tgtIValRef2 deconsInfo
-> doDeconstruct deconsInfo frames (InductiveData cons patIValRefs) tgtIValRef2
_ -> throwError (Default "not function : inductive-match")
patternMatch (frame:_) typVal (Pattern (CutPat patIValRef)) tgtIValRef = do
patVal <- force patIValRef
patternMatch [frame] typVal patVal tgtIValRef
patternMatch frames typVal (Pattern (AsPat name patIValRef)) tgtIValRef = undefined
patternMatch frames typVal (Pattern (OfPat patIValRefs)) tgtIValRef =
let loop patIValRefs2 = case patIValRefs2 of
[] -> return []
patIValRef:rests -> do patVal <- force patIValRef
newFrames1 <- patternMatch frames typVal patVal tgtIValRef
newFrames2 <- loop rests
return (newFrames1 ++ newFrames2) in
loop patIValRefs
patternMatch frames (Type bind) (Pattern (ValPat onEnv expr)) tgtIValRef = do
case getValueFromFrame bind "equal?" of
Nothing -> throwError (Default "no equal? function")
Just equalFnRef -> do equalFn <- force equalFnRef
case equalFn of
Function funEnv fpat body
-> let loop frames2 = case frames2 of
[] -> return []
(frame:rests)
-> do iValPatRef <- liftIO (makeClosure (addFrame frame onEnv) expr)
argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef])))
argsFrame <- makeFrame fpat argsIValRef
iValRef <- liftIO (makeClosure (addFrame argsFrame funEnv) body)
val <- force iValRef
restFrames <- loop rests
case val of
(InductiveData "true" []) -> return (frame:restFrames)
(InductiveData "false" []) -> return restFrames
_ -> throwError (Default "invalid return value from equal? function") in
loop frames
_ -> throwError (Default "equal? is not function")
patternMatch _ _ _ _ = throwError (Default "invalid pattern : you shold add ',' to the head of value")
doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame]
doDeconstruct [] _ _ _ = throwError (Default "no match decons clause")
doDeconstruct ((pCons, innerTypeIValRef, dcs):deconsInfo) frames (InductiveData cons pats) tgtIValRef =
if pCons == cons
then do innerTypeIValRefs <- tupleToList innerTypeIValRef
let loop dcs2 = case dcs2 of
[] -> throwError (Default "no match primitive pattern")
(env, primePat, expr):rest -> do mFrame <- primitivePatternMatch primePat tgtIValRef
case mFrame of
Nothing -> loop rest
Just pFrame -> do retIValRef <- liftIO (makeClosure (addFrame pFrame env) expr)
retIValRefs <- collectionToList retIValRef
patternMatchListMap frames innerTypeIValRefs pats retIValRefs in
loop dcs
else doDeconstruct deconsInfo frames (InductiveData cons pats) tgtIValRef
doDeconstruct _ _ _ _ = throwError (Default "at doDeconstruct : number of types, patterns, and targets are different")
connectFrames :: [Frame] -> [Frame] -> [Frame]
connectFrames [] _ = []
connectFrames (frame:frames) newFrames =
(map (\newFrame -> (appendFrames frame newFrame)) newFrames) ++ (connectFrames frames newFrames)
---
---
---
primitivePatternMatch :: PrimePat -> IORef IntermidiateValue -> IOThrowsError (Maybe Frame)
primitivePatternMatch PrimeWildCard _ = return (Just (Frame []))
primitivePatternMatch (PrimePatCharacter c) iValRef = do
val <- force iValRef
case val of
Character c2 -> if c == c2
then return (Just (Frame []))
else return Nothing
_ -> throwError (Default "primitive : not character to primitive character pat")
primitivePatternMatch (PrimePatInteger n) iValRef = do
val <- force iValRef
case val of
Integer n2 -> if n == n2
then return (Just (Frame []))
else return Nothing
_ -> throwError (Default "primitive : not integer to primitive integer pat")
--primitivePatternMatch (PrimePatDouble d) iValRef = do
-- val <- force iValRef
-- case val of
-- Integer d2 -> if d == d2
-- then return (Just (Frame []))
-- else return Nothing
-- _ -> throwError (Default "primitive : not double to primitive double pat")
primitivePatternMatch (PrimePatVar name) iValRef = return (Just (Frame [(name, iValRef)]))
primitivePatternMatch (InductivePrimePat pCons pPats) iValRef = do
val <- force iValRef
case val of
InductiveData cons iValRefs -> if pCons == cons
then primitivePatternMatchAll pPats iValRefs
else return Nothing
_ -> throwError (Default "primitive : not inductive value to primitive inductive pattern")
primitivePatternMatch (TuplePrimePat pPats) iValRef = do
val <- force iValRef
case val of
Tuple iValRefs -> primitivePatternMatchAll pPats iValRefs
_ -> throwError (Default "primitive : not tuple value to primitive tuple pattern")
primitivePatternMatch EmptyPat iValRef = do
val <- force iValRef
b <- isEmptyCollection val
if b
then return (Just (Frame []))
else return Nothing
primitivePatternMatch (ConsPat carPat cdrPat) iValRef = do
val <- force iValRef
b <- isEmptyCollection val
if b
then return Nothing
else do (carIValRef, cdrIValRef) <- consDeconstruct val
mCarFrame <- primitivePatternMatch carPat carIValRef
case mCarFrame of
Nothing -> return Nothing
Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrIValRef
case mCdrFrame of
Nothing -> return Nothing
Just cdrFrame -> return (Just (appendFrames carFrame cdrFrame))
primitivePatternMatch (SnocPat rdcPat racPat) iValRef = do
val <- force iValRef
b <- isEmptyCollection val
if b
then return Nothing
else do (racIValRef, rdcIValRef) <- snocDeconstruct val
mRacFrame <- primitivePatternMatch racPat racIValRef
case mRacFrame of
Nothing -> return Nothing
Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcIValRef
case mRdcFrame of
Just rdcFrame -> return (Just (appendFrames racFrame rdcFrame))
Nothing -> return Nothing
primitivePatternMatchAll :: [PrimePat] -> [IORef IntermidiateValue] -> IOThrowsError (Maybe Frame)
primitivePatternMatchAll [] [] = return (Just (Frame []))
primitivePatternMatchAll (pat:pats) (iValRef:iValRefs) = do
mFrame <- primitivePatternMatch pat iValRef
case mFrame of
Nothing -> return Nothing
Just frame -> do mRestFrame <- primitivePatternMatchAll pats iValRefs
case mRestFrame of
Nothing -> return Nothing
Just restFrame -> return (Just (appendFrames frame restFrame))
primitivePatternMatchAll _ _ = throwError (Default "primitivePatternMatchAll : number of patterns and targets are different")
isEmptyCollection :: Value -> IOThrowsError Bool
isEmptyCollection (Collection []) = return True
isEmptyCollection (Collection (Element _:_)) = return False
isEmptyCollection (Collection (SubCollection subRef:rest)) = do
subVal <- force subRef
b <- isEmptyCollection subVal
if b
then isEmptyCollection (Collection rest)
else return False
isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection")
consDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue)
consDeconstruct (Collection (Element eRef:rest)) = do
restRef <- liftIO (newIORef (Value (Collection rest)))
return (eRef, restRef)
consDeconstruct (Collection (SubCollection subRef:rest)) = do
subVal <- force subRef
b <- isEmptyCollection subVal
if b
then consDeconstruct (Collection rest)
else do (carRef, cdrRef) <- consDeconstruct subVal
cdrVal <- force cdrRef
case cdrVal of
Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest))))
return (carRef, restRef)
consDeconstruct (Collection []) = throwError (Default "empty collection")
consDeconstruct _ = throwError (Default "consDeconstruct : not collection")
snocDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue)
snocDeconstruct (Collection innerVals) =
case reverse innerVals of
Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest))))
return (eRef, restRef)
SubCollection subRef:rest
-> do subVal <- force subRef
b <- isEmptyCollection subVal
if b
then snocDeconstruct (Collection (reverse rest))
else do (racRef, rdcRef) <- snocDeconstruct subVal
rdcVal <- force rdcRef
case rdcVal of
Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs))))
return (racRef, restRef)
snocDeconstruct _ = throwError (Default "snocDeconstruct : not collection")
---
---
---
valListToIValRefList :: [Value] -> IO [IORef IntermidiateValue]
valListToIValRefList [] = return []
valListToIValRefList (val:vals) = do
iValRef <- newIORef (Value val)
iValRefs <- valListToIValRefList vals
return (iValRef:iValRefs)
iValRefListToValueList :: [IORef IntermidiateValue] -> IO [Value]
iValRefListToValueList [] = return []
iValRefListToValueList (iValRef:iValRefs) = do
iVal <- readIORef iValRef
case iVal of
Value val -> do vals <- iValRefListToValueList iValRefs
return (val:vals)
tupleToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]
tupleToList iValRef = do
val <- force iValRef
case val of
(Tuple iValRefs) -> return iValRefs
val -> return [iValRef]
tupleToValueList :: Value -> IO [Value]
tupleToValueList (Tuple []) = return []
tupleToValueList (Tuple (iValRef:iValRefs)) = do
val <- readIORef iValRef
case val of
Value val -> do vals <- tupleToValueList (Tuple iValRefs)
return (val:vals)
tupleToValueList val = return [val]
makeTupleFromValueList :: [Value] -> IO Value
makeTupleFromValueList vals = do
iValRefs <- makeIValRefList vals
return (Tuple iValRefs)
makeIValRefList :: [Value] -> IO [IORef IntermidiateValue]
makeIValRefList [] = return []
makeIValRefList (val:vals) = do
iValRef <- newIORef (Value val)
iValRefs <- makeIValRefList vals
return (iValRef:iValRefs)
collectionToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]
collectionToList iValRef = do
val <- force iValRef
let loop val = case val of
(Collection []) -> return []
(Collection (Element eRef:rest)) -> do restRefs <- loop (Collection rest)
return (eRef : restRefs)
(Collection (SubCollection subRef:rest)) -> do valRefs1 <- collectionToList subRef
valRefs2 <- loop (Collection rest)
return (valRefs1 ++ valRefs2)
_ -> throwError (Default "collectionToList : not collection") in
loop val
collectionToValueList :: Value -> IO [Value]
collectionToValueList (Collection []) = return []
collectionToValueList (Collection (Element eRef : rest)) = do
eIVal <- readIORef eRef
case eIVal of
Value e -> do rest <- collectionToValueList (Collection rest)
return (e : rest)
collectionToValueList (Collection (SubCollection subRef : rest)) = do
subIVal <- readIORef subRef
case subIVal of
Value subVal -> do vals1 <- collectionToValueList subVal
vals2 <- collectionToValueList (Collection rest)
return (vals1 ++ vals2)
makeCollectionFromValueList :: [Value] -> IO Value
makeCollectionFromValueList vals =
let loop vals2 = case vals2 of
[] -> return []
(val:rest) -> do iValRef <- newIORef (Value val)
restRefs <- loop rest
return ((Element iValRef):restRefs) in
do innerVals <- loop vals
return (Collection innerVals)
---
--- Builtin Function
---
getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value)
getBuiltin name =
case name of
"read" -> Just builtinRead
"write" -> Just builtinWrite
"read-char" -> Just builtinReadChar
"write-char" -> Just builtinWriteChar
"int-to-float" -> Just builtinIntToFloat
"ceiling" -> Just builtinCeiling
"floor" -> Just builtinFloor
"truncate" -> Just builtinTruncate
"round" -> Just builtinRound
"=" -> Just builtinEqual
"+" -> Just builtinPlus
"-" -> Just builtinMinus
"*" -> Just builtinMultiply
"/" -> Just builtinDevide
"mod" -> Just builtinMod
"=f" -> Just builtinEqualFloat
"+f" -> Just builtinPlusFloat
"-f" -> Just builtinMinusFloat
"*f" -> Just builtinMultiplyFloat
"/f" -> Just builtinDevideFloat
-- "pi" -> Just builtinPi
"exp" -> Just builtinExp
"log" -> Just builtinLog
"sqrt" -> Just builtinSqrt
"**" -> Just builtinPower
"log-base" -> Just builtinLogBase
"sin" -> Just builtinSin
"cos" -> Just builtinCos
"tan" -> Just builtinTan
"asin" -> Just builtinAsin
"acos" -> Just builtinAcos
"atan" -> Just builtinAtan
"sinh" -> Just builtinSinh
"cosh" -> Just builtinCosh
"tanh" -> Just builtinTanh
"asinh" -> Just builtinAsinh
"acosh" -> Just builtinAcosh
"atanh" -> Just builtinAtanh
_ -> Nothing
builtinRead :: [Value] -> IOThrowsError Value
builtinRead [(World actions)] = do
str <- liftIO (getExpressionHelper False 0)
val <- readValue str
ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])
return ret
builtinRead _ = throwError (Default "invalid args to read")
builtinWrite :: [Value] -> IOThrowsError Value
builtinWrite [(World actions), val] = do
valStr <- liftIO (showValue val)
liftIO (flushStr valStr)
return (World ((Write val):actions))
builtinWrite _ = throwError (Default "invalid args to write")
builtinReadChar :: [Value] -> IOThrowsError Value
builtinReadChar [(World actions)] = do
c <- liftIO getChar
ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])
return ret
builtinReadChar _ = throwError (Default "invalid args to read-char")
builtinWriteChar :: [Value] -> IOThrowsError Value
builtinWriteChar [(World actions), (Character c)] = do
liftIO (putChar c)
return (World ((Write (Character c)):actions))
builtinWriteChar _ = throwError (Default "invalid args to write-char")
builtinIntToFloat :: [Value] -> IOThrowsError Value
builtinIntToFloat [Integer n] = return (Double (fromInteger n))
builtinIntToFloat _ = throwError (Default "invalid args to int-to-float")
builtinCeiling :: [Value] -> IOThrowsError Value
builtinCeiling [Double d] = return (Integer (ceiling d))
builtinCeiling _ = throwError (Default "invalid args to ceiling")
builtinFloor :: [Value] -> IOThrowsError Value
builtinFloor [Double d] = return (Integer (floor d))
builtinFloor _ = throwError (Default "invalid args to floor")
builtinTruncate :: [Value] -> IOThrowsError Value
builtinTruncate [Double d] = return (Integer (truncate d))
builtinTruncate _ = throwError (Default "invalid args to truncate")
builtinRound :: [Value] -> IOThrowsError Value
builtinRound [Double d] = return (Integer (round d))
builtinRound _ = throwError (Default "invalid args to round")
builtinEqual :: [Value] -> IOThrowsError Value
builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2)
then return (InductiveData "true" [])
else return (InductiveData "false" [])
builtinEqual _ = throwError (Default "invalid args to =")
builtinPlus :: [Value] -> IOThrowsError Value
builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2))
builtinPlus _ = throwError (Default "invalid args to +")
builtinMinus :: [Value] -> IOThrowsError Value
builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2))
builtinMinus _ = throwError (Default "invalid args to -")
builtinMultiply :: [Value] -> IOThrowsError Value
builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2))
builtinMultiply _ = throwError (Default "invalid args to *")
builtinDevide :: [Value] -> IOThrowsError Value
builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2))
builtinDevide _ = throwError (Default "invalid args to /")
builtinMod :: [Value] -> IOThrowsError Value
builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2))
builtinMod _ = throwError (Default "invalid args to mod")
builtinEqualFloat :: [Value] -> IOThrowsError Value
builtinEqualFloat [(Double n1), (Double n2)] = if (n1 == n2)
then return (InductiveData "true" [])
else return (InductiveData "false" [])
builtinEqualFloat _ = throwError (Default "invalid args to =f")
builtinPlusFloat :: [Value] -> IOThrowsError Value
builtinPlusFloat [(Double n1), (Double n2)] = return (Double (n1 + n2))
builtinPlusFloat _ = throwError (Default "invalid args to +f")
builtinMinusFloat :: [Value] -> IOThrowsError Value
builtinMinusFloat [(Double n1), (Double n2)] = return (Double (n1 - n2))
builtinMinusFloat _ = throwError (Default "invalid args to -f")
builtinMultiplyFloat :: [Value] -> IOThrowsError Value
builtinMultiplyFloat [(Double n1), (Double n2)] = return (Double (n1 * n2))
builtinMultiplyFloat _ = throwError (Default "invalid args to *f")
builtinDevideFloat :: [Value] -> IOThrowsError Value
builtinDevideFloat [(Double n1), (Double n2)] = return (Double (n1 / n2))
builtinDevideFloat _ = throwError (Default "invalid args to /f")
builtinExp :: [Value] -> IOThrowsError Value
builtinExp [Double d] = return (Double (exp d))
builtinExp _ = throwError (Default "invalid args to exp")
builtinLog :: [Value] -> IOThrowsError Value
builtinLog [Double d] = return (Double (log d))
builtinLog _ = throwError (Default "invalid args to log")
builtinSqrt :: [Value] -> IOThrowsError Value
builtinSqrt [Double d] = return (Double (sqrt d))
builtinSqrt _ = throwError (Default "invalid args to sqrt")
builtinPower :: [Value] -> IOThrowsError Value
builtinPower [(Double n1), (Double n2)] = return (Double (n1 ** n2))
builtinPower _ = throwError (Default "invalid args to **")
builtinLogBase :: [Value] -> IOThrowsError Value
builtinLogBase [(Double n1), (Double n2)] = return (Double (logBase n1 n2))
builtinLogBase _ = throwError (Default "invalid args to log-base")
builtinSin :: [Value] -> IOThrowsError Value
builtinSin [Double d] = return (Double (sin d))
builtinSin _ = throwError (Default "invalid args to sin")
builtinCos :: [Value] -> IOThrowsError Value
builtinCos [Double d] = return (Double (cos d))
builtinCos _ = throwError (Default "invalid args to cos")
builtinTan :: [Value] -> IOThrowsError Value
builtinTan [Double d] = return (Double (tan d))
builtinTan _ = throwError (Default "invalid args to tan")
builtinAsin :: [Value] -> IOThrowsError Value
builtinAsin [Double d] = return (Double (asin d))
builtinAsin _ = throwError (Default "invalid args to asin")
builtinAcos :: [Value] -> IOThrowsError Value
builtinAcos [Double d] = return (Double (acos d))
builtinAcos _ = throwError (Default "invalid args to acos")
builtinAtan :: [Value] -> IOThrowsError Value
builtinAtan [Double d] = return (Double (atan d))
builtinAtan _ = throwError (Default "invalid args to atan")
builtinSinh :: [Value] -> IOThrowsError Value
builtinSinh [Double d] = return (Double (sinh d))
builtinSinh _ = throwError (Default "invalid args to sinh")
builtinCosh :: [Value] -> IOThrowsError Value
builtinCosh [Double d] = return (Double (cosh d))
builtinCosh _ = throwError (Default "invalid args to cosh")
builtinTanh :: [Value] -> IOThrowsError Value
builtinTanh [Double d] = return (Double (tanh d))
builtinTanh _ = throwError (Default "invalid args to tanh")
builtinAsinh :: [Value] -> IOThrowsError Value
builtinAsinh [Double d] = return (Double (asinh d))
builtinAsinh _ = throwError (Default "invalid args to asinh")
builtinAcosh :: [Value] -> IOThrowsError Value
builtinAcosh [Double d] = return (Double (acosh d))
builtinAcosh _ = throwError (Default "invalid args to acosh")
builtinAtanh :: [Value] -> IOThrowsError Value
builtinAtanh [Double d] = return (Double (atanh d))
builtinAtanh _ = throwError (Default "invalid args to atanh")
---
--- for Debug : show Expression
---
showTopExpression :: TopExpression -> String
showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")"
showTopExpression (Test expr) = "(test " ++ show expr ++ ")"
showTopExpression Execute = "(execute)"
instance Show TopExpression where show = showTopExpression
showExpression :: Expression -> String
showExpression (CharacterExp c) = show c
showExpression (IntegerExp n) = show n
showExpression (SymbolExp name) = name
showExpression (InductiveDataExp s []) = "<" ++ s ++ ">"
showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">"
showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]"
showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}"
showExpression (PatternExp pat) = show pat
showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"
showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")"
showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")"
showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")"
showExpression (DeconstructorExp deconsInfoExp) = "(deconstructor " ++ showDeconsInfoExp deconsInfoExp ++ ")"
showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})"
showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")"
showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")"
instance Show Expression where show = showExpression
showInnerExp :: InnerExp -> String
showInnerExp (ElementExp v) = show v
showInnerExp (SubCollectionExp v) = "@" ++ show v
instance Show InnerExp where show = showInnerExp
showPatternExp :: PatternExp -> String
showPatternExp WildCardExp = "_"
showPatternExp (PatVarExp s) = "$" ++ s
showPatternExp (CutPatExp p) = "!" ++ show p
showPatternExp (AsPatExp s p) = "(as " ++ s ++ " " ++ show p ++ ")"
showPatternExp (OfPatExp ps) = "(of " ++ show ps ++ ")"
showPatternExp (ValPatExp expr) = "," ++ show expr
instance Show PatternExp where show = showPatternExp
showRecursiveBind :: RecursiveBind -> String
showRecursiveBind [] = "{}"
showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}"
showRecursiveBindHelper :: (String, Expression) -> String
showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]"
showFunPat :: FunPat -> String
showFunPat (FunPatVar name) = "$" ++ name
showFunPat (FunPatTuple []) = "[]"
showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]"
instance Show FunPat where show = showFunPat
showDeconsInfoExp :: DeconsInfoExp -> String
showDeconsInfoExp dcs = "{" ++ unwords (map showDeconsClause dcs) ++ "}"
showDeconsClause :: (String, Expression, [(PrimePat, Expression)]) -> String
showDeconsClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDeconsClause2 dc2s) ++ "})"
showDeconsClause2 :: (PrimePat, Expression) -> String
showDeconsClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"
showPrimePat :: PrimePat -> String
showPrimePat PrimeWildCard = "_"
showPrimePat (PrimePatVar name) = "$" ++ name
showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">"
showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">"
showPrimePat (TuplePrimePat vs) = "[" ++ unwordsList vs ++ "]"
showPrimePat EmptyPat = "{}"
showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}"
showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}"
instance Show PrimePat where show = showPrimePat
showMatchClause :: MatchClause -> String
showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"
instance Show MatchClause where show = showMatchClause
showFrame :: Frame -> String
showFrame (Frame assocs) =
let vars = map fst assocs in
"[" ++ unwords vars ++ "]"
instance Show Frame where show = showFrame
showFrames :: [Frame] -> String
showFrames frames = "[" ++ unwordsList frames ++ "]"