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

index.html

@@ -9,18 +9,17 @@
         <div id="elm-container">
         </div>
         <script>
-            var program = `
+            var program = `move(0, 0);
-move(0, 0);
 define line(x1, y1, x2, y2) {
     pen up;
     move(x1, y1);
     pen down;
     move(x2, y2);
-};
+}
 define nix(x, y, width, height) {
     call line (x, y, x + width, y + height);
     call line (x + width, y, x, y + height);
-};
+}
 call nix(0, 0, 20, 20);
 `
             var container = document.getElementById("elm-container");

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
@@ -90,7 +90,7 @@ parseExpr = oneOf [ lazy (\_ -> backtrackable parseSum), parseTerm ]
 parseProg : Parser LogoProg
 parseProg = sequence
     { start = ""
-    , separator = ";"
+    , separator = ""
     , end = ""
     , spaces = spaces
     , item = lazy (\_ -> parseCmd)
@@ -135,6 +135,8 @@ parseCall = succeed Call
         , item = parseExpr
         , trailing = Forbidden
         }
+    |. spaces
+    |. symbol ";"
 
 parsePenMode : Parser LogoPenMode
 parsePenMode = oneOf
@@ -147,6 +149,8 @@ parsePen = succeed Pen
     |. keyword "pen"
     |. spaces
     |= parsePenMode
+    |. spaces
+    |. symbol ";"
 
 parseMove : Parser LogoCmd
 parseMove = succeed Move
@@ -158,7 +162,10 @@ parseMove = succeed Move
     |. symbol ","
     |. spaces
     |= parseExpr
+    |. spaces
     |. symbol ")"
+    |. spaces
+    |. symbol ";"
 
 {-
 ======= Semantics Code =======
@@ -199,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
@@ -210,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
@@ -260,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
@@ -350,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 ] ]