Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
278 lines (223 sloc) 9.87 KB
{-
Copyright © 2012 Daniel Tahara, Kartik Venkatraman
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
-}
module DTKV_Implementation where
import Data.Maybe
import Data.List
-------------------------------------------------------------------------------
-- Grammar for DTKV Language
{-
List of tokens:
-}
type Environment = (Program, Memory)
type Memory = (AssignmentFn, FnTable)
type AssignmentFn = [(Variable, Expression)]
type FnTable = [(Variable, Function)]
type Program = ([Statement], Expression) -- last expression is what to return
type Name = String
type Variable = (Name, Type)
--type Array a = [a]
data Type = Integer | Boolean | Str | Null deriving (Show, Eq)
data Statement = Assignment Variable Expression | FnDeclaration Name Function
| LoopBlock Loop | CondBlock Conditional deriving Show
data Expression = Data Atom | Var Variable | FnCall Variable [Expression]
deriving Show
data Atom = IntAtom Int | BoolAtom Bool | StrAtom String | NullAtom
deriving (Show, Eq, Ord)
-- make sure that Eq, Ord work properly
data Function = Fn Type [Variable] [Statement] Expression deriving Show
data Loop = For Expression Expression [Statement]
| While Expression [Statement] deriving Show
data Conditional = IfElse Expression [Statement] [Statement] deriving Show
-- if second list is empty, no else
-------------------------------------------------------------------------------
-- Functions to actually evaluate the statements
run :: Environment -> Atom
-- run (([], retExpr), m) = evaluate m retExpr
run (([], retExpr), m) = NullAtom
run ((stms, retExpr), m) = evaluate (execStms m stms) retExpr
execStms :: Memory -> [Statement] -> Memory
execStms m [] = m
execStms m (s:sts) = execStms (execSingleStm m s) sts
execSingleStm :: Memory -> Statement -> Memory
execSingleStm m@(a,fs) (Assignment v e) = (assign m a v value, fs)
where -- updatedMem = fst $ evaluate m e
value = Data (evaluate m e) -- eager semantics
execSingleStm m@(a,fs) (FnDeclaration n f) = (a, addFn fs n f)
execSingleStm m (LoopBlock l) = execLoop m l
execSingleStm m (CondBlock c) = execConditional m c
-------------------------------------------------------------------------------
-- Execution Functions for each statement type
execConditional :: Memory -> Conditional -> Memory
execConditional m (IfElse cond trueBody falseBody)
| evalCondition m cond = execStms m trueBody
| otherwise = execStms m falseBody
evalCondition :: Memory -> Expression -> Bool
evalCondition m e = atomToBool $ evaluate m e
atomToBool :: Atom -> Bool
atomToBool (IntAtom x) = x /= 0
atomToBool (BoolAtom b) = b
atomToBool (StrAtom s) = not $ null s
atomToBool NullAtom = False
execLoop :: Memory -> Loop -> Memory
execLoop m (For e1 e2 body) =
execForLoop (evaluate m e1) (evaluate m e2) m body
execLoop m (While cond body) =
execWhileLoop cond m body
-- execWhileLoop (evalCondition m cond) cond m body
execWhileLoop :: Expression -> Memory -> [Statement] -> Memory
execWhileLoop cond m body
| evalCondition m cond = execWhileLoop cond (execStms m body) body
| otherwise = m
{-
execWhileLoop :: Bool -> Expression -> Memory -> [Statement] -> Memory
execWhileLoop False _ m _ = m
execWhileLoop True cond m body =
execWhileLoop (evalCondition updatedMem cond) cond updatedMem body
where updatedMem = execStms m body
-}
execForLoop :: Atom -> Atom -> Memory -> [Statement] -> Memory
execForLoop a1 a2 m@(a,ft) body
| x > y = m
| otherwise =
execForLoop (IntAtom (succ x)) a2 (execStms updatedMem body) body
where x = getInt a1
y = getInt a2
updatedMem = (assign m a ("loopVar", Integer) (Data a1), ft)
getInt (IntAtom x) = x
-- Expression Evaluation
{- evaluateFn :: Memory -> FnExpression -> Atom -- (Memory, Atom)
evaluateFn m (Data atom) = evaluate m (Data atom)
evaluateFn m@(a,ft) (Var var) = evaluate m var
evaluateFn m (FnCall fVar args) = callFunction m fVar resolvedArgs
where resolvedArgs = map (evaluateFn m) args
--}
evaluate :: Memory -> Expression -> Atom -- (Memory, Atom)
evaluate m (Data atom) = atom
evaluate m@(a,ft) (Var var) =
if isNothing val then NullAtom else evaluate m (fromJust val)
where val = lookupVar var a
evaluate m (FnCall fVar args) = callFunction m fVar resolvedArgs
where resolvedArgs = map (evaluate m) args
-- Helpers
lookupVar :: Variable -> AssignmentFn -> Maybe Expression
lookupVar v a =
if isNothing index then Nothing else Just (snd $ a !! (fromJust index))
where index = findIndex (\x -> v == fst x) a
-- should work b/c both Name = String and Type derive Eq
lookupFn :: Variable -> FnTable -> Maybe Function
lookupFn v ft =
if isNothing index then Nothing else Just (snd $ ft !! (fromJust index))
where index = findIndex (\x -> v == fst x) ft -- see above comment
-- if it's already there, does nothing
addFn :: FnTable -> Name -> Function -> FnTable
addFn ft n fn = if isNothing $ lookupFn fVar ft then (fVar, fn):ft else ft
where fVar = (n, getFnType fn)
-- reassigns variable if exists in memory, otherwise, adds it
assign :: Memory -> AssignmentFn -> Variable -> Expression -> AssignmentFn
assign m [] v e = if (getVarType v) == (getExprType m e) then [(v,e)] else []
assign m (a:as) v e =
if fst a == v && (getVarType v) == (getExprType m e)
then (v,e):as else a:(assign m as v e)
-- Type Checking Helpers
getExprType :: Memory -> Expression -> Type
getExprType m (Data a) = getAtomType a
getExprType m (Var var) = getVarType var
getExprType m@(a,ft) (FnCall fVar body) =
if isNothing fn then Null else getFnType (fromJust fn)
where fn = lookup fVar ft
getAtomType :: Atom -> Type
getAtomType (IntAtom _) = Integer
getAtomType (BoolAtom _) = Boolean
getAtomType (StrAtom _) = Str
getAtomType NullAtom = Null
getVarType :: Variable -> Type
getVarType = snd
getFnType :: Function -> Type
getFnType (Fn retType _ _ _) = retType
-------------------------------------------------------------------------------
-- Function Evaluation
callFunction :: Memory -> Variable -> [Atom] -> Atom
-- memory would be a parameter if want side effects
-- [Atom] instead of [Expr] because we resolve them before entering new scope
-- do lookup first, then check matching types / standard library, then evaluate
-- type matching for library function s-- can make a triple with type signature
callFunction m@(a,ft) fVar@(n,t) args
| isJust (lookupUnaryFn n) =
(snd $ unaryLibFns !! (fromJust $ lookupUnaryFn n)) (args !! 0)
| isJust (lookupBinFn n) =
(snd $ binaryLibFns !! (fromJust $ lookupBinFn n)) (args !! 0) (args !! 1)
| otherwise =
if isJust $ lookupFn fVar ft
then evalUserFunction m (fromJust $ lookupFn fVar ft) args
else NullAtom
--userArgTypesMatch :: Memory -> [Variable] -> [Atom] -> Bool
--userArgTypesMatch m argVars args = length argVars == length args
-- && all (\x -> getVarType (fst x) == getAtomType (snd x)) (zip argVars args)
evalUserFunction :: Memory -> Function -> [Atom] -> Atom
-- need to work in side effect stuff; maybe make local mem and global mem?
-- then return (Memory, Atom)
evalUserFunction m@(a,ft) (Fn retType argVars body retExpr) args =
evaluate updatedMem retExpr
where updatedMem = (execStms (zip argVars (map Data args), ft) body)
-- so variables are local, functions are global scope
lookupBinFn :: Name -> Maybe Int
lookupBinFn n = findIndex (\x -> n == x) (map (fst . fst) binaryLibFns)
lookupUnaryFn :: Name -> Maybe Int
lookupUnaryFn n = findIndex (\x -> n == x) (map (fst . fst) unaryLibFns)
-------------------------------------------------------------------------------
-- Built-in Library Functions
exprTypesMatch :: Memory -> Expression -> Expression -> Bool
exprTypesMatch m e1 e2 = getExprType m e1 == getExprType m e2
-- Binary Functions
-- binaryType = Atom -> Atom -> Atom
binaryLibFns = [(("+", Integer), add),
(("-", Integer), subt),
(("*", Integer), mult),
(("/", Integer), divide),
(("%", Integer), modulus),
(("&&", Boolean), boolAnd),
(("||", Boolean), boolOr),
(("==", Boolean), eq),
((">", Boolean), gt),
(("<", Boolean), lt),
(("++", Str), concatenate)]
-- check that "deriving Ord" actually makes this work
add (IntAtom x1) (IntAtom x2) = IntAtom (x1 + x2)
subt (IntAtom x1) (IntAtom x2) = IntAtom (x1 - x2)
mult (IntAtom x1) (IntAtom x2) = IntAtom (x1 * x2)
divide (IntAtom x1) (IntAtom x2) = IntAtom (x1 `div` x2)
modulus (IntAtom x1) (IntAtom x2) = IntAtom (x1 `mod` x2)
boolAnd (BoolAtom b1) (BoolAtom b2) = BoolAtom (b1 && b2)
boolOr (BoolAtom b1) (BoolAtom b2) = BoolAtom (b1 || b2)
eq a1 a2 = BoolAtom (a1 == a2)
gt a1 a2 = BoolAtom (a1 > a2)
lt a1 a2 = BoolAtom (a1 < a2)
concatenate (StrAtom s1) (StrAtom s2) = StrAtom (s1 ++ s2)
-- Unary Functions
-- unaryType = Atom -> Atom
unaryLibFns = [(("abs", Integer), absVal),
(("neg", Integer), negative),
(("!", Boolean), boolNot),
(("head", Str), strHead),
(("tail", Str), strTail)]
absVal (IntAtom x) = IntAtom (abs x)
negative x = subt (IntAtom 0) x
boolNot (BoolAtom b) = BoolAtom (not b)
strHead (StrAtom s) = StrAtom [(head s)]
strTail (StrAtom s) = StrAtom (tail s)