Get rid of the Y combinator.

It's a bit overcomplicated. We can rely on the fact that parsers
are functions.

1 files changed, 72 insertions, 73 deletions

diff --git a/parser.sml b/parser.sml
index 930431f..a907edf 100644
--- a/parser.sml
+++ b/parser.sml
@@ -14,8 +14,7 @@ struct
   datatype message = Unexpected of string | Expected of string
   datatype parseError = ParseError of sourceLoc * message list
   datatype hints = Hints of string list
-  type 'a parserResponse = response * (parseError, 'a * state * hints) Either.either
-  type 'a parser = state -> 'a parserResponse
+  type 'a parser = state -> response * (parseError, 'a * state * hints) Either.either
 
   val reservedWords =
     [ "abstype", "and", "andalso", "as", "case", "datatype", "do", "else"
@@ -44,11 +43,11 @@ struct
 
   fun printError (ParseError (loc, msgs)) : string =
     let
-      val unexpect = List.mapPartial (fn (Unexpected x) => SOME x | _ => NONE) msgs
+      val unexpect = List.mapPartial (fn Unexpected x => SOME x | _ => NONE) msgs
       val showUnexpect = case unexpect of
                            [] => ""
                          | s :: _ => "unexpected " ^ s ^ ";\n"
-      val expect = List.mapPartial (fn (Expected s) => SOME s | _ => NONE) msgs
+      val expect = List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs
     in
         printSourceLoc loc ^ " Syntax error:\n"
       ^ showUnexpect
@@ -77,10 +76,11 @@ struct
   fun newState (fileName : string) (fileStream : TextIO.instream) : state =
     State (TextIO.getInstream fileStream, newLoc fileName, makeUserState defaultInfixOperators)
 
-  fun updateUserState (f : userState -> userState) (State (stream, loc, us) : state) : userState parserResponse =
-    let val st' = f us
-    in (Empty, Either.Right (st', State (stream, loc, st'), Hints []))
-    end
+  fun updateUserState (f : userState -> userState) : userState parser =
+    fn State (stream, loc, us) =>
+      let val st' = f us
+      in (Empty, Either.Right (st', State (stream, loc, st'), Hints []))
+      end
 
   val getUserState : userState parser = updateUserState (fn x => x)
 
@@ -94,7 +94,7 @@ struct
 
   fun withHints (Hints hints) (ParseError (loc, msgs)) : parseError = ParseError (loc, map Expected hints @ msgs)
 
-  fun errToHints (ParseError (_, msgs)) = Hints (List.mapPartial (fn (Expected s) => SOME s | _ => NONE) msgs)
+  fun errToHints (ParseError (_, msgs)) = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs)
 
   fun compareLoc (SourceLoc (_, r1, c1), SourceLoc (_, r2, c2)) : order =
     case Int.compare (r1, r2) of
@@ -108,15 +108,16 @@ struct
     | GREATER => e1
     | LESS => e2
 
