--
-- Copyright (c)2007 Chris Pressey, Cat's Eye Technologies.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
--
-- 1. Redistributions of source code must retain the above copyright
-- notices, this list of conditions and the following disclaimer.
-- 2. Redistributions in binary form must reproduce the above copyright
-- notices, this list of conditions, and the following disclaimer in
-- the documentation and/or other materials provided with the
-- distribution.
-- 3. Neither the names of the copyright holders nor the names of their
-- contributors may be used to endorse or promote products derived
-- from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-- COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
--
-----------------------------------------------------------------------
-- ======================= Monadic Interpreter ===================== --
-----------------------------------------------------------------------
--
-- This interpreter performs I/O. It is not as straightforward as
-- PureInterp, as it must frame every function in terms of IO monads,
-- which tends to obscure the logic of the interpreter somewhat.
--
module MonadInterp where
import qualified Data.Char as Char
import Map
import AST
import Primitive
--
-- The eval* functions are passed a store and a continuation (cc).
--
-- The store maps VarName objects to their values (Integers).
--
-- The continuation is used with the loop and repeat constructs.
-- It is not a full-blown continuation in the sense of being a
-- function which represents the entire rest of the computation.
-- Rather, it represents only the matchings between occurrences
-- of loop and occurrences of repeat.
--
-- The continuation is implemented as list of NumExprs, where the
-- head NumExpr is the most recently encountered (innermost) loop
-- expression. Each loop expression extends the continuation with
-- the expression being looped around, and a repeat expression
-- executes the continuation.
--
evalBool :: BoolExpr -> Map VarName Integer -> [NumExpr] -> IO Bool
evalBool (BoolOp op b1 b2) store cc = do
val1 <- evalBool b1 store cc
val2 <- evalBool b2 store cc
return (applyBoolOp op val1 val2)
evalBool (RelOp op e1 e2) store cc = do
val1 <- evalNum e1 store cc
val2 <- evalNum e2 store cc
return (applyRelOp op val1 val2)
evalBool (Not b) store cc = do
val <- evalBool b store cc
return (not val)
evalBool (BoolConst b) store cc = do
return b
evalNum :: NumExpr -> Map VarName Integer -> [NumExpr] -> IO Integer
evalNum (NumOp op e1 e2) store cc = do
val1 <- evalNum e1 store cc
val2 <- evalNum e2 store cc
return (applyNumOp op val1 val2)
evalNum (NumConst i) store cc = do
return i
evalNum (IfExpr b e1 e2) store cc = do
result <- evalBool b store cc
evalNum (if result then e1 else e2) store cc
evalNum (VarRef v) store cc = do
return (get v store 0)
evalNum (Let v e1 e2) store cc = do
val <- evalNum e1 store cc
evalNum e2 (set v val store) cc
evalNum (Loop e) store cc = evalNum e store ((Loop e):cc)
evalNum (Repeat) store cc = evalNum (head cc) store (tail cc)
evalNum (ValueOf v s) store cc = do
newStore <- interpret s store
return (get v newStore 0)
evalNum (Input v e) store cc = do
symbol <- getChar
evalNum e (set v (Prelude.fromIntegral (Char.ord symbol)) store) cc
interpret :: Statement -> Map VarName Integer -> IO (Map VarName Integer)
interpret (Block []) store = do
return store
interpret (Block (s:rest)) store = do
newStore <- interpret s store
interpret (Block rest) newStore
interpret (Var v s) store = interpret s store
interpret (Assign v e) store = do
val <- evalNum e store []
return (set v val store)
interpret (IfStmt b s1 s2) store = do
result <- evalBool b store []
interpret (if result then s1 else s2) store
interpret (While b s) store = do
result <- evalBool b store []
loop result
where
loop True = do
newStore <- interpret s store
interpret (While b s) newStore
loop False = do
return store
interpret (Print e) store = do
val <- evalNum e store []
putChar (Char.chr (Prelude.fromIntegral val))
return store