Implement Eric's tips (primitive get and put) and add more error checks.

src/Main.elm

@@ -4,7 +4,7 @@ import Html.Events exposing (onInput)
 import Browser exposing (element)
 import Canvas exposing (Shape)
 import Dict exposing (Dict)
-import Parser exposing (Parser, Problem(..), DeadEnd, (|.), (|=), variable, succeed, symbol, int, spaces, map, oneOf, lazy, sequence, Trailing(..), keyword, run, backtrackable)
+import Parser exposing (Parser, Problem(..), DeadEnd, (|.), (|=), variable, succeed, symbol, int, spaces, map, oneOf, lazy, sequence, Trailing(..), keyword, run, backtrackable, end)
 import Color
 import Canvas exposing (Point, path, lineTo, circle, shapes, stroke, lineWidth, fill, rect)
 import Set
@@ -206,9 +206,42 @@ initialState =
     , board = []
     }
 
+updatePosition : Coord -> State -> State
+updatePosition c state =
+    let
+        newBoard = case state.penMode of
+            Up -> state.board
+            Down -> (state.pos, c)::state.board
+    in
+        { state | pos = c, board = newBoard }
+
+registerFunction : String -> Function -> State -> State
+registerFunction s f state = { state | scope = setScopeFunction s f state.scope }
+
+registerVariable : String -> Int -> State -> State
+registerVariable s v state = { state | scope = setScopeVariable s v state.scope }
+
+setPenMode : LogoPenMode -> State -> State
+setPenMode m state = { state | penMode = m}
+
+upScope : State -> State
+upScope state = { state | scope = Child state.scope Dict.empty Dict.empty }
+
+downScope : State -> State
+downScope state =
+    let
+        newScope = case state.scope of
+            End -> End
+            Child p _ _ -> p
+    in
+        { state | scope = newScope }
+
 unit : a -> Step a
 unit a state = Ok (a, state)
 
+err : String -> Step a
+err s state = Err s
+
 bind : Step a -> (a -> Step b) -> Step b
 bind sa f state = case sa state of
     Ok (a, newState) -> f a newState
@@ -217,45 +250,24 @@ bind sa f state = case sa state of
 rbind : (a -> Step b) -> Step a -> Step b
 rbind f sa = bind sa f
 
-updatePosition : Coord -> Step ()
+get : Step State
-updatePosition c state =
+get s = Ok (s, s)
-    let
-        newBoard = case state.penMode of
-            Up -> state.board
-            Down -> (state.pos, c)::state.board
-    in
-        Ok ((), { state | pos = c, board = newBoard })
 
-registerFunction : String -> Function -> Step ()
+put : State -> Step ()
-registerFunction s f state = Ok ((), { state | scope = setScopeFunction s f state.scope })
+put s _ = Ok ((), s)
 
-registerVariable : String -> Int -> Step ()
+modify : (State -> State) -> Step ()
-registerVariable s v state = Ok ((), { state | scope = setScopeVariable s v state.scope })
+modify f = get |> rbind (put << f)
-
-setPenMode : LogoPenMode -> Step ()
-setPenMode m state = Ok ((), { state | penMode = m})
-
-upScope : Step ()
-upScope state = Ok ((), { state | scope = Child state.scope Dict.empty Dict.empty })
-
-downScope : Step ()
-downScope state =
-    let
-        newScope = case state.scope of
-            End -> End
-            Child p _ _ -> p
-    in
-        Ok ((), { state | scope = newScope })
 
 lookupFunction : String -> Step Function
-lookupFunction s state = case scopeFunction s state.scope of
+lookupFunction s = get |> rbind (\st -> case scopeFunction s st.scope of
-    Just f -> Ok (f, state)
+    Just f -> unit f
-    Nothing -> Err ("No function with name " ++ s)
+    Nothing -> err ("No function with name " ++ s))
 
 lookupVariable : String -> Step Int
-lookupVariable s state = case scopeVariable s state.scope of
+lookupVariable s = get |> rbind (\st -> case scopeVariable s st.scope of
-    Just i -> Ok (i, state)
+    Just v -> unit v
-    Nothing -> Err ("No variable with name " ++ s)
+    Nothing -> err ("No variable with name " ++ s))
 
 evaluateExp : LogoExpr -> Step Int
 evaluateExp le = case le of
@@ -267,24 +279,27 @@ evaluateAllExps : List LogoExpr -> Step (List Int)
 evaluateAllExps = List.foldr (\x acc -> acc |> rbind (\vs -> evaluateExp x |> rbind (\v -> unit (v::vs)))) (unit [])
 
 registerAllVariables : List (String, Int) -> Step ()
-registerAllVariables = List.foldl (\(s, i) m -> bind m (\_ -> registerVariable s i)) (unit ())
+registerAllVariables = List.foldl (\(s, i) m -> bind m (\_ -> modify <| registerVariable s i)) (unit ())
 
-zip : List a -> List b -> List (a, b)
+zipParams : List String -> List Int -> Step (List (String, Int))
-zip la lb = case (la, lb) of
+zipParams la lb = case (la, lb) of
-    (a::lat, b::lbt) -> (a, b)::zip lat lbt
+    (a::lat, b::lbt) -> zipParams lat lbt |> rbind (\ps -> unit <| (a, b)::ps)
-    _ -> []
+    ([], []) -> unit []
+    ([], _) -> err "Passing too many parameters to macro call"
+    (_, []) -> err "Not enough parameters in macro call" 
 
 evaluateCmd : LogoCmd -> Step ()
 evaluateCmd c = case c of
-    Move l r -> evaluateExp l |> rbind (\x -> evaluateExp r |> rbind (\y -> updatePosition (x, y)))
+    Move l r -> evaluateExp l |> rbind (\x -> evaluateExp r |> rbind (\y -> modify <| updatePosition (x, y)))
-    Define n xs prg -> registerFunction n (xs, prg)
+    Define n xs prg -> modify <| registerFunction n (xs, prg)
-    Pen mode -> setPenMode mode
+    Pen mode -> modify <| setPenMode mode
     Call n args -> lookupFunction n
         |> rbind (\(ns, prg) -> evaluateAllExps args
-        |> rbind (\vs -> upScope
+        |> rbind (\vs -> modify upScope
-        |> rbind (\_ -> registerAllVariables (zip ns vs)
+        |> rbind (\_  -> zipParams ns vs
-        |> rbind (\_ -> evaluateAll prg
+        |> rbind (\ps -> registerAllVariables ps
-        |> rbind (\_ -> downScope)))))
+        |> rbind (\_  -> evaluateAll prg
+        |> rbind (\_  -> modify downScope))))))
 
 evaluateAll : LogoProg -> Step ()
 evaluateAll prg = List.foldl rbind (unit ()) <| List.map (\c _ -> evaluateCmd c) prg
@@ -357,9 +372,9 @@ init fs =
 view : Model -> Html Msg
 view m = 
     let 
+        parseResult = Result.mapError humanParseError (run (parseProg |. end) m.programText)
         evalResult = Result.map (\(_, s) -> s)
-            <| Result.andThen (\prg -> evaluateAll prg initialState)
+            <| Result.andThen (\prg -> evaluateAll prg initialState) parseResult
-            <| Result.mapError humanParseError (run parseProg m.programText)
         toRender = Result.withDefault initialState evalResult
         error = case evalResult of
             Err e -> [ p [ classList [ ("centered", True), ("error", True), ("shadow", True) ] ] [ text e ] ]