egison-1.0.2: Egison.hs
module Main where
import System.Environment
import Control.Monad.Error
import Data.IORef
--import qualified Data.HashMap as Hash
import Text.Parsec hiding (spaces)
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellDef)
import IO hiding (try)
welcomeMsg :: String
welcomeMsg = "Egison, version 1.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"
data Input = Input String
| Eof
readPrompt :: String -> IO Input
readPrompt prompt = flushStr prompt >> getExpression
flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout
getExpressionHelper :: Bool -> Integer -> IO String
getExpressionHelper b n = do c <- getChar
case c of
'(' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
'<' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
'[' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
'{' -> do l <- getExpressionHelper True (n + 1)
return (c : l)
')' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
'>' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
']' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
'}' -> do l <- getExpressionHelper True (n - 1)
return (c : l)
'\n' -> if n > 0
then do l <- getExpressionHelper b n
return (c : l)
else if b
then return "\n"
else getExpressionHelper b n
' ' -> do l <- getExpressionHelper b n
return (c : l)
'\t' -> do l <- getExpressionHelper b n
return (c : l)
_ -> do l <- getExpressionHelper True n
return (c : l)
getExpression :: IO Input
getExpression = catch (do str <- getExpressionHelper False 0
return (Input str))
(\_ -> return Eof)
--
-- Error Handle
--
type IOThrowsError = ErrorT EgiError IO
data EgiError = Parser ParseError
| UnboundVariable String [Integer]
| WithTopExpression String Expression
| WithExpression String Expression
| Default String
showError :: EgiError -> String
showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n"
showError (UnboundVariable name nums) = "Error : unbound variable : " ++ name ++ unwordsNums nums ++ "\n"
showError (WithTopExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n"
showError (WithExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n"
showError (Default str) = "Error : " ++ str ++ "\n"
instance Show EgiError where show = showError
instance Error EgiError where
noMsg = Default "An error has occured"
strMsg = Default
type ThrowsError = Either EgiError
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val
runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runErrorT (trapError action) >>= return . extractValue
trapError :: (MonadError e m, Show e) => m String -> m String
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "egison" input of
Left err -> throwError (Parser err)
Right val -> return val
readTopExpression :: String -> IOThrowsError TopExpression
readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr)
readTopExpressionList :: String -> IOThrowsError [TopExpression]
readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str)
executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String
executeTopExpression defs (Define name expr) = do
liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))
return (name ++ "\n")
executeTopExpression defs (Test expr) = do
topFrame <- makeTopFrame defs
val <- eval [topFrame] expr
ret <- liftIO (showValue val)
return (ret ++ "\n")
executeTopExpression defs (Load filename) = do
mStr <- liftIO (readEgisonFile filename)
case mStr of
Nothing -> throwError (Default "load error")
Just str -> do topExprs <- readTopExpressionList str
let loop topExprs2 = case topExprs2 of
[] -> return (filename ++ " loaded\n")
topExpr:rest -> do executeTopExpression defs topExpr
loop rest
in loop topExprs
executeTopExpression defs Execute = do
topFrame <- makeTopFrame defs
mainFn <- eval [topFrame] (VariableExp "main" [])
args <- liftIO (newIORef (Value (World [])))
case mainFn of
Function funEnv fpat body
-> do frame <- makeFrame fpat args
objRef <- liftIO (makeClosure (frame:funEnv) body)
cEval objRef
return ""
_ -> throwError (Default "main is not function")
readEgisonFile :: String -> IO (Maybe String)
readEgisonFile filename = catch (do str <- (readFile filename)
return (Just str))
(\_ -> return Nothing)
runRepl :: Definitions -> IO ()
runRepl defs = do input <- (readPrompt "> ")
case input of
Eof -> flushStr byebyeMsg
Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defs) >>= flushStr >> runRepl defs
-- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs
main :: IO ()
main = do args <- getArgs
case length args of
0 -> do flushStr welcomeMsg
defsRef <- newIORef []
runRepl defsRef
_ -> putStrLn "Program takes only 0 argument!"
--
-- Data Types
--
data TopExpression = Define String Expression
| Test Expression
| Load String
| Execute
data Expression = CharacterExp Char
| StringExp String
| IntegerExp Integer
| DoubleExp Double
| VariableExp String [Expression]
| InductiveDataExp String [Expression]
| TupleExp [Expression]
| CollectionExp [InnerExp]
| WildCardExp
| PatVarExp String [Expression]
| CutPatExp Expression
| AndPatExp [Expression]
| OrPatExp [Expression]
| PredPatExp String [Expression]
| FunctionExp FunPat Expression
| DoExp Bind Expression
| LetExp RecursiveBind Expression
| LoopExp Expression Expression Expression Expression Expression
| TypeExp RecursiveBind
| TypeRefExp Expression String
| DestructorExp DestructInfoExp
| MatchExp Expression Expression [MatchClause]
| MatchAllExp Expression Expression MatchClause
| ApplyExp Expression Expression
data InnerExp = ElementExp Expression
| SubCollectionExp Expression
type Bind = [(FunPat, Expression)]
data FunPat = FunPatVar String
| FunPatTuple [FunPat]
type RecursiveBind = [(String, Expression)]
data MatchClause = MatchClause Expression Expression
type DestructInfoExp = [(String, Expression, [(PrimePat, Expression)])]
data PrimePat = PrimeWildCard
| PrimePatCharacter Char
| PrimePatInteger Integer
| PrimePatDouble Double
| PrimePatVar String
| InductivePrimePat String [PrimePat]
| EmptyPat
| ConsPat PrimePat PrimePat
| SnocPat PrimePat PrimePat
data Object = Closure Environment Expression
| Value Value
data Value = World [Action]
| Character Char
| Integer Integer
| Double Double
| InductiveData String [ObjectRef]
| Tuple [ObjectRef]
| Collection [InnerValue]
| WildCard
| PatVar String [Integer]
| PredPat String [ObjectRef]
| CutPat ObjectRef
| AndPat [ObjectRef]
| OrPat [ObjectRef]
| Function Environment FunPat Expression
| Macro FunPat Expression
| Loop String String Integer Integer Expression Expression
| Type Frame
| DestructorFunction DestructInfo
| BuiltinFunction ([Value] -> IOThrowsError Value)
type ObjectRef = IORef Object
data Action = Read Value
| Write Value
| Print String
data InnerValue = Element ObjectRef
| SubCollection ObjectRef
type DestructInfo = [(String, ObjectRef, [(Environment, PrimePat, Expression)])]
type Environment = [Frame]
type Frame = [Association]
type Association = ((String, [Integer]), ObjectRef)
type Definitions = IORef [(String, Expression)]
data PClosure = PClosure Frame ObjectRef
data MAtom = MAtom PClosure ObjectRef ObjectRef
data MState = MState Frame [MAtom]
isEqualValue :: Value -> Value -> IOThrowsError Bool
isEqualValue (Character c1) (Character c2) = return (c1 == c2)
isEqualValue (Integer n1) (Integer n2) = return (n1 == n2)
isEqualValue (Double d1) (Double d2) = return (d1 == d2)
isEqualValue (InductiveData c1 objRefs1) (InductiveData c2 objRefs2) =
if (c1 == c2)
then do vals1 <- liftIO (objRefListToValueList objRefs1)
vals2 <- liftIO (objRefListToValueList objRefs2)
isEqualValueList vals1 vals2
else return False
isEqualValue (Tuple objRefs1) (Tuple objRefs2) = do
vals1 <- liftIO (objRefListToValueList objRefs1)
vals2 <- liftIO (objRefListToValueList objRefs2)
isEqualValueList vals1 vals2
isEqualValue val1@(Collection _) val2@(Collection _) = do
vals1 <- liftIO (collectionToValueList val1)
vals2 <- liftIO (collectionToValueList val2)
isEqualValueList vals1 vals2
isEqualValue _ _ = return False
isEqualValueList :: [Value] -> [Value] -> IOThrowsError Bool
isEqualValueList [] [] = return True
isEqualValueList (v1:vals1) (v2:vals2) = do
b <- isEqualValue v1 v2
if b
then isEqualValueList vals1 vals2
else return False
isEqualValueList _ _ = return False
objectRefToInteger :: ObjectRef -> IOThrowsError Integer
objectRefToInteger objRef = do
obj <- liftIO (readIORef objRef)
case obj of
Value (Integer n) -> return n
_ -> throwError (Default "objectRefToInteger: not Integer value")
--
-- Environment
--
getValueFromFrame :: Frame -> (String,[Integer]) -> Maybe ObjectRef
getValueFromFrame [] _ = Nothing
getValueFromFrame (((var,nums1),objRef):rest) (var2,nums2) =
if var == var2 && nums1 == nums2
then Just objRef
else getValueFromFrame rest (var2,nums2)
getValue :: Environment -> (String,[Integer]) -> Maybe ObjectRef
getValue [] _ = Nothing
getValue (frame:env) (var,nums) =
let mObjRef = getValueFromFrame frame (var,nums)in
case mObjRef of
Nothing -> getValue env (var,nums)
Just objRef -> Just objRef
makeClosure :: Environment -> Expression -> IO ObjectRef
makeClosure env expr = newIORef (Closure env expr)
makeClosureList :: Environment -> [Expression] -> IO [ObjectRef]
makeClosureList _ [] = return []
makeClosureList env (expr:exprs) = do
obj <- makeClosure env expr
objs <- makeClosureList env exprs
return (obj:objs)
makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue]
makeClosureInnerVals _ [] = return []
makeClosureInnerVals env (ElementExp expr : rest) = do
objRef <- makeClosure env expr
innerValRefs <- makeClosureInnerVals env rest
return (Element objRef : innerValRefs)
makeClosureInnerVals env (SubCollectionExp expr : rest) = do
objRef <- makeClosure env expr
innerValRefs <- makeClosureInnerVals env rest
return (SubCollection objRef : innerValRefs)
makeDestructInfo :: Environment -> DestructInfoExp -> IO DestructInfo
makeDestructInfo _ [] = return []
makeDestructInfo env ((cons, typeExp, dcs):deconsInfoExp) = do
typeObjRef <- makeClosure env typeExp
let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs in
do deconsInfo <- makeDestructInfo env deconsInfoExp
return ((cons, typeObjRef, dcs2):deconsInfo)
makeFrameHelper :: [FunPat] -> [ObjectRef] -> IOThrowsError Frame
makeFrameHelper fpats objRefs =
case (fpats, objRefs) of
([], []) -> return []
((fpat:fps), (objRef:ivrs)) -> do frame1 <- makeFrame fpat objRef
frame2 <- makeFrameHelper fps ivrs
return (frame1 ++ frame2)
(_, _) -> throwError (Default "invalid number of argument")
makeFrame :: FunPat -> ObjectRef -> IOThrowsError Frame
makeFrame (FunPatVar name) objRef = do
return [((name, []), objRef)]
makeFrame (FunPatTuple fpats) objRef = do
val <- cEval1 objRef
case val of
Tuple objRefs -> makeFrameHelper fpats objRefs
_ -> makeFrameHelper fpats [objRef]
makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO ()
makeRecursiveFrameHelper _ _ [] = return ()
makeRecursiveFrameHelper env newFrame ((_, objRef):assocs) = do
obj <- readIORef objRef
case obj of
(Closure _ expr) -> writeIORef objRef (Closure (newFrame:env) expr)
makeRecursiveFrameHelper env newFrame assocs
makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame
makeRecursiveFrame env bind =
let vars = map (\name -> (name, [])) (map fst bind) in
let exprs = map snd bind in
do objRefs <- liftIO (makeClosureList [] exprs)
let newFrame = zip vars objRefs in
do liftIO (makeRecursiveFrameHelper env newFrame newFrame)
return newFrame
makeTopFrame :: Definitions -> IOThrowsError Frame
makeTopFrame defsRef = do
defs <- liftIO (readIORef defsRef)
makeRecursiveFrame [] defs
--
-- InnerExp
--
valListToObjRefList :: [Value] -> IO [ObjectRef]
valListToObjRefList [] = return []
valListToObjRefList (val:vals) = do
objRef <- newIORef (Value val)
objRefs <- valListToObjRefList vals
return (objRef:objRefs)
objRefListToValueList :: [ObjectRef] -> IO [Value]
objRefListToValueList [] = return []
objRefListToValueList (objRef:objRefs) = do
obj <- readIORef objRef
case obj of
Value val -> do vals <- objRefListToValueList objRefs
return (val:vals)
tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]
tupleToObjRefList objRef = do
val <- cEval1 objRef
case val of
(Tuple objRefs) -> return objRefs
val -> return [objRef]
tupleToValueList :: Value -> IO [Value]
tupleToValueList (Tuple []) = return []
tupleToValueList (Tuple (objRef:objRefs)) = do
val <- readIORef objRef
case val of
Value val -> do vals <- tupleToValueList (Tuple objRefs)
return (val:vals)
tupleToValueList val = return [val]
tupleObjRefListToListOfList :: [ObjectRef] -> IOThrowsError [[ObjectRef]]
tupleObjRefListToListOfList [] = return []
tupleObjRefListToListOfList (objRef:objRefs) = do
objRefs2 <- tupleToObjRefList objRef
objRefss2 <- tupleObjRefListToListOfList objRefs
return (objRefs2:objRefss2)
makeObjRefList :: [Value] -> IO [ObjectRef]
makeObjRefList [] = return []
makeObjRefList (val:vals) = do
objRef <- newIORef (Value val)
objRefs <- makeObjRefList vals
return (objRef:objRefs)
makeTupleFromValueList :: [Value] -> IO Value
makeTupleFromValueList vals = do
objRefs <- makeObjRefList vals
return (Tuple objRefs)
collectionObjToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]
collectionObjToObjRefList objRef = do
val <- cEval1 objRef
collectionToObjRefList val
collectionToObjRefList :: Value -> IOThrowsError [ObjectRef]
collectionToObjRefList (Collection []) = return []
collectionToObjRefList (Collection (Element eRef:rest)) = do restRefs <- collectionToObjRefList (Collection rest)
return (eRef : restRefs)
collectionToObjRefList (Collection (SubCollection subRef:rest)) = do valRefs1 <- collectionObjToObjRefList subRef
valRefs2 <- collectionToObjRefList (Collection rest)
return (valRefs1 ++ valRefs2)
collectionToObjRefList _ = throwError (Default "collectionObjToObjRefList : not a collection")
collectionToValueList :: Value -> IO [Value]
collectionToValueList (Collection []) = return []
collectionToValueList (Collection (Element eRef : rest)) = do
eObj <- readIORef eRef
case eObj of
Value e -> do rest <- collectionToValueList (Collection rest)
return (e : rest)
collectionToValueList (Collection (SubCollection subRef : rest)) = do
subObj <- readIORef subRef
case subObj of
Value subVal -> do vals1 <- collectionToValueList subVal
vals2 <- collectionToValueList (Collection rest)
return (vals1 ++ vals2)
charCollectionToString :: Value -> IOThrowsError [Char]
charCollectionToString (Collection []) = return []
charCollectionToString (Collection (Element eRef : rest)) = do
eObj <- liftIO (readIORef eRef)
restStr <- charCollectionToString (Collection rest)
case eObj of
Value (Character c) -> return (c : restStr)
_ -> throwError (Default "charCollectionToString : not char collection")
makeCollectionFromValueList :: [Value] -> IO Value
makeCollectionFromValueList vals =
let loop vals2 = case vals2 of
[] -> return []
(val:rest) -> do objRef <- newIORef (Value val)
restRefs <- loop rest
return ((Element objRef):restRefs) in
do innerVals <- loop vals
return (Collection innerVals)
integerValListToIntegerList :: [Value] -> [Integer]
integerValListToIntegerList [] = []
integerValListToIntegerList ((Integer n):vals) = n:(integerValListToIntegerList vals)
--
-- Parser
--
lexer = P.makeTokenParser haskellDef
charLiteral = P.charLiteral lexer
stringLiteral = P.stringLiteral lexer
integer = P.integer lexer
float = P.float lexer
parens = P.parens lexer
angles = P.angles lexer
brackets = P.brackets lexer
braces = P.braces lexer
headSymbol :: Parser Char
headSymbol = oneOf "+-*/=:"
restSymbol :: Parser Char
restSymbol = oneOf "!?+-*/=:"
word :: Parser String
word = do first <- (letter <|> headSymbol)
rest <- many (letter <|> digit <|> restSymbol)
return (first:rest)
spaces :: Parser ()
spaces = skipMany (oneOf " \n\t")
spaces1 :: Parser ()
spaces1 = skipMany1 (oneOf " \n\t")
parseTopExpression :: Parser TopExpression
parseTopExpression = do spaces
parens (do try (string "define")
spaces
char '$'
name <- word
spaces
expr <- parseExpression
return (Define name expr)
<|> do try (string "test")
spaces
expr <- parseExpression
spaces
return (Test expr)
<|> do try (string "execute")
return Execute
<|> do try (string "load")
spaces
filename <- stringLiteral
spaces
return (Load filename)
) <?> "top expression"
parseExpression :: Parser Expression
parseExpression = do ws <- word
nums <- parseIndexNums
return (VariableExp ws nums)
<|> do c <- charLiteral
return (CharacterExp c)
<|> do str <- stringLiteral
return (StringExp str)
<|> do d <- try float
return (DoubleExp d)
<|> do n <- try integer
return (IntegerExp n)
<|> do try (do char '$'
ws <- word
nums <- parseIndexNums
return (PatVarExp ws nums))
<|> do char '_'
return WildCardExp
<|> do char '!'
expr <- parseExpression
return (CutPatExp expr)
<|> do char ','
expr <- parseExpression
return (PredPatExp "equal?" [expr])
<|> angles (do c <- word
spaces
vs <- sepEndBy parseExpression spaces
return (InductiveDataExp c vs))
<|> brackets (do vs <- sepEndBy parseExpression spaces
return (TupleExp vs))
<|> braces (do vs <- sepEndBy parseInnerExp spaces
return (CollectionExp vs))
<|> parens (do try (do char '&'
spaces1)
exprs <- sepEndBy parseExpression spaces
return (AndPatExp exprs)
<|> do try (do char '|'
spaces1)
exprs <- sepEndBy parseExpression spaces
return (OrPatExp exprs)
<|> do try (do char '?'
spaces1)
name <- word
spaces1
exprs <- sepEndBy parseExpression spaces
return (PredPatExp name exprs)
<|> do try (do string "lambda"
spaces1)
args <- parseFunPat
spaces
body <- parseExpression
return (FunctionExp args body)
<|> do try (do string "do"
spaces1)
bind <- parseBind
spaces
body <- parseExpression
return (DoExp bind body)
<|> do try (do string "let"
spaces1)
bind <- parseRecursiveBind
spaces
body <- parseExpression
return (LetExp bind body)
<|> do try (do string "loop"
spaces1)
spaces
var1 <- parseExpression
spaces
var2 <- parseExpression
spaces
range <- parseExpression
spaces
body1 <- parseExpression
spaces
body2 <- parseExpression
return (LoopExp var1 var2 range body1 body2)
<|> do try (do string "type"
spaces1)
bind <- parseRecursiveBind
return (TypeExp bind)
<|> do try (do string "type-ref"
spaces1)
typ <- parseExpression
spaces
name <- word
return (TypeRefExp typ name)
<|> do try (do string "destructor"
spaces1)
deconsInfo <- parseDestructInfoExp
return (DestructorExp deconsInfo)
<|> do try (do string "match"
spaces1)
tgt <- parseExpression
spaces
typ <- parseExpression
spaces
clss <- braces (sepEndBy parseMatchClause spaces)
return (MatchExp tgt typ clss)
<|> do try (do string "match-all"
spaces1)
tgt <- parseExpression
spaces
typ <- parseExpression
spaces
cls <- parseMatchClause
spaces
return (MatchAllExp tgt typ cls)
<|> do try (do string "apply"
spaces1)
fn <- parseExpression
spaces
args <- parseExpression
return (ApplyExp fn args)
<|> do fn <- parseExpression
spaces
args <- sepEndBy parseExpression spaces
return (ApplyExp fn (TupleExp args)))
parseIndexNums :: Parser [Expression]
parseIndexNums = do try (do char '_'
n <- parseExpression
ns <- parseIndexNums
return (n:ns))
<|> do return []
parseInnerExp :: Parser InnerExp
parseInnerExp = do v <- parseExpression
return (ElementExp v)
<|> do char '@'
v <- parseExpression
return (SubCollectionExp v)
parseFunPat :: Parser FunPat
parseFunPat = do char '$'
name <- word
return (FunPatVar name)
<|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces))
case fpats of
[fpat] -> return fpat
_ -> return (FunPatTuple fpats))
parseBind :: Parser Bind
parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat
spaces
expr <- parseExpression
return (fpat, expr)))
spaces
return bs)
parseRecursiveBind :: Parser RecursiveBind
parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$'
var <- word
spaces
expr <- parseExpression
return (var, expr)))
spaces
return bs)
parseDestructInfoExp :: Parser DestructInfoExp
parseDestructInfoExp = braces (sepEndBy parseDestructClause spaces)
parseDestructClause :: Parser (String, Expression, [(PrimePat, Expression)])
parseDestructClause = brackets (do patCons <- word
spaces
typExpr <- parseExpression
spaces
dc2s <- braces (sepEndBy parseDestructClause2 spaces)
return (patCons, typExpr, dc2s))
parseDestructClause2 :: Parser (PrimePat, Expression)
parseDestructClause2 = brackets (do datPat <- parsePrimePat
spaces
expr <- parseExpression
return (datPat, expr))
parsePrimePat :: Parser PrimePat
parsePrimePat = do char '_'
return PrimeWildCard
<|> do c <- try charLiteral
return (PrimePatCharacter c)
<|> do d <- try float
return (PrimePatDouble d)
<|> do n <- try integer
return (PrimePatInteger n)
<|> do char '$'
name <- word
return (PrimePatVar name)
<|> angles (do c <- word
spaces
ps <- sepEndBy parsePrimePat spaces
return (InductivePrimePat c ps))
<|> try (do char '{'
spaces
char '}'
return EmptyPat)
<|> try (do char '{'
spaces
a <- parsePrimePat
spaces
char '.'
b <- parsePrimePat
char '}'
return (ConsPat a b))
<|> try (do char '{'
spaces
char '.'
a <- parsePrimePat
spaces
b <- parsePrimePat
char '}'
return (SnocPat a b))
parseMatchClause :: Parser MatchClause
parseMatchClause = brackets (do pat <- parseExpression
spaces
body <- parseExpression
return (MatchClause pat body))
--
-- Show
--
unwordsList :: Show a => [a] -> String
unwordsList = unwords . map show
unwordsNums :: Show a => [a] -> String
unwordsNums [] = ""
unwordsNums (n:ns) = "_" ++ show n ++ unwordsNums ns
showTopExpression :: TopExpression -> String
showTopExpression (Define name expr) = "(define $" ++ name ++ " " ++ show expr ++ ")"
showTopExpression (Test expr) = "(test " ++ show expr ++ ")"
showTopExpression (Load expr) = "(load " ++ show expr ++ ")"
showTopExpression Execute = "(execute)"
instance Show TopExpression where show = showTopExpression
showExpression :: Expression -> String
showExpression (CharacterExp c) = "'" ++ show c ++ "'"
showExpression (StringExp s) = "\"" ++ show s ++ "\""
showExpression (IntegerExp n) = show n
showExpression (VariableExp name nums) = name ++ unwordsNums nums
showExpression (InductiveDataExp s []) = "<" ++ s ++ ">"
showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">"
showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]"
showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}"
showExpression WildCardExp = "_"
showExpression (PatVarExp name nums) = "$" ++ name ++ unwordsNums nums
showExpression (CutPatExp p) = "!" ++ show p
showExpression (AndPatExp ps) = "(& " ++ unwordsList ps ++ ")"
showExpression (OrPatExp ps) = "(| " ++ unwordsList ps ++ ")"
showExpression (PredPatExp name ps) = "(? " ++ name ++ " " ++ unwordsList ps ++ ")"
showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"
showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")"
showExpression (LoopExp var1 var2 range body1 body2) = "(loop" ++ " " ++ show var1 ++ " " ++ show var2 ++ " " ++ show range ++ " " ++ show body1 ++ " " ++ show body2 ++ ")"
showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")"
showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")"
showExpression (DestructorExp deconsInfoExp) = "(destructor " ++ showDestructInfoExp deconsInfoExp ++ ")"
showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})"
showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")"
showExpression (ApplyExp fn args) = "(apply " ++ show fn ++ " " ++ show args ++ ")"
instance Show Expression where show = showExpression
showInnerExp :: InnerExp -> String
showInnerExp (ElementExp v) = show v
showInnerExp (SubCollectionExp v) = "@" ++ show v
instance Show InnerExp where show = showInnerExp
showRecursiveBind :: RecursiveBind -> String
showRecursiveBind [] = "{}"
showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}"
showRecursiveBindHelper :: (String, Expression) -> String
showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]"
showFunPat :: FunPat -> String
showFunPat (FunPatVar name) = "$" ++ name
showFunPat (FunPatTuple []) = "[]"
showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]"
instance Show FunPat where show = showFunPat
showDestructInfoExp :: DestructInfoExp -> String
showDestructInfoExp dcs = "{" ++ unwords (map showDestructClause dcs) ++ "}"
showDestructClause :: (String, Expression, [(PrimePat, Expression)]) -> String
showDestructClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDestructClause2 dc2s) ++ "})"
showDestructClause2 :: (PrimePat, Expression) -> String
showDestructClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"
showPrimePat :: PrimePat -> String
showPrimePat PrimeWildCard = "_"
showPrimePat (PrimePatVar name) = "$" ++ name
showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">"
showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">"
showPrimePat EmptyPat = "{}"
showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}"
showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}"
instance Show PrimePat where show = showPrimePat
showMatchClause :: MatchClause -> String
showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"
instance Show MatchClause where show = showMatchClause
--
-- read and show Value
--
readValue :: String -> IOThrowsError Value
readValue exprStr = do
expr <- readExpression exprStr
expressionToValue expr
readExpression :: String -> IOThrowsError Expression
readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr)
expressionToValue :: Expression -> IOThrowsError Value
expressionToValue (CharacterExp c) = return (Character c)
expressionToValue (StringExp str) = do
val <- liftIO (makeCollectionFromValueList (map Character str))
return val
expressionToValue (IntegerExp n) = return (Integer n)
expressionToValue (DoubleExp d) = return (Double d)
expressionToValue (InductiveDataExp con exprs) = do
vals <- expressionToValueMap exprs
objRefs <- liftIO (valListToObjRefList vals)
return (InductiveData con objRefs)
expressionToValue (TupleExp exprs) = do
vals <- expressionToValueMap exprs
case vals of
[val] -> return val
_ -> do objRefs <- liftIO (valListToObjRefList vals)
return (Tuple objRefs)
expressionToValue (CollectionExp innerExps) = do
innerVals <- innerExpToInnerValueMap innerExps
return (Collection innerVals)
expressionToValue expr = throwError (WithExpression "You should give a value as an input of read." expr)
expressionToValueMap :: [Expression] -> IOThrowsError [Value]
expressionToValueMap [] = return []
expressionToValueMap (expr:exprs) = do
val <- expressionToValue expr
vals <- expressionToValueMap exprs
return (val:vals)
innerExpToInnerValueMap :: [InnerExp] -> IOThrowsError [InnerValue]
innerExpToInnerValueMap [] = return []
innerExpToInnerValueMap (ElementExp expr:rest) = do
val <- expressionToValue expr
objRef <- liftIO (newIORef (Value val))
innerVals <- innerExpToInnerValueMap rest
return (Element objRef:innerVals)
innerExpToInnerValueMap (SubCollectionExp expr:rest) = do
val <- expressionToValue expr
objRef <- liftIO (newIORef (Value val))
innerVals <- innerExpToInnerValueMap rest
return (SubCollection objRef:innerVals)
showValue :: Value -> IO String
showValue (World _) = return "#<world>"
showValue (Character c) = return (show c)
showValue (Integer n) = return (show n)
showValue (Double d) = return (show d)
showValue (InductiveData cons []) = do
return ("<" ++ cons ++ ">")
showValue (InductiveData cons objRefs) = do
vals <- objRefListToValueList objRefs
str <- unwordsVals vals
return ("<" ++ cons ++ " " ++ str ++ ">")
showValue (Tuple []) = do
return ("[]")
showValue (Tuple objRefs) = do
vals <- objRefListToValueList objRefs
str <- unwordsVals vals
return ("[" ++ str ++ "]")
showValue (Collection []) = do
return ("{}")
showValue (Collection innerVals) = do
vals <- collectionToValueList (Collection innerVals)
str <- unwordsVals vals
return ("{" ++ str ++ "}")
showValue WildCard = return "_"
showValue (PatVar name nums) = return ("$" ++ name ++ unwordsNums nums)
showValue (CutPat _) = return "#<cut-pat>"
showValue (AndPat _) = return "#<and-pat>"
showValue (OrPat _) = return "#<or-pat>"
showValue (PredPat _ _) = return "#<pred-pat>"
showValue (Function _ _ _) = do
return "#<function>"
showValue (Loop _ _ _ _ _ _) = return "#<loop>"
showValue (Type _) = do
return "#<type>"
showValue (DestructorFunction _) = do
return "#<destructor-function>"
showValue (BuiltinFunction _) = do
return "#<builtin-function>"
unwordsVals :: [Value] -> IO String
unwordsVals [] = return ""
unwordsVals (val:vals) = do
s1 <- showValue val
s2 <- unwordsValsHelper vals
return (s1 ++ s2)
unwordsValsHelper :: [Value] -> IO String
unwordsValsHelper [] = return ""
unwordsValsHelper (val:vals) = do
s1 <- showValue val
s2 <- unwordsValsHelper vals
return (" " ++ s1 ++ s2)
showObjectRef :: ObjectRef -> IO String
showObjectRef objRef = do
obj <- readIORef objRef
case obj of
-- Closure env expr -> do envStr <- liftIO (showEnv env)
-- return ("(Closure " ++ envStr ++ " " ++ (show expr) ++ ")")
Closure _ _ -> return "#<closure>"
Value _ -> return "#<value>"
showEnv :: Environment -> IO String
showEnv [] = return "empty-env"
showEnv (frame:_) = do frameStr <- showFrame frame
return ("(Env " ++ frameStr ++ " : " ++ "..." ++ ")")
--showEnv (frame1:(frame2:_)) = do frameStr1 <- showFrame frame1
-- frameStr2 <- showFrame frame2
-- return ("(Env " ++ frameStr1 ++ " : " ++ frameStr2 ++ " : ...)")
showFrame :: Frame -> IO String
showFrame [] = return "[]"
showFrame (((var,nums),objRef):frame) = do
objRefStr <- showObjectRef objRef
frameStr <- showFrame frame
return ("(" ++ var ++ unwordsNums nums ++"," ++ objRefStr ++"):" ++ frameStr)
--
-- Evaluation
--
eval1 :: Environment -> Expression -> IOThrowsError Value
eval1 _ (CharacterExp c) = return (Character c)
eval1 _ (StringExp str) = do
val <- liftIO (makeCollectionFromValueList (map Character str))
return val
eval1 _ (IntegerExp n) = return (Integer n)
eval1 _ (DoubleExp d) = return (Double d)
eval1 env (VariableExp name numExprs) = do
numVals <- evalList env numExprs
let nums = integerValListToIntegerList numVals in
let maybeObjRef = getValue env (name,nums) in
case maybeObjRef of
Just objRef -> do val <- cEval1 objRef
case val of
Loop _ _ _ _ _ _ -> eval1Loop env val
_ -> return val
Nothing -> let mBuiltinFn = getBuiltin name in
case mBuiltinFn of
Just builtinFn -> return (BuiltinFunction builtinFn)
Nothing -> throwError (UnboundVariable name nums)
eval1 env (InductiveDataExp con exprs) = do
objRefs <- liftIO (makeClosureList env exprs)
return (InductiveData con objRefs)
eval1 env (TupleExp exprs) = do
objRefs <- liftIO (makeClosureList env exprs)
case objRefs of
[objRef] -> do cEval1 objRef
_ -> return (Tuple objRefs)
eval1 env (CollectionExp innerExps) = do
innerVals <- liftIO (makeClosureInnerVals env innerExps)
return (Collection innerVals)
eval1 _ WildCardExp = return WildCard
eval1 env (PatVarExp name numExprs) = do
numVals <- evalList env numExprs
return (PatVar name (integerValListToIntegerList numVals))
eval1 env (PredPatExp name exprs) = do
objRefs <- liftIO (makeClosureList env exprs)
return (PredPat name objRefs)
eval1 env (CutPatExp expr) = do
objRef <- liftIO (makeClosure env expr)
return (CutPat objRef)
eval1 env (AndPatExp exprs) = do
objRefs <- liftIO (makeClosureList env exprs)
return (AndPat objRefs)
eval1 env (OrPatExp exprs) = do
objRefs <- liftIO (makeClosureList env exprs)
return (OrPat objRefs)
eval1 env (FunctionExp args body) = return (Function env args body)
eval1 env (DoExp [] body) = eval1 env body
eval1 env (DoExp ((fpat,expr):assocs) body) = do
objRef <- liftIO (makeClosure env expr)
frame <- makeFrame fpat objRef
eval1 (frame:env) (DoExp assocs body)
eval1 env (LetExp bind body) = do
frame <- makeRecursiveFrame env bind
objRef <- liftIO (newIORef (Closure (frame:env) body))
cEval1 objRef
eval1 env expr@(LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do
range <- eval env rangeExpr
case range of
Tuple [mObjRef,nObjRef] ->
do m <- objectRefToInteger mObjRef
n <- objectRefToInteger nObjRef
eval1Loop env (Loop var1 var2 m n expr1 expr2)
_ -> throwError (WithExpression "third arg of loop is not a range" expr)
eval1 env (TypeExp bind) = do
frame <- makeRecursiveFrame env bind
return (Type frame)
eval1 env expr@(TypeRefExp typExp name) = do
typVal <- eval1 env typExp
case typVal of
(Type frame) -> let mObjRef = getValueFromFrame frame (name,[]) in
case mObjRef of
Nothing -> throwError (WithExpression ("no method in type" ++ name) expr)
Just objRef -> do val <- cEval1 objRef
return val
_ -> throwError (WithExpression "first arg of typeref is not type" expr)
eval1 env (DestructorExp deconsInfoExp) = do
deconsInfo <- liftIO (makeDestructInfo env deconsInfoExp)
return (DestructorFunction deconsInfo)
eval1 env (MatchExp tgtExp typExp mCs) = do
typObj <- liftIO (makeClosure env typExp)
tgtObj <- liftIO (makeClosure env tgtExp)
evalMatchExp env typObj tgtObj mCs
eval1 env (MatchAllExp tgtExp typExp mC) = do
typObj <- liftIO (makeClosure env typExp)
tgtObj <- liftIO (makeClosure env tgtExp)
evalMatchAllExp env typObj tgtObj mC
eval1 env expr@(ApplyExp fnExp argsExp) = do
fnVal <- eval1 env fnExp
argsObjRef <- liftIO (makeClosure env argsExp)
case fnVal of
BuiltinFunction builtinFn -> do argsVal <- cEval argsObjRef
argsVals <- liftIO (tupleToValueList argsVal)
builtinFn argsVals
Function funEnv fpat body -> do frame <- makeFrame fpat argsObjRef
objRef <- liftIO (makeClosure (frame:funEnv) body)
cEval1 objRef
_ -> throwError (WithExpression "applying non-functional object" expr)
eval :: Environment -> Expression -> IOThrowsError Value
eval env expr = do
objRef <- liftIO (makeClosure env expr)
val <- cEval objRef
return val
evalList :: Environment -> [Expression] -> IOThrowsError [Value]
evalList _ [] = return []
evalList env (expr:exprs) = do
val <- eval env expr
vals <- evalList env exprs
return (val:vals)
cEval1 :: ObjectRef -> IOThrowsError Value
cEval1 objRef = do
obj <- liftIO (readIORef objRef)
case obj of
Closure env expr ->
do val <- eval1 env expr
liftIO (writeIORef objRef (Value val))
return val
Value (Tuple [objRef2]) ->
do val <- cEval1 objRef2
liftIO (writeIORef objRef (Value val))
return val
Value val -> return val
cEval :: ObjectRef -> IOThrowsError Value
cEval objRef = do
val1 <- cEval1 objRef
evalValue val1
cEvalList :: [ObjectRef] -> IOThrowsError ()
cEvalList [] = return ()
cEvalList (objRef:objRefs) = do
cEval objRef
cEvalList objRefs
evalValue :: Value -> IOThrowsError Value
evalValue (InductiveData cons objRefs) = do
cEvalList objRefs
return (InductiveData cons objRefs)
evalValue (Tuple objRefs) = do
cEvalList objRefs
return (Tuple objRefs)
evalValue (Collection innerVals) = do
evalInnerVals innerVals
return (Collection innerVals)
evalValue val = return val
eval1Loop :: Environment -> Value -> IOThrowsError Value
eval1Loop env (Loop var1 var2 m n expr1 expr2) = do
mObjRef <- liftIO (newIORef (Value (Integer m)))
if m > n
then do eval1 (([((var2,[]),mObjRef)]):env) expr2
else do loopObjRef <- liftIO (newIORef (Value (Loop var1 var2 (m + 1) n expr1 expr2)))
eval1 ([((var1,[]),loopObjRef),((var2,[]),mObjRef)]:env) expr1
eval1Loop _ _ = throwError (Default "eval1Loop")
evalInnerVals :: [InnerValue] -> IOThrowsError ()
evalInnerVals [] = return ()
evalInnerVals (Element objRef : rest) = do
cEval objRef
evalInnerVals rest
evalInnerVals (SubCollection objRef : rest) = do
cEval objRef
evalInnerVals rest
evalMatchExp :: Environment -> ObjectRef -> ObjectRef -> [MatchClause] -> IOThrowsError Value
evalMatchExp env typObjRef tgtObjRef (MatchClause pat expr:rest) = do
patObjRef <- liftIO (makeClosure env pat)
matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]
case matchs of
[] -> evalMatchExp env typObjRef tgtObjRef rest
(frame:_) -> do objRef <- liftIO (makeClosure (frame:env) expr)
cEval1 objRef
evalMatchExp _ _ _ _ = throwError (Default "end of match clause")
evalMatchAllExp :: Environment -> ObjectRef -> ObjectRef -> MatchClause -> IOThrowsError Value
evalMatchAllExp env typObjRef tgtObjRef (MatchClause pat expr) = do
patObjRef <- liftIO (makeClosure env pat)
matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]
innerVals <- evalMatchAllExpHelper env matchs expr
retObjRef <- liftIO (newIORef (Value (Collection innerVals)))
cEval retObjRef
evalMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue]
evalMatchAllExpHelper _ [] _ = return []
evalMatchAllExpHelper env (frame:frames) expr = do
objRef <- liftIO (makeClosure (frame:env) expr)
rest <- evalMatchAllExpHelper env frames expr
return (Element objRef:rest)
--
-- Pattern Match
--
patternMatch :: [MState] -> IOThrowsError [Frame]
patternMatch [] = return []
patternMatch ((MState frame []):rest) = do
frames <- patternMatch rest
return (frame:frames)
patternMatch ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef):atoms)):states) = do
patObj <- liftIO (readIORef patObjRef)
case patObj of
Value (World _) -> throwError (Default "patternMatch: not a pattern")
Value (Character _) -> throwError (Default "patternMatch: not a pattern")
Value (Integer _) -> throwError (Default "patternMatch: not a pattern")
Value (Double _) -> throwError (Default "patternMatch: not a pattern")
Value (Collection _) -> throwError (Default "patternMatch: not a pattern")
Value (Function _ _ _) -> throwError (Default "patternMatch: not a pattern")
Value (Type _) -> throwError (Default "patternMatch: not a pattern")
Value (DestructorFunction _) -> throwError (Default "patternMatch: not a pattern")
Value (BuiltinFunction _) -> throwError (Default "patternMatch: not a pattern")
Value WildCard -> patternMatch ((MState frame atoms):states)
Value (PatVar var nums) ->
do typVal <- cEval1 typObjRef
case typVal of
Type tf -> let mObjRef = getValueFromFrame tf ("var-match",[]) in
case mObjRef of
Nothing -> throwError (Default "no method in type: var-match")
Just fnObjRef ->
do ret <- cApply fnObjRef [tgtObjRef]
objRefs <- collectionToObjRefList ret
patternMatch ((map (\objRef -> (MState (((var,nums),objRef):frame)
(map (\(MAtom (PClosure bf2 pat) tgt typ) -> (MAtom (PClosure (((var,nums),objRef):bf2) pat) tgt typ))
atoms)))
objRefs) ++ states)
_ -> throwError (Default "patternMatch: patVar not type")
Value (Tuple pats) ->
do tgts <- tupleToObjRefList tgtObjRef
typs <- tupleToObjRefList typObjRef
patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states)
Value (InductiveData con pats) ->
do typVal <- cEval1 typObjRef
case typVal of
Type tf -> let mObjRef = getValueFromFrame tf ("inductive-match",[]) in
case mObjRef of
Nothing -> throwError (Default "no method in type: var-match")
Just fnObjRef ->
do fnObj <- cEval1 fnObjRef
case fnObj of
DestructorFunction deconInfo ->
do indRet <- inductiveMatch deconInfo con tgtObjRef
case indRet of
(nTypObjRef, nTgtsObjRef) ->
do inTypObjRefs <- tupleToObjRefList nTypObjRef
inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef
inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs
patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))
pats inTgtObjRefs inTypObjRefs) ++ atoms)))
inTgtObjRefss) ++ states)
_ -> throwError (Default "patternMatch: inductive-match is not destructor")
Value (PredPat predName pats) ->
do typVal <- cEval1 typObjRef
case typVal of
Type tf -> let mObjRef = getValueFromFrame tf (predName,[]) in
case mObjRef of
Nothing -> throwError (Default "no method in type: var-match")
Just fnObjRef ->
do ret <- cApply fnObjRef (pats ++ [tgtObjRef])
case ret of
(InductiveData "true" []) -> patternMatch ((MState frame atoms):states)
(InductiveData "false" []) -> patternMatch states
_ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean")
Value (AndPat pats) ->
patternMatch ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states)
Value (OrPat pats) ->
patternMatch ((map (\pat -> (MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms)))
pats) ++ states)
Value (CutPat pat) ->
do retFrames <- patternMatch [(MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))]
case retFrames of
[] -> return []
_ -> do restFrames <- patternMatch states
return (retFrames ++ restFrames)
Closure env expr ->
do patObj2 <- eval1 (bf:env) expr
patObjRef2 <- liftIO (newIORef (Value patObj2))
patternMatch ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef):atoms)):states)
cApply :: ObjectRef -> [ObjectRef] -> IOThrowsError Value
cApply fnObjRef argObjRefs = do
fnVal <- cEval1 fnObjRef
case fnVal of
BuiltinFunction builtinFn -> do argVals <- liftIO (objRefListToValueList argObjRefs)
retVal <- builtinFn argVals
return retVal
Function funEnv fpat body -> do objRef <- liftIO (newIORef (Value (Tuple argObjRefs)))
frame <- makeFrame fpat objRef
retObjRef <- liftIO (makeClosure (frame:funEnv) body)
retVal <- cEval1 retObjRef
return retVal
_ -> throwError (Default "cApply: not a function")
map3 :: ((a,b,c) -> d) -> [a] -> [b] -> [c] -> [d]
map3 fn [] [] [] = []
map3 fn (x:xs) (y:ys) (z:zs) = (fn (x,y,z)):(map3 fn xs ys zs)
--
-- Inductive Match
--
inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef,ObjectRef)
inductiveMatch [] _ _ = throwError (Default "inductiveMatch: not matched any clauses")
inductiveMatch ((con,_,[]):rest) pcon tgtObjRefRef =
if (con == pcon)
then throwError (Default "inductiveMatch: not matched any clauses")
else inductiveMatch rest pcon tgtObjRefRef
inductiveMatch ((con,typObjRef,((env,ppat,expr):cls)):rest) pcon tgtObjRefRef =
if (con == pcon)
then do mPpmRet <- primitivePatternMatch ppat tgtObjRefRef
case mPpmRet of
Nothing -> inductiveMatch ((con,typObjRef,cls):rest) pcon tgtObjRefRef
Just ppmRet -> do ret <- liftIO (makeClosure (ppmRet:env) expr)
return (typObjRef,ret)
else inductiveMatch rest pcon tgtObjRefRef
--
-- Primitive Pattern Match
--
primitivePatternMatch :: PrimePat -> ObjectRef -> IOThrowsError (Maybe Frame)
primitivePatternMatch PrimeWildCard _ = return (Just [])
primitivePatternMatch (PrimePatCharacter c) objRef = do
val <- cEval1 objRef
case val of
Character c2 -> if c == c2
then return (Just [])
else return Nothing
_ -> throwError (Default "primitive : not character to primitive character pat")
primitivePatternMatch (PrimePatInteger n) objRef = do
val <- cEval1 objRef
case val of
Integer n2 -> if n == n2
then return (Just [])
else return Nothing
_ -> throwError (Default "primitive : not integer to primitive integer pat")
--primitivePatternMatch (PrimePatDouble d) objRef = do
-- val <- cEval1 objRef
-- case val of
-- Integer d2 -> if d == d2
-- then return (Just (Frame []))
-- else return Nothing
-- _ -> throwError (Default "primitive : not double to primitive double pat")
primitivePatternMatch (PrimePatVar name) objRef = return (Just [((name,[]), objRef)])
primitivePatternMatch (InductivePrimePat pCons pPats) objRef = do
val <- cEval1 objRef
case val of
InductiveData cons objRefs -> if pCons == cons
then primitivePatternMatchList pPats objRefs
else return Nothing
_ -> do valStr <- liftIO (showValue val)
throwError (Default ("primitive : not inductive value to primitive inductive pattern : " ++ valStr))
primitivePatternMatch EmptyPat objRef = do
val <- cEval1 objRef
b <- isEmptyCollection val
if b
then return (Just [])
else return Nothing
primitivePatternMatch (ConsPat carPat cdrPat) objRef = do
val <- cEval1 objRef
b <- isEmptyCollection val
if b
then return Nothing
else do (carObjRef, cdrObjRef) <- consDestruct val
mCarFrame <- primitivePatternMatch carPat carObjRef
case mCarFrame of
Nothing -> return Nothing
Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrObjRef
case mCdrFrame of
Nothing -> return Nothing
Just cdrFrame -> return (Just (carFrame ++ cdrFrame))
primitivePatternMatch (SnocPat rdcPat racPat) objRef = do
val <- cEval1 objRef
b <- isEmptyCollection val
if b
then return Nothing
else do (racObjRef, rdcObjRef) <- snocDestruct val
mRacFrame <- primitivePatternMatch racPat racObjRef
case mRacFrame of
Nothing -> return Nothing
Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcObjRef
case mRdcFrame of
Just rdcFrame -> return (Just (racFrame ++ rdcFrame))
Nothing -> return Nothing
primitivePatternMatchList :: [PrimePat] -> [ObjectRef] -> IOThrowsError (Maybe Frame)
primitivePatternMatchList [] [] = return (Just [])
primitivePatternMatchList (pat:pats) (objRef:objRefs) = do
mFrame <- primitivePatternMatch pat objRef
case mFrame of
Nothing -> return Nothing
Just frame -> do mRestFrame <- primitivePatternMatchList pats objRefs
case mRestFrame of
Nothing -> return Nothing
Just restFrame -> return (Just (frame ++ restFrame))
primitivePatternMatchList _ _ = throwError (Default "primitivePatternMatchList : number of patterns and targets are different")
isEmptyCollection :: Value -> IOThrowsError Bool
isEmptyCollection (Collection []) = return True
isEmptyCollection (Collection (Element _:_)) = return False
isEmptyCollection (Collection (SubCollection subRef:rest)) = do
subVal <- cEval1 subRef
b <- isEmptyCollection subVal
if b
then isEmptyCollection (Collection rest)
else return False
isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection")
consDestruct :: Value -> IOThrowsError (ObjectRef, ObjectRef)
consDestruct (Collection (Element eRef:rest)) = do
restRef <- liftIO (newIORef (Value (Collection rest)))
return (eRef, restRef)
consDestruct (Collection (SubCollection subRef:rest)) = do
subVal <- cEval1 subRef
b <- isEmptyCollection subVal
if b
then consDestruct (Collection rest)
else do (carRef, cdrRef) <- consDestruct subVal
cdrVal <- cEval1 cdrRef
case cdrVal of
Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest))))
return (carRef, restRef)
_ -> undefined
consDestruct (Collection []) = throwError (Default "empty collection")
consDestruct _ = throwError (Default "consDestruct : not collection")
snocDestruct :: Value -> IOThrowsError (ObjectRef, ObjectRef)
snocDestruct (Collection innerVals) =
case reverse innerVals of
Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest))))
return (eRef, restRef)
SubCollection subRef:rest
-> do subVal <- cEval1 subRef
b <- isEmptyCollection subVal
if b
then snocDestruct (Collection (reverse rest))
else do (racRef, rdcRef) <- snocDestruct subVal
rdcVal <- cEval1 rdcRef
case rdcVal of
Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs))))
return (racRef, restRef)
_ -> undefined
_ -> undefined
snocDestruct _ = throwError (Default "snocDestruct : not collection")
--
-- Builtin Functions
--
getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value)
getBuiltin name =
case name of
"read" -> Just builtinRead
"write" -> Just builtinWrite
"print" -> Just builtinPrint
"read-char" -> Just builtinReadChar
"write-char" -> Just builtinWriteChar
"int-to-float" -> Just builtinIntToFloat
"ceiling" -> Just builtinCeiling
"floor" -> Just builtinFloor
"truncate" -> Just builtinTruncate
"round" -> Just builtinRound
"=" -> Just builtinEqual
"compare-integer" -> Just builtinCompareInteger
"+" -> Just builtinPlus
"-" -> Just builtinMinus
"*" -> Just builtinMultiply
"dev" -> Just builtinDevide
"mod" -> Just builtinMod
"=f" -> Just builtinEqualFloat
"compare-float" -> Just builtinCompareFloat
"+f" -> Just builtinPlusFloat
"-f" -> Just builtinMinusFloat
"*f" -> Just builtinMultiplyFloat
"/f" -> Just builtinDevideFloat
-- "pi" -> Just builtinPi
"exp" -> Just builtinExp
"log" -> Just builtinLog
"sqrt" -> Just builtinSqrt
"**" -> Just builtinPower
"log-base" -> Just builtinLogBase
"sin" -> Just builtinSin
"cos" -> Just builtinCos
"tan" -> Just builtinTan
"asin" -> Just builtinAsin
"acos" -> Just builtinAcos
"atan" -> Just builtinAtan
"sinh" -> Just builtinSinh
"cosh" -> Just builtinCosh
"tanh" -> Just builtinTanh
"asinh" -> Just builtinAsinh
"acosh" -> Just builtinAcosh
"atanh" -> Just builtinAtanh
_ -> Nothing
builtinRead :: [Value] -> IOThrowsError Value
builtinRead [(World actions)] = do
str <- liftIO (getExpressionHelper False 0)
val <- readValue str
ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])
return ret
builtinRead _ = throwError (Default "invalid args to read")
builtinWrite :: [Value] -> IOThrowsError Value
builtinWrite [(World actions), val] = do
valStr <- liftIO (showValue val)
liftIO (flushStr valStr)
return (World ((Write val):actions))
builtinWrite _ = throwError (Default "invalid args to write")
builtinPrint :: [Value] -> IOThrowsError Value
builtinPrint [(World actions), val] = do
str <- charCollectionToString val
liftIO (flushStr str)
return (World ((Print str):actions))
builtinPrint _ = throwError (Default "invalid args to print")
builtinReadChar :: [Value] -> IOThrowsError Value
builtinReadChar [(World actions)] = do
c <- liftIO getChar
ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])
return ret
builtinReadChar _ = throwError (Default "invalid args to read-char")
builtinWriteChar :: [Value] -> IOThrowsError Value
builtinWriteChar [(World actions), (Character c)] = do
liftIO (putChar c)
return (World ((Write (Character c)):actions))
builtinWriteChar _ = throwError (Default "invalid args to write-char")
builtinIntToFloat :: [Value] -> IOThrowsError Value
builtinIntToFloat [Integer n] = return (Double (fromInteger n))
builtinIntToFloat _ = throwError (Default "invalid args to int-to-float")
builtinCeiling :: [Value] -> IOThrowsError Value
builtinCeiling [Double d] = return (Integer (ceiling d))
builtinCeiling _ = throwError (Default "invalid args to ceiling")
builtinFloor :: [Value] -> IOThrowsError Value
builtinFloor [Double d] = return (Integer (floor d))
builtinFloor _ = throwError (Default "invalid args to floor")
builtinTruncate :: [Value] -> IOThrowsError Value
builtinTruncate [Double d] = return (Integer (truncate d))
builtinTruncate _ = throwError (Default "invalid args to truncate")
builtinRound :: [Value] -> IOThrowsError Value
builtinRound [Double d] = return (Integer (round d))
builtinRound _ = throwError (Default "invalid args to round")
builtinEqual :: [Value] -> IOThrowsError Value
builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2)
then return (InductiveData "true" [])
else return (InductiveData "false" [])
builtinEqual _ = throwError (Default "invalid args to =")
builtinCompareInteger :: [Value] -> IOThrowsError Value
builtinCompareInteger [(Integer n1), (Integer n2)] = if (n1 == n2)
then return (InductiveData "equal" [])
else if (n1 < n2)
then return (InductiveData "less" [])
else return (InductiveData "greater" [])
builtinCompareInteger _ = throwError (Default "invalid args to compare-integer")
builtinPlus :: [Value] -> IOThrowsError Value
builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2))
builtinPlus _ = throwError (Default "invalid args to +")
builtinMinus :: [Value] -> IOThrowsError Value
builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2))
builtinMinus _ = throwError (Default "invalid args to -")
builtinMultiply :: [Value] -> IOThrowsError Value
builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2))
builtinMultiply _ = throwError (Default "invalid args to *")
builtinDevide :: [Value] -> IOThrowsError Value
builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2))
builtinDevide _ = throwError (Default "invalid args to dev")
builtinMod :: [Value] -> IOThrowsError Value
builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2))
builtinMod _ = throwError (Default "invalid args to mod")
builtinEqualFloat :: [Value] -> IOThrowsError Value
builtinEqualFloat [(Double n1), (Double n2)] = if (n1 == n2)
then return (InductiveData "true" [])
else return (InductiveData "false" [])
builtinEqualFloat _ = throwError (Default "invalid args to =f")
builtinCompareFloat :: [Value] -> IOThrowsError Value
builtinCompareFloat [(Double n1), (Double n2)] = if (n1 == n2)
then return (InductiveData "equal" [])
else if (n1 < n2)
then return (InductiveData "less" [])
else return (InductiveData "greater" [])
builtinCompareFloat _ = throwError (Default "invalid args to compare-float")
builtinPlusFloat :: [Value] -> IOThrowsError Value
builtinPlusFloat [(Double n1), (Double n2)] = return (Double (n1 + n2))
builtinPlusFloat _ = throwError (Default "invalid args to +f")
builtinMinusFloat :: [Value] -> IOThrowsError Value
builtinMinusFloat [(Double n1), (Double n2)] = return (Double (n1 - n2))
builtinMinusFloat _ = throwError (Default "invalid args to -f")
builtinMultiplyFloat :: [Value] -> IOThrowsError Value
builtinMultiplyFloat [(Double n1), (Double n2)] = return (Double (n1 * n2))
builtinMultiplyFloat _ = throwError (Default "invalid args to *f")
builtinDevideFloat :: [Value] -> IOThrowsError Value
builtinDevideFloat [(Double n1), (Double n2)] = return (Double (n1 / n2))
builtinDevideFloat _ = throwError (Default "invalid args to /f")
builtinExp :: [Value] -> IOThrowsError Value
builtinExp [Double d] = return (Double (exp d))
builtinExp _ = throwError (Default "invalid args to exp")
builtinLog :: [Value] -> IOThrowsError Value
builtinLog [Double d] = return (Double (log d))
builtinLog _ = throwError (Default "invalid args to log")
builtinSqrt :: [Value] -> IOThrowsError Value
builtinSqrt [Double d] = return (Double (sqrt d))
builtinSqrt _ = throwError (Default "invalid args to sqrt")
builtinPower :: [Value] -> IOThrowsError Value
builtinPower [(Double n1), (Double n2)] = return (Double (n1 ** n2))
builtinPower _ = throwError (Default "invalid args to **")
builtinLogBase :: [Value] -> IOThrowsError Value
builtinLogBase [(Double n1), (Double n2)] = return (Double (logBase n1 n2))
builtinLogBase _ = throwError (Default "invalid args to log-base")
builtinSin :: [Value] -> IOThrowsError Value
builtinSin [Double d] = return (Double (sin d))
builtinSin _ = throwError (Default "invalid args to sin")
builtinCos :: [Value] -> IOThrowsError Value
builtinCos [Double d] = return (Double (cos d))
builtinCos _ = throwError (Default "invalid args to cos")
builtinTan :: [Value] -> IOThrowsError Value
builtinTan [Double d] = return (Double (tan d))
builtinTan _ = throwError (Default "invalid args to tan")
builtinAsin :: [Value] -> IOThrowsError Value
builtinAsin [Double d] = return (Double (asin d))
builtinAsin _ = throwError (Default "invalid args to asin")
builtinAcos :: [Value] -> IOThrowsError Value
builtinAcos [Double d] = return (Double (acos d))
builtinAcos _ = throwError (Default "invalid args to acos")
builtinAtan :: [Value] -> IOThrowsError Value
builtinAtan [Double d] = return (Double (atan d))
builtinAtan _ = throwError (Default "invalid args to atan")
builtinSinh :: [Value] -> IOThrowsError Value
builtinSinh [Double d] = return (Double (sinh d))
builtinSinh _ = throwError (Default "invalid args to sinh")
builtinCosh :: [Value] -> IOThrowsError Value
builtinCosh [Double d] = return (Double (cosh d))
builtinCosh _ = throwError (Default "invalid args to cosh")
builtinTanh :: [Value] -> IOThrowsError Value
builtinTanh [Double d] = return (Double (tanh d))
builtinTanh _ = throwError (Default "invalid args to tanh")
builtinAsinh :: [Value] -> IOThrowsError Value
builtinAsinh [Double d] = return (Double (asinh d))
builtinAsinh _ = throwError (Default "invalid args to asinh")
builtinAcosh :: [Value] -> IOThrowsError Value
builtinAcosh [Double d] = return (Double (acosh d))
builtinAcosh _ = throwError (Default "invalid args to acosh")
builtinAtanh :: [Value] -> IOThrowsError Value
builtinAtanh [Double d] = return (Double (atanh d))
builtinAtanh _ = throwError (Default "invalid args to atanh")
--
-- For debug
--
debug :: String -> ObjectRef -> IOThrowsError ()
debug tag objRef = do
val <- cEval objRef
valStr <- liftIO $ showValue val
liftIO $ putStr $ tag ++ ": "
liftIO $ putStrLn valStr
debug2 :: String -> ObjectRef -> IOThrowsError ()
debug2 tag objRef = do
objStr <- liftIO $ showObjectRef objRef
liftIO $ putStr $ tag ++ ": "
liftIO $ putStrLn objStr