Implemented if statements and lambdas. (#5)

Harper.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1292c5eacfd1a96f86a094038ec24eddeefd8228f9afd3eda0d7b94e16f50b6a
+-- hash: 861c4b90f8799dbbb3e331b8de6a3fa0fc17f243de164fccbe5ce3013eec8da9
 
 name:           Harper
 version:        0.1.0.0
@@ -30,7 +30,9 @@ library
       Harper.Abs
       Harper.Engine
       Harper.Engine.Comparable
+      Harper.Engine.Conditionals
       Harper.Engine.Object
+      Harper.Engine.Values
       Harper.Lexer
       Harper.Parser
       Harper.Printer

src/Harper/Abs.hs

@@ -154,6 +154,7 @@ data MatchStatementClause = MatchStmtClause Pattern Statement
 data ConditionalStatement
     = IfElifStmts IfStatement [ElseIfStatement]
     | IfElifElseStmts IfStatement [ElseIfStatement] ElseStatement
+    | LinCondStmt [IfStatement] -- Internal transformation.
   deriving (Eq, Ord, Show, Read)
 
 data IfStatement = IfStmt Value Statement

src/Harper/Engine.hs

@@ -13,7 +13,9 @@ import Data.List
 
 import Harper.Abs
 import Harper.Engine.Comparable
+import Harper.Engine.Conditionals
 import Harper.Engine.Object
+import Harper.Engine.Values
 import ErrM
 
 type Interpreter a = ReaderT Env (StateT Store (Writer String)) a
@@ -45,7 +47,12 @@ decls ds = do
     where 
         declToFun e (FDecl i params (FValBody body)) = case [i | FArg i <- params] of 
                                                            [] -> Thunk body e
-                                                           ps -> Fun ps body e
+                                                           ps -> Fun ps (RetValStmt body) e
+        declToFun e (FDecl i params (FStmtBody body)) = Fun [i | FArg i <- params] body e
+
+fBodyToStmt :: FunBody -> Statement
+fBodyToStmt (FStmtBody s) = s
+fBodyToStmt (FValBody v) = RetValStmt v
 
 eval :: Value -> Interpreter Object
 eval l@(LitVal (IntLit n))       = return $ PInt n
@@ -72,6 +79,11 @@ eval (AppVal v1 v2) = do
     o1 <- eval v1
     apply o1 v2
 
+eval (LamVal params body) = do
+    env <- ask
+    let ps = [i | LamArg (PatDecl (LocVDecl LocSVal (Decl i))) <- params]
+    return $ Fun ps (fBodyToStmt body) env
+
 eval (AddVal v1 v2)     = evalAddOp v1 v2
 eval (SubVal v1 v2)     = evalSubOp v1 v2
 eval (MulVal v1 v2)     = evalMulOp v1 v2
@@ -89,17 +101,42 @@ eval (OrVal v1 v2)      = evalOrOp v1 v2
 eval (NotVal v)         = evalNotOp v
 
 apply :: Object -> Value -> Interpreter Object
-apply (Fun (p:ps) v e) argV = do
+apply (Fun (p:ps) s e) argV = do
     st <- get
     env <- ask
     let l  = newloc st
         e' = Map.insert p l e
     modify (Map.insert l (Thunk argV env))
     case ps of
-        [] -> local (Map.union e') (eval v)
-        _  -> return $ Fun ps v e'
+        [] -> local (Map.union e') (exec s return (error "exec returned without a value"))
+        _  -> return $ Fun ps s e'
 apply _ _ = error "Applied to too many arguments"
 
+-- Execution uses continuation-passing-style to implement control flow. 
+-- Since statements can only be executed in a body of a function, they take at least two continuations:
+-- the "return value" continuation and execution continuation. Calling the kRet short-circuits back to
+-- the place of call. Using k continues the execution to the next statement.
+exec :: Statement -> (Object -> Interpreter Object) -> Interpreter Object -> Interpreter Object
+exec (RetValStmt v) kRet _ = do
+    o <- eval v
+    kRet o
+exec RetStmt kRet _ = kRet PUnit
+exec (StmtBlock []) _ k = k
+exec (StmtBlock (s:ss)) kRet k = exec s kRet (exec (StmtBlock ss) kRet k)
+exec (CondStmt (LinCondStmt ifs)) kRet k = execIfs ifs kRet k
+exec (CondStmt c) kRet k = exec (CondStmt (linearizeCond c)) kRet k
+
+-- Executes a linear conditional. 
+-- Looks for the first if with a predicate evaluating to true and executes that branch.
+execIfs :: [IfStatement] -> (Object -> Interpreter Object) -> Interpreter Object -> Interpreter Object
+execIfs [] kRet k = k
+execIfs ((IfStmt pred stmt):ifs) kRet k = do
+    b <- eval pred
+    case b of
+        PBool True  -> exec stmt kRet k
+        PBool False -> execIfs ifs kRet k
+        _           -> error "Conditional predicate must be a bool."
+
 -- OPERATORS
 
 evalAddOp :: Value -> Value -> Interpreter Object

src/Harper/Engine/Comparable.hs

@@ -11,10 +11,12 @@ instance Eq ComparableObject where
     (CmpObj (PBool b1)) == (CmpObj (PBool b2)) = b1 == b2
     (CmpObj (PStr s1))  == (CmpObj (PStr s2))  = s1 == s2
     (CmpObj (PChar c1)) == (CmpObj (PChar c2)) = c1 == c2
+    (CmpObj PUnit) == (CmpObj PUnit)           = True
     _ == _                                     = error "Type mismatch in equality operator"
 
 instance Ord ComparableObject where
     compare (CmpObj (PInt n1)) (CmpObj (PInt n2))   = compare n1 n2
     compare (CmpObj (PStr s1)) (CmpObj (PStr s2))   = compare s1 s2
     compare (CmpObj (PChar c1)) (CmpObj (PChar c2)) = compare c1 c2
+    compare (CmpObj PUnit) (CmpObj PUnit)           = EQ
     compare _ _                                     = error "Type mismatch in comparison operator"

src/Harper/Engine/Conditionals.hs

@@ -0,0 +1,21 @@
+module Harper.Engine.Conditionals (
+    linearizeCond
+)
+where
+
+import Harper.Abs
+import Harper.Engine.Values
+
+-- Turns a conditional statement into a linear conditional statement.
+-- Linear means a list of if statements where we assume that the first if with a true predicate
+-- will be the only one to execute.
+linearizeCond :: ConditionalStatement -> ConditionalStatement
+linearizeCond s@(LinCondStmt _) = s
+linearizeCond (IfElifStmts _if elifs) = LinCondStmt (_if:map elifToIf elifs)
+linearizeCond (IfElifElseStmts _if elifs _else) = LinCondStmt (_if:map elifToIf elifs ++ [elseToIf _else])
+
+elifToIf :: ElseIfStatement -> IfStatement
+elifToIf (ElifStmt v s) = IfStmt v s
+
+elseToIf :: ElseStatement -> IfStatement
+elseToIf (ElseStmt s) = IfStmt litTrue s

src/Harper/Engine/Object.hs

@@ -15,14 +15,15 @@ type Store = Map.Map Ptr Object
 type Env = Map.Map Ident Ptr
 
 data Object = Fun { params :: [Ident],
-                    body :: Value,
+                    body :: Statement,
                     env :: Env }
-              | Thunk { body :: Value,
+              | Thunk { value :: Value,
                         env :: Env }
               | PInt Integer
               | PBool Bool
               | PStr String
               | PChar Char
+              | PUnit
             deriving (Show, Eq, Ord)
 
 isValue :: Object -> Bool

src/Harper/Engine/Values.hs

@@ -0,0 +1,13 @@
+module Harper.Engine.Values
+where
+
+import Harper.Abs
+
+litTrue :: Value
+litTrue = LitVal (BoolLit BTrue)
+
+litFalse :: Value
+litFalse = LitVal (BoolLit BFalse)
+
+unit :: Value
+unit = UnitVal -- TODO: Turn into a literal.

test/Spec.hs

@@ -57,6 +57,42 @@ issue1_lazy = TProg "\
 \main = true or (fun 42);"
     (PBool True)
 
+issue2_fac = TProg "\
+\fac n = {\
+\  if (n <= 0) {\
+\    return 1;\
+\  }\
+\  else {\
+\    return fac (n - 1) * n;\
+\  }\
+\};\
+\\n\
+\main = fac 42;\
+\"
+    (PInt 1405006117752879898543142606244511569936384000000000)
+
+issue2_lam = TProg "\
+\f n = {\
+\  if n mod 2 == 0 {\
+\    return (\val x val y => x * y * n);\
+\  }\
+\  else if n == 37 {\
+\    return (\val x val y => 42);\
+\  }\
+\  else {\
+\    return (\val x val y => x + y + n);\
+\  }\
+\};\
+\\n\
+\main = f 42 3 4 == 504 and \
+\       f 37 100 100 == 42 and \
+\       f 37 1000 1000 == 42 and \
+\       f 0 2 2 == 0 and \
+\       f 1 2 3 == 6 and \
+\       f 17 37 47 == 101;\
+\"
+    (PBool True)
+
 testProg :: TestProgram -> Test.HUnit.Test
 testProg (TProg i o) = TestCase (assertEqual "Expected output" o run)
     where run = let ts = lexer i