summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--elab.sml14
-rw-r--r--parser.sml188
2 files changed, 139 insertions, 63 deletions
diff --git a/elab.sml b/elab.sml
index 33f1a10..84b99a9 100644
--- a/elab.sml
+++ b/elab.sml
@@ -186,18 +186,6 @@ struct
in (patterns, occurrences, actions)
end
- (* There's ambiguity between pattern variables and constructors that can only
- * be resolved by looking up each pattern variable in the constructors map *)
- fun fixConstructors (env : env) (expr : Syntax.pat) =
- case expr of
- Syntax.PTuple t => Syntax.PTuple (map (fixConstructors env) t)
- | Syntax.PVar v =>
- if isSome (lookupCon [v] env)
- then Syntax.PCon ([v], Syntax.PTuple [])
- else Syntax.PVar v
- | Syntax.PCon (s, p) => Syntax.PCon (s, fixConstructors env p)
- | _ => expr
-
fun compilePatternMatching (env : env) ([] : Syntax.pat list list, _ : Syntax.lexp list, _ : Syntax.lexp list) : Syntax.lexp =
raise Fail "nonexhaustive match"
| compilePatternMatching env (patterns as firstRow :: rows, occurrences, actions) =
@@ -297,7 +285,6 @@ struct
and elabCase (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) =
let
- val arms = map (fn (p, e) => (fixConstructors env p, e)) arms
val patterns = transpose (patternMatrix (map (fn (x, _) => x) arms))
val occurrences = occurrenceVector expr (map (fn (x, _) => x) arms)
val actions = actionVector env expr arms
@@ -331,6 +318,7 @@ struct
| go _ [] _ = raise Fail "go empty"
in go env accessors s
end
+ | Syntax.EIdent [] => raise Fail "invalid syntax"
| Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
| Syntax.EInt i => Syntax.LInt i
| Syntax.EStr s => Syntax.LString s
diff --git a/parser.sml b/parser.sml
index ea68412..e464332 100644
--- a/parser.sml
+++ b/parser.sml
@@ -5,14 +5,16 @@ infix 0 <?>
structure Parser =
struct
+ structure StringMap = Map(type k = string val cmp = String.compare)
+
(* vector of length 10, holding the left and right associative infix operators for each precedence level. *)
type infixTable = (string list * string list) vector
- datatype userState = UserState of infixTable
- datatype sourceLoc = SourceLoc of string * int * int (* file * row * column *)
- datatype state = State of TextIO.StreamIO.instream * sourceLoc * userState
+ type userState = {infixTable : infixTable}
+ type sourceLoc = {file : string, row : int, column : int}
+ type state = {stream : TextIO.StreamIO.instream, loc : sourceLoc, userState : userState}
datatype response = Consumed | Empty
datatype message = Unexpected of string | Expected of string
- datatype parseError = ParseError of sourceLoc * message list
+ type parseError = {loc : sourceLoc, msgs : message list}
datatype hints = Hints of string list
type 'a parser = state -> response * (parseError, 'a * state * hints) Result.either
@@ -29,10 +31,10 @@ struct
val emptyInfixOperators : infixTable =
Vector.tabulate (10, fn _ => ([], []))
- fun printSourceLoc (SourceLoc (fileName, row, col)) : string =
- fileName ^ ":" ^ Int.toString row ^ "." ^ Int.toString col
+ fun printSourceLoc ({file, row, column} : sourceLoc) : string =
+ file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column
- fun printError (ParseError (loc, msgs)) : string =
+ fun printError ({loc, msgs} : parseError) : string =
let
val unexpect = List.mapPartial (fn Unexpected x => SOME x | _ => NONE) msgs
val showUnexpect = case unexpect of
@@ -45,18 +47,18 @@ struct
^ "expecting " ^ String.concatWith ", " expect
end
- fun stateStream (State (stream, _, _)) : TextIO.StreamIO.instream = stream
-
- fun stateLoc (State (_, loc, _)) : sourceLoc = loc
-
fun unpackParserResponse (_ : response, Result.Left err : (parseError, 'a * state * hints) Result.either) : (string, 'a) Result.either =
Result.Left (printError err)
| unpackParserResponse (_, Result.Right (a, st, _)) =
- if TextIO.StreamIO.endOfStream (stateStream st)
+ if TextIO.StreamIO.endOfStream (#stream st)
then Result.Right a
- else Result.Left (printSourceLoc (stateLoc st) ^ " Syntax error: trailing characters")
+ else Result.Left (printSourceLoc (#loc st) ^ " Syntax error: trailing characters")
- fun newLoc (fileName : string) : sourceLoc = SourceLoc (fileName, 1, 1)
+ fun newLoc (fileName : string) : sourceLoc = {
+ file = fileName,
+ row = 1,
+ column = 1
+ }
fun collectInfixOperators (opTable : (string list * string list) vector) : string list =
Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable
@@ -64,13 +66,16 @@ struct
fun infixOps (opTable : infixTable) : string list =
Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable
- fun newState (fileName : string) (fileStream : TextIO.instream) : state =
- State (TextIO.getInstream fileStream, newLoc fileName, UserState emptyInfixOperators)
+ fun newState (fileName : string) (fileStream : TextIO.instream) : state = {
+ stream = TextIO.getInstream fileStream,
+ loc = newLoc fileName,
+ userState = {infixTable = emptyInfixOperators}
+ }
fun updateUserState (f : userState -> userState) : userState parser =
- fn State (stream, loc, us) =>
- let val st' = f us
- in (Empty, Result.Right (st', State (stream, loc, st'), Hints []))
+ fn {stream, loc, userState} =>
+ let val st' = f userState
+ in (Empty, Result.Right (st', {stream = stream, loc = loc, userState = st'}, Hints []))
end
val getUserState : userState parser = updateUserState (fn x => x)
@@ -85,19 +90,25 @@ struct
fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b)
- fun withHints (Hints hints) (ParseError (loc, msgs)) : parseError = ParseError (loc, map Expected hints @ msgs)
+ fun withHints (Hints hints) ({loc, msgs} : parseError) : parseError = {
+ loc = loc,
+ msgs = map Expected hints @ msgs
+ }
- fun errToHints (ParseError (_, msgs)) = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs)
+ fun errToHints ({msgs, ...} : parseError) : hints = 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
- EQUAL => Int.compare (c1, c2)
+ fun compareLoc (l : sourceLoc, m : sourceLoc) : order =
+ case Int.compare (#row l, #row m) of
+ EQUAL => Int.compare (#column l, #column m)
| ord => ord
- fun mergeError (e1 as ParseError (loc1, msgs1)) (e2 as ParseError (loc2, msgs2)) : parseError =
+ fun mergeError (e1 : parseError) (e2 : parseError) : parseError =
(* pick the longest match *)
- case compareLoc (loc1, loc2) of
- EQUAL => ParseError (loc1, msgs1 @ msgs2)
+ case compareLoc (#loc e1, #loc e2) of
+ EQUAL => {
+ loc = #loc e1,
+ msgs = #msgs e1 @ #msgs e2
+ }
| GREATER => e1
| LESS => e2
@@ -118,7 +129,7 @@ struct
fn st =>
case p st of
(consumed, Result.Right (a, st', _)) => (consumed, Result.Right (a, st', Hints [msg]))
- | (consumed, Result.Left (ParseError (loc, _))) => (consumed, Result.Left (ParseError (loc, [Expected msg])))
+ | (consumed, Result.Left {loc, ...}) => (consumed, Result.Left {loc = loc, msgs = [Expected msg]})
fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser =
fn st =>
@@ -142,20 +153,32 @@ struct
(Consumed, Result.Left err) => (Empty, Result.Left err)
| res => res
- fun updatePosChar (SourceLoc (file, row, column)) (c : char) : sourceLoc =
+ fun updatePosChar ({file, row, column} : sourceLoc) (c : char) : sourceLoc =
case c of
- #"\n" => SourceLoc (file, row + 1, 1)
- | #"\t" => SourceLoc (file, row, column + 8 - (column - 1) mod 8)
- | _ => SourceLoc (file, row, column + 1)
+ #"\n" => {
+ file = file,
+ row = row + 1,
+ column = 1
+ }
+ | #"\t" => {
+ file = file,
+ row = row,
+ column = column + 8 - (column - 1) mod 8
+ }
+ | _ => {
+ file = file,
+ row = row,
+ column = column + 1
+ }
fun satisfy (pred : char -> bool) : char parser =
- fn State (stream, loc, us) =>
+ fn {stream, loc, userState} =>
case TextIO.StreamIO.input1 stream of
- NONE => (Empty, Result.Left (ParseError (loc, [Expected "UNKNOWN"])))
+ NONE => (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]})
| SOME (c, stream') =>
if pred c
- then (Consumed, Result.Right (c, State (stream', updatePosChar loc c, us), Hints []))
- else (Empty, Result.Left (ParseError (loc, [Expected "UNKNOWN"])))
+ then (Consumed, Result.Right (c, {stream = stream', loc = updatePosChar loc c, userState = userState}, Hints []))
+ else (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]})
fun parseChar (c : char) : char parser =
satisfy (fn c' => c = c') <?> str c
@@ -193,7 +216,7 @@ struct
val spaces : unit parser = () <$ many space <?> "white space"
fun unexpected (s : string) : 'a parser =
- fn st => (Empty, Result.Left (ParseError (stateLoc st, [Unexpected s])))
+ fn {loc, ...} => (Empty, Result.Left {loc = loc, msgs = [Unexpected s]})
val letter : char parser = satisfy Char.isAlpha <?> "letter"
@@ -244,8 +267,8 @@ struct
else const identName))
val identifier : string parser =
- bind getUserState (fn UserState st =>
- notReserved (infixOps st @ reservedWords))
+ bind getUserState (fn {infixTable, ...} =>
+ notReserved (infixOps infixTable @ reservedWords))
val tycon : string parser =
bind getUserState (fn st =>
@@ -285,8 +308,8 @@ struct
end
val infixIdentifier : string parser =
- bind getUserState (fn UserState infixOps =>
- let val ops = map reserved (Vector.foldl (fn ((l, r), acc) => l @ r @ acc) [] infixOps)
+ bind getUserState (fn {infixTable, ...} =>
+ let val ops = map reserved (Vector.foldl (fn ((l, r), acc) => l @ r @ acc) [] infixTable)
in
case ops of
[] => unexpected "infix op"
@@ -365,8 +388,8 @@ struct
<|> const ty) st
fun leftOp (i : int) : string parser =
- bind getUserState (fn UserState opTable =>
- let val (leftOps, _) = Vector.sub (opTable, i)
+ bind getUserState (fn {infixTable, ...} =>
+ let val (leftOps, _) = Vector.sub (infixTable, i)
in
case (map reserved leftOps) of
[] => unexpected "left-associative operator"
@@ -374,8 +397,8 @@ struct
end)
fun rightOp (i : int) : string parser =
- bind getUserState (fn UserState opTable =>
- let val (_, rightOps) = Vector.sub (opTable, i)
+ bind getUserState (fn {infixTable, ...} =>
+ let val (_, rightOps) = Vector.sub (infixTable, i)
in
case (map reserved rightOps) of
[] => unexpected "right-associative operator"
@@ -511,12 +534,12 @@ struct
bind (integer <|> const 0) (fn level =>
bind (many1 identifier) (fn ops =>
updateUserState
- (fn UserState table =>
- let val (leftOps, rightOps) = Vector.sub (table, level)
+ (fn {infixTable} =>
+ let val (leftOps, rightOps) = Vector.sub (infixTable, level)
in
if direction
- then UserState (Vector.update (table, level, (leftOps, ops @ rightOps)))
- else UserState (Vector.update (table, level, (ops @ leftOps, rightOps)))
+ then {infixTable = Vector.update (infixTable, level, (leftOps, ops @ rightOps))}
+ else {infixTable = Vector.update (infixTable, level, (ops @ leftOps, rightOps))}
end) >>
const NONE)))
<|> (reserved "datatype" >>
@@ -577,8 +600,73 @@ struct
const (SOME (Syntax.DStruct (strID, List.mapPartial (fn x => x) bindings))))))
<|> dec) st
+ (* There's ambiguity between pattern variables and constructors that can only
+ * be resolved by checking for constructors in scope *)
+ fun fixPatConstructors (constructors : unit StringMap.map) (Syntax.PVar v) : Syntax.pat =
+ if isSome (StringMap.lookup v constructors)
+ then Syntax.PCon ([v], Syntax.PTuple [])
+ else Syntax.PVar v
+ | fixPatConstructors constructors (Syntax.PTuple pats) = Syntax.PTuple (map (fixPatConstructors constructors) pats)
+ | fixPatConstructors constructors (Syntax.PCon (con, arg)) = Syntax.PCon (con, fixPatConstructors constructors arg)
+ | fixPatConstructors _ pat = pat
+
+ fun findConstructors (Syntax.DDatatype (_, cases)) : string list =
+ List.mapPartial
+ (fn (constructor, NONE) => SOME constructor
+ | _ => NONE)
+ cases
+ | findConstructors _ = []
+
+ fun fixDecConstructors (constructors : unit StringMap.map) (Syntax.DVal (pat, body)) : Syntax.dec =
+ Syntax.DVal (fixPatConstructors constructors pat, fixConstructors constructors body)
+ | fixDecConstructors constructors (Syntax.DValRec (pat, body)) =
+ Syntax.DValRec (fixPatConstructors constructors pat, fixConstructors constructors body)
+ | fixDecConstructors constructors (Syntax.DFun (f, arms)) =
+ Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms)
+ | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl
+ | fixDecConstructors constructors (Syntax.DStruct (name, decs)) =
+ let
+ val constructors = ref constructors
+ val decs : Syntax.dec list =
+ map
+ (fn dec =>
+ (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
+ fixDecConstructors (!constructors) dec))
+ decs
+ in Syntax.DStruct (name, decs)
+ end
+
+ and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr =
+ Syntax.ETuple (map (fixConstructors constructors) exprs)
+ | fixConstructors constructors (Syntax.EList exprs) =
+ Syntax.EList (map (fixConstructors constructors) exprs)
+ | fixConstructors constructors (Syntax.EApp (func, arg)) =
+ Syntax.EApp (fixConstructors constructors func, fixConstructors constructors arg)
+ | fixConstructors constructors (Syntax.ETyped (expr, ty)) =
+ Syntax.ETyped (fixConstructors constructors expr, ty)
+ | fixConstructors constructors (Syntax.EAndAlso (e1, e2)) =
+ Syntax.EAndAlso (fixConstructors constructors e1, fixConstructors constructors e2)
+ | fixConstructors constructors (Syntax.EOrElse (e1, e2)) =
+ Syntax.EOrElse (fixConstructors constructors e1, fixConstructors constructors e2)
+ | fixConstructors constructors (Syntax.ELet (decs, body)) =
+ let
+ val constructors = ref constructors
+ val decs =
+ map
+ (fn dec =>
+ (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
+ fixDecConstructors (!constructors) dec))
+ decs
+ in Syntax.ELet (decs, fixConstructors (!constructors) body)
+ end
+ | fixConstructors constructors (Syntax.ELambda (pat, body)) =
+ Syntax.ELambda (fixPatConstructors constructors pat, fixConstructors constructors body)
+ | fixConstructors constructors (Syntax.ECase (expr, arms)) =
+ Syntax.ECase (fixConstructors constructors expr, map (fn (pat, expr) => (fixPatConstructors constructors pat, fixConstructors constructors expr)) arms)
+ | fixConstructors _ expr = expr
+
val program : Syntax.expr parser =
bind (many strdec) (fn decs =>
- const (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0)))
+ const (fixConstructors StringMap.empty (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0))))
fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
end
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 04:37:38 +0000