-  fun bind (p : 'a parser) (f : 'a -> 'b parser) (st : state) : 'b parserResponse =
-    case p st of
-      (consumed1, Either.Right (a, st', hints)) =>
-        (case (f a) st' of
-          (Consumed, Either.Right success) => (Consumed, Either.Right success)
-        | (Empty, Either.Right (b, st'', hints')) => (consumed1, Either.Right (b, st'', mergeHints hints hints'))
-        | (Consumed, Either.Left err) => (Consumed, Either.Left (withHints hints err))
-        | (Empty, Either.Left err) => (consumed1, Either.Left (withHints hints err)))
-    | (consumed, Either.Left err) => (consumed, Either.Left err)
+  fun bind (p : 'a parser) (f : 'a -> 'b parser) : 'b parser =
+    fn st =>
+      case p st of
+        (consumed1, Either.Right (a, st', hints)) =>
+          (case (f a) st' of
+            (Consumed, Either.Right success) => (Consumed, Either.Right success)
+          | (Empty, Either.Right (b, st'', hints')) => (consumed1, Either.Right (b, st'', mergeHints hints hints'))
+          | (Consumed, Either.Left err) => (Consumed, Either.Left (withHints hints err))
+          | (Empty, Either.Left err) => (consumed1, Either.Left (withHints hints err)))
+      | (consumed, Either.Left err) => (consumed, Either.Left err)
 
   fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2)
 
@@ -142,10 +143,11 @@ struct
 
   fun (p : 'a parser) <$ (x : 'b) : 'b parser = (fn _ => x) <$> p
 
-  fun try (p : 'a parser) (st : state) : 'a parserResponse =
-    case p st of
-      (Consumed, Either.Left err) => (Empty, Either.Left err)
-    | res => res
+  fun try (p : 'a parser) : 'a parser =
+    fn st =>
+      case p st of
+        (Consumed, Either.Left err) => (Empty, Either.Left err)
+      | res => res
 
   fun updatePosChar (SourceLoc (file, row, column)) (c : char) : sourceLoc =
     case c of
@@ -153,13 +155,14 @@ struct
     | #"\t" => SourceLoc (file, row, column + 8 - (column - 1) mod 8)
     | _ => SourceLoc (file, row, column + 1)
 
-  fun satisfy (pred : char -> bool) (State (stream, loc, us) : state) : char parserResponse =
-    case TextIO.StreamIO.input1 stream of
-      NONE => (Empty, Either.Left (ParseError (loc, [Expected "UNKNOWN"])))
-    | SOME (c, stream') =>
-        if pred c
-        then (Consumed, Either.Right (c, State (stream', updatePosChar loc c, us), Hints []))
-        else (Empty, Either.Left (ParseError (loc, [Expected "UNKNOWN"])))
+  fun satisfy (pred : char -> bool) : char parser =
+    fn State (stream, loc, us) =>
+      case TextIO.StreamIO.input1 stream of
+        NONE => (Empty, Either.Left (ParseError (loc, [Expected "UNKNOWN"])))
+      | SOME (c, stream') =>
+          if pred c
+          then (Consumed, Either.Right (c, State (stream', updatePosChar loc c, us), Hints []))
+          else (Empty, Either.Left (ParseError (loc, [Expected "UNKNOWN"])))
 
   fun parseChar (c : char) : char parser =
     satisfy (fn c' => c = c') <?> str c
@@ -171,20 +174,21 @@ struct
 
   fun manyErr () = raise Fail "many is applied to a parser that accepts an empty string"
 
-  fun many (p : 'a parser) (st : state) : 'a list parserResponse =
-    let fun walk xs s' =
-          case p s' of
-            (Consumed, Either.Right (x, s'', _)) => walk (x :: xs) s''
-          | (Consumed, Either.Left err) => (Consumed, Either.Left err)
-          | (Empty, Either.Right _) => manyErr ()
-          | (Empty, Either.Left err) => (Consumed, Either.Right (rev xs, s', errToHints err))
-    in
-      case p st of
-        (Consumed, Either.Right (x, s', _)) => walk [x] s'
-      | (Consumed, Either.Left err) => (Consumed, Either.Left err)
-      | (Empty, Either.Right _) => manyErr ()
-      | (Empty, Either.Left err) => (Empty, Either.Right ([], st, errToHints err))
-    end
+  fun many (p : 'a parser) : 'a list parser =
+    fn st =>
+      let fun walk xs s' =
+            case p s' of
+              (Consumed, Either.Right (x, s'', _)) => walk (x :: xs) s''
+            | (Consumed, Either.Left err) => (Consumed, Either.Left err)
+            | (Empty, Either.Right _) => manyErr ()
+            | (Empty, Either.Left err) => (Consumed, Either.Right (rev xs, s', errToHints err))
+      in
+        case p st of
+          (Consumed, Either.Right (x, s', _)) => walk [x] s'
+        | (Consumed, Either.Left err) => (Consumed, Either.Left err)
+        | (Empty, Either.Right _) => manyErr ()
+        | (Empty, Either.Left err) => (Empty, Either.Right ([], st, errToHints err))
+      end
 
   fun many1 (p : 'a parser) : 'a list parser =
     bind p (fn x =>
@@ -195,8 +199,8 @@ struct
 
   val spaces : unit parser = many space <$ () <?> "white space"
 
-  fun unexpected (s : string) (st : state) : 'a parserResponse =
-    (Empty, Either.Left (ParseError (stateLoc st, [Unexpected s])))
+  fun unexpected (s : string) : 'a parser =
+    fn st => (Empty, Either.Left (ParseError (stateLoc st, [Unexpected s])))
 
   val letter : char parser = satisfy Char.isAlpha <?> "letter"
 
@@ -236,7 +240,7 @@ struct
   val identifier : string parser =
     try
       (bind (alphaNumIdentifier <|> symbolicIdentifier <?> "identifier") (fn identName =>
-      bind getUserState (fn (UserState (ops, _)) =>
+      bind getUserState (fn UserState (ops, _) =>
       if List.exists (fn n => n = identName) reservedWords orelse List.exists (fn n => n = identName) ops
       then unexpected identName
       else const identName)))
@@ -295,7 +299,7 @@ struct
     const (x :: xs)))
 
   fun leftOp (i : int) : Syntax.expr parser =
-    bind getUserState (fn (UserState (_, opTable)) =>
+    bind getUserState (fn UserState (_, opTable) =>
     let val (leftOps, _) = Vector.sub (opTable, i)
     in
       case (map reserved leftOps) of
@@ -304,7 +308,7 @@ struct
     end)
 
   fun rightOp (i : int) : Syntax.expr parser =
-    bind getUserState (fn (UserState (_, opTable)) =>
+    bind getUserState (fn UserState (_, opTable) =>
     let val (_, rightOps) = Vector.sub (opTable, i)
     in
       case (map reserved rightOps) of
@@ -312,25 +316,25 @@ struct
       | op1 :: ops => Syntax.EIdent <$> foldl (op <|>) op1 ops
     end)
 
-  (* Values cannot be recursive. So we take the recursive call as a parameter,
-     and wire it together with the Y combinator. *)
-  fun expr' (expr : Syntax.expr parser) : Syntax.expr parser =
-    let
-      val atom =
-        Syntax.EInt <$> integer
-        <|> Syntax.EStr <$> stringConstant
-        <|> Syntax.EIdent <$> identifier
-        <|> (symbol "(" >>
-             bind (sepBy1 expr (symbol ",")) (fn exprs =>
-             symbol ")" >>
-             const
-               (case exprs of
-                 [x] => x
-               | _ => Syntax.ETuple exprs)))
-      val expr0 =
-        bind atom (fn e0 =>
-        foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom)
-    in
+  (* Values cannot be recursive, so we write each expression parser as a lambda. *)
+  val rec atom : Syntax.expr parser =
+    fn st =>
+      (Syntax.EInt <$> integer
+      <|> Syntax.EStr <$> stringConstant
+      <|> Syntax.EIdent <$> identifier
+      <|> (symbol "(" >>
+           bind (sepBy1 expr (symbol ",")) (fn exprs =>
+           symbol ")" >>
+           const
+             (case exprs of
+               [x] => x
+             | _ => Syntax.ETuple exprs)))) st
+  and expr0 : Syntax.expr parser =
+    fn st =>
+      bind atom (fn e0 =>
+      foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st
+  and expr : Syntax.expr parser =
+    fn st =>
       foldl
         (fn (i, exprLower) =>
           let
@@ -350,10 +354,5 @@ struct
             exprLeft expr1 <|> exprRight expr1 <|> const expr1)
           end)
         expr0
-        (List.tabulate (10, fn i => 9 - i))
-    end
-
-    fun Y (f : ('a -> 'b) -> 'a -> 'b) : 'a -> 'b = f (fn x => Y f x)
-
-    val expr = Y expr'
+        (List.tabulate (10, fn i => 9 - i)) st
 end