Merge pull request #435 from lepsa/let-bindings

Fixing an off by one error in Expr variable evaluation.

CHANGELOG.md

@@ -5,6 +5,7 @@
 
 * Other changes
   * Migrating StateC and StateE to a ReaderT/WriterT/StateT transformer stack, rather than being just StateT. [#432](https://github.com/Haskell-Things/ImplicitCAD/pull/432)
+  * Fixing an off by one error in variable stack lookups. [#431](https://github.com/Haskell-Things/ImplicitCAD/issues/431)
   * Fixing exponent operator precedence. [#428](https://github.com/Haskell-Things/ImplicitCAD/issues/428)
 
 # Version [0.4.0.0](https://github.com/Haskell-Things/ImplicitCAD/compare/v0.3.0.0...v0.4.0.0) (2022-06-06)

Graphics/Implicit/ExtOpenScad/Eval/Expr.hs

@@ -12,7 +12,7 @@
 
 module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where
 
-import Prelude (String, Maybe(Just, Nothing), ($), pure, zip, (!!), const, (<>), foldr, foldMap, (.), (<$>), traverse)
+import Prelude (String, Maybe(Just, Nothing), Bool (True), ($), elem, pure, zip, (&&), const, (<>), foldr, foldMap, (.), (<$>), traverse)
 
 import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   Pattern(Name, ListP, Wild),
@@ -32,7 +32,7 @@ import Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup)
 
 import qualified Graphics.Implicit.ExtOpenScad.Util.StateC as GIEUS (addMessage)
 
-import Data.List (elemIndex)
+import Data.Maybe (fromMaybe, isNothing)
 
 import Data.Map (fromList, lookup)
 
@@ -44,7 +44,7 @@ import Control.Monad (zipWithM)
 
 import Data.Text.Lazy (Text, unpack)
 
-import Data.Eq (Eq)
+import Data.Eq (Eq, (==))
 import Text.Show (Show)
 import Control.Monad.Writer.Class (tell)
 import Control.Monad.State.Lazy (get)
@@ -129,12 +129,28 @@ evalExpr' :: Expr -> StateE ([OVal] -> OVal)
 evalExpr' (Var (Symbol name)) = do
   Input (VarLookup varlookup) spos <- ask
   (ExprState namestack) <- get
-  case (lookup (Symbol name) varlookup, elemIndex (unpack name) namestack) of
-        (_, Just pos) -> pure (!! pos)
-        (Just val, _) -> pure $ const val
-        _             -> do
-          errorE spos ("Variable " <> name <> " not in scope")
-          pure $ const OUndefined
+  let v = lookup (Symbol name) varlookup
+      n = elem (unpack name) namestack
+  case (v, n) of
+    (_, True) -> pure $ \l ->
+      let m = foldr
+            -- Scan for variable names from the end of the list (newest), and also
+            -- ensure that we aren't overriding values if we have already found one.
+            -- All in all, this should ensure that we aren't seeing the off by 1 error
+            -- when looking up the values for function parameters as raised in this issue.
+            -- https://github.com/Haskell-Things/ImplicitCAD/issues/431
+            (\(n', v') z -> if isNothing z && unpack name == n' then pure v' else z)
+            Nothing $
+            -- Zip the names and incoming values so that when looking up values
+            -- we are ensuring that names are paired with values. When a LamE is evaled
+            -- it is possible that a name is pushed and then used before a value is pushed
+            -- and this zip neatly handles that situation.
+            zip namestack l
+      in fromMaybe OUndefined m
+    (Just o, _) -> pure $ const o
+    _ -> do
+      errorE spos ("Variable " <> name <> "not in scope")
+      pure $ const OUndefined
 
 -- Evaluate a literal value.
 evalExpr' (LitE  val) = pure $ const val
@@ -164,9 +180,14 @@ evalExpr' (fexpr :$ argExprs) = do
 -- Evaluate a lambda function.
 evalExpr' (LamE pats fexpr) = do
     fparts <- for pats $ \pat -> do
-        modify $ \s -> s { patterns = (unpack <$> patVars pat) <> patterns s}
+        -- Add new names to the end of the list so that names and values aren't
+        -- effectively shifted by 1 when a name is defined but the value hasn't been
+        -- calculated yet. This also allows us to neatly zip names and values ensuring
+        -- we are only looking at names with defined values.
+        modify $ \s -> s { patterns = patterns s <> (unpack <$> patVars pat)}
         pure $ \f xss -> OFunc $ \val -> case patMatch pat val of
-            Just xs -> f (xs <> xss)
+            -- Push values to the end once they are calculated.
+            Just xs -> f (xss <> xs)
             Nothing -> OError "Pattern match failed"
     fval <- evalExpr' fexpr
     pure $ foldr ($) fval fparts

tests/ExecSpec/Expr.hs

@@ -93,9 +93,27 @@ exprExec = do
       "lookup(0, [])" --> OUndefined
     it "Handles embedded statements" $ do
       "lookup(0+1, [[0*2, 0], [1+1, 4/2]])" --> num 1
+  describe "let bindings" $ do
+    it "Evaluates let bindings" $ do
+      -- basic let binding
+      "let (a = 1) [a, 1]" --> vect [1, 1]
+      -- Directly nested lets
+      "let (a = 1) let (b = a) [a, b]" --> vect [1, 1]
+      "let (a = 1) let (b = a) let (c = b) [a, b, c]" --> vect [1, 1, 1]
+      "let (a = 1) let (b = a) let (c = a) [a, b, c]" --> vect [1, 1, 1]
+      "let (a = 1) let (b = a) let (c = b + 1) [a, b, c]" --> vect [1, 1, 2]
+      "let (a = 1) let (b = a) let (c = a + 1) [a, b, c]" --> vect [1, 1, 2]
+      "let (a = 1) let (b = a+1) let (c = b+1) [a, b, c]" --> vect [1, 2, 3]
+      "let (a = 1) let (a = a+1) [a]" --> vect [2]
+      -- Indirect nesting
+      "let (a = 1) [a, let (b = a) b]" --> vect [1, 1]
+      -- Let name overloading
+      "let (a = 1) let (b = a + 1) let (a = b) [a, a]" --> vect [2, 2]
+      -- Scoped name overloading
+      "let (a = 1) let (b = a + 1) [a, let (a = b) a]" --> vect [1, 2]
   describe "operator precedence" $ do
     -- https://github.com/Haskell-Things/ImplicitCAD/issues/428
     it "Evaluates exponents correctly" $ do
       "2*3^2" --> num 18
       "-2^2" --> num 4
-      "-(2^2)" --> num (-4)
+      "-(2^2)" --> num (-4)

tests/MessageSpec/Message.hs

@@ -38,3 +38,5 @@ programExec =
       "module a(b,c){echo(b+c);}a(b=1,1);" --> oneMessage TextOut (SourcePosition 1 15 []) "2.0"
 --    it "warns about a missing argument" $
 --      "module a(b){echo(b);}a();" --> oneMessage TextOut (SourcePosition 1 13 []) "1.0"
+    it "handles let bindings in functions" $
+      "function foo(a,b,c) = let(output=b) [output,b]; echo(foo(1,2,3));" --> oneMessage TextOut (SourcePosition 1 49 []) "[2.0,2.0]"

tests/ParserSpec/Statement.hs

@@ -63,6 +63,10 @@ assignmentSpec = do
   it "handles function with let expression" $
     "function withlet ( b ) = let ( c = 5 ) b + c ; " -->
     single (Name "withlet" := LamE [Name "b"] (LamE [Name "c"] (plus [Var "b", Var "c"]) :$ [num 5]))
+  -- https://github.com/Haskell-Things/ImplicitCAD/issues/431
+  it "handles function with let expression" $
+    "function foo(a,b,c) = let(output=b) [output,b];" -->
+    single (Name "foo" := LamE [Name "a", Name "b", Name "c"] (LamE [Name "output"] (ListE [Var "output", Var "b"]) :$ [Var "b"]))
   it "handles nested indexing" $
     "x = [ y [ 0 ] - z * 2 ] ; " -->
     single ( Name "x" := ListE [minus [index [Var "y", num 0],