diff options
Diffstat (limited to 'parser.sml')
| -rw-r--r-- | parser.sml | 672 |
1 files changed, 0 insertions, 672 deletions
diff --git a/parser.sml b/parser.sml deleted file mode 100644 index e464332..0000000 --- a/parser.sml +++ /dev/null @@ -1,672 +0,0 @@ -infix 4 <$> <$ -infix 1 >> -infixr 1 <|> -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 - 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 - type parseError = {loc : sourceLoc, msgs : message list} - datatype hints = Hints of string list - type 'a parser = state -> response * (parseError, 'a * state * hints) Result.either - - val reservedWords = - [ "abstype", "and", "andalso", "as", "case", "datatype", "do", "else" - , "end", "exception", "fn", "fun", "handle", "if", "in", "infix" - , "infixr", "let", "local", "nonfix", "of", "op", "open", "orelse" - , "raise", "rec", "then", "type", "val", "with", "withtype", "while" - , "(", ")", "[", "]", "{", "}", ",", ":", ";", "...", "_", "|", "=", "=>", "->", "#" - , "eqtype", "functor", "include", "sharing", "sig" - , "signature", "struct", "structure", "where", ":>" - ] - - val emptyInfixOperators : infixTable = - Vector.tabulate (10, fn _ => ([], [])) - - fun printSourceLoc ({file, row, column} : sourceLoc) : string = - file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column - - fun printError ({loc, msgs} : parseError) : string = - let - 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 - in - printSourceLoc loc ^ " Syntax error:\n" - ^ showUnexpect - ^ "expecting " ^ String.concatWith ", " expect - end - - 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 (#stream st) - then Result.Right a - else Result.Left (printSourceLoc (#loc st) ^ " Syntax error: trailing characters") - - 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 - - fun infixOps (opTable : infixTable) : string list = - Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable - - 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 {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) - - fun runParser (p : 'a parser) (fileName : string) : (string, 'a) Result.either = - unpackParserResponse (p (newState fileName (TextIO.openIn fileName))) - - fun testParser (p : 'a parser) (s : string) : 'a = - case unpackParserResponse (p (newState "STRING" (TextIO.openString s))) of - Result.Right x => x - | Result.Left e => raise Fail ("Parse failed: " ^ e) - - fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b) - - fun withHints (Hints hints) ({loc, msgs} : parseError) : parseError = { - loc = loc, - msgs = map Expected hints @ msgs - } - - fun errToHints ({msgs, ...} : parseError) : hints = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs) - - 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 : parseError) (e2 : parseError) : parseError = - (* pick the longest match *) - case compareLoc (#loc e1, #loc e2) of - EQUAL => { - loc = #loc e1, - msgs = #msgs e1 @ #msgs e2 - } - | GREATER => e1 - | LESS => e2 - - fun bind (p : 'a parser) (f : 'a -> 'b parser) : 'b parser = - fn st => - case p st of - (consumed1, Result.Right (a, st', hints)) => - (case (f a) st' of - (Consumed, Result.Right success) => (Consumed, Result.Right success) - | (Empty, Result.Right (b, st'', hints')) => (consumed1, Result.Right (b, st'', mergeHints hints hints')) - | (Consumed, Result.Left err) => (Consumed, Result.Left (withHints hints err)) - | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err))) - | (consumed, Result.Left err) => (consumed, Result.Left err) - - fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2) - - fun (p : 'a parser) <?> (msg : string) : 'a parser = - fn st => - case p st of - (consumed, Result.Right (a, st', _)) => (consumed, Result.Right (a, st', Hints [msg])) - | (consumed, Result.Left {loc, ...}) => (consumed, Result.Left {loc = loc, msgs = [Expected msg]}) - - fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser = - fn st => - case p1 st of - (Empty, Result.Left err) => - (case p2 st of - (Empty, Result.Right (a, st', hints)) => (Empty, Result.Right (a, st', mergeHints (errToHints err) hints)) - | (Empty, Result.Left err') => (Empty, Result.Left (mergeError err err')) - | res => res) - | res => res - - fun const (x : 'a) (st : state) = (Empty, Result.Right (x, st, Hints [])) - - fun (f : 'a -> 'b) <$> (p : 'a parser) : 'b parser = bind p (const o f) - - fun (x : 'a) <$ (p : 'b parser) : 'a parser = (fn _ => x) <$> p - - fun try (p : 'a parser) : 'a parser = - fn st => - case p st of - (Consumed, Result.Left err) => (Empty, Result.Left err) - | res => res - - fun updatePosChar ({file, row, column} : sourceLoc) (c : char) : sourceLoc = - case c of - #"\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 {stream, loc, userState} => - case TextIO.StreamIO.input1 stream of - NONE => (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]}) - | SOME (c, stream') => - if pred c - 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 - - fun parseString (s : string) : string parser = - case explode s of - [] => const "" - | c1 :: cs => s <$ foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs <?> "'" ^ String.toString s ^ "'" - - fun manyErr () = raise Fail "many is applied to a parser that accepts an empty string" - - fun many (p : 'a parser) : 'a list parser = - fn st => - let fun walk xs s' = - case p s' of - (Consumed, Result.Right (x, s'', _)) => walk (x :: xs) s'' - | (Consumed, Result.Left err) => (Consumed, Result.Left err) - | (Empty, Result.Right _) => manyErr () - | (Empty, Result.Left err) => (Consumed, Result.Right (rev xs, s', errToHints err)) - in - case p st of - (Consumed, Result.Right (x, s', _)) => walk [x] s' - | (Consumed, Result.Left err) => (Consumed, Result.Left err) - | (Empty, Result.Right _) => manyErr () - | (Empty, Result.Left err) => (Empty, Result.Right ([], st, errToHints err)) - end - - fun many1 (p : 'a parser) : 'a list parser = - bind p (fn x => - bind (many p) (fn xs => - const (x :: xs))) - - val space : char parser = satisfy Char.isSpace <?> "space" - - val spaces : unit parser = () <$ many space <?> "white space" - - fun unexpected (s : string) : 'a parser = - fn {loc, ...} => (Empty, Result.Left {loc = loc, msgs = [Unexpected s]}) - - val letter : char parser = satisfy Char.isAlpha <?> "letter" - - val alphaNum : char parser = satisfy Char.isAlphaNum <?> "letter or digit" - - fun oneOf ([] : char list) : char parser = raise Fail "oneOf empty" - | oneOf (x :: xs) = foldl (fn (c, p) => p <|> parseChar c) (parseChar x) xs - - (* some day, whiteSpace will support comments *) - val whiteSpace = spaces - - fun lexeme (p : 'a parser) : 'a parser = - bind p (fn x => - whiteSpace >> - const x) - - val alphaNumIdentifierLetter : char parser = - alphaNum <|> oneOf [#"'", #"_"] - - val symbolicIdentifierLetters : char list = - [ #"!", #"%", #"&", #"$", #"#", #"+", #"-", #"/", #":", #"<" - , #"=", #">", #"?", #"@", #"\\", #"~", #"`", #"^", #"|", #"*" - ] - - val symbolicIdentifierLetter : char parser = oneOf symbolicIdentifierLetters - - val alphaNumIdentifier : string parser = - lexeme - (bind letter (fn firstLetter => - bind (many alphaNumIdentifierLetter) (fn rest => - const (implode (firstLetter :: rest))))) - - val tyvar : string parser = - lexeme - (bind (parseChar #"'") (fn firstLetter => - bind (many alphaNumIdentifierLetter) (fn rest => - const (implode (firstLetter :: rest))))) - - val symbolicIdentifier : string parser = - lexeme - (implode <$> many1 symbolicIdentifierLetter) - - fun notReserved (reserved : string list) : string parser = - try - (bind (alphaNumIdentifier <|> symbolicIdentifier <?> "identifier") (fn identName => - if List.exists (fn n => n = identName) reserved - then unexpected identName - else const identName)) - - val identifier : string parser = - bind getUserState (fn {infixTable, ...} => - notReserved (infixOps infixTable @ reservedWords)) - - val tycon : string parser = - bind getUserState (fn st => - notReserved ("*" :: reservedWords)) - - fun sepBy1 (p : 'a parser) (sep : 'b parser) : 'a list parser = - bind p (fn x => - bind (many (sep >> p)) (fn xs => - const (x :: xs))) - - fun sepBy (p : 'a parser) (sep : 'b parser) : 'a list parser = - sepBy1 p sep <|> const [] - - fun symbol (s : string) : string parser = lexeme (parseString s) - - val longIdentifier : string list parser = sepBy1 identifier (symbol ".") - - fun notFollowedBy (p : char parser) : unit parser = - bind (try p) (fn c => unexpected (str c)) - <|> const () - - fun reserved (s : string) : string parser = - let - val start = - if s = "" - then raise Fail "reserved was called on an empty string" - else String.sub (s, 0) - val isSymbolic = - List.exists (fn c => c = start) symbolicIdentifierLetters - in - lexeme - (try - (parseString s >> - notFollowedBy (if isSymbolic then symbolicIdentifierLetter else alphaNumIdentifierLetter) >> - const s)) - <?> s - end - - val infixIdentifier : string parser = - 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" - | x :: xs => foldl op <|> x xs <?> "infix op" - end) - - val longInfixIdentifier : string list parser = - bind (many (bind identifier (fn id => symbol "." >> const id))) (fn idents => - bind infixIdentifier (fn ii => - const (idents @ [ii]))) - - val digit : char parser = satisfy Char.isDigit <?> "digit" - - val integer : int parser = - lexeme - (bind (many1 digit) (fn digits => - const (valOf (Int.fromString (implode digits))))) - - val stringInternalChar : char parser = - (parseString "\\" >> (#"\a" <$ parseChar #"a" - <|> #"\b" <$ parseChar #"b" - <|> #"\t" <$ parseChar #"t" - <|> #"\n" <$ parseChar #"n" - <|> #"\v" <$ parseChar #"v" - <|> #"\f" <$ parseChar #"f" - <|> #"\r" <$ parseChar #"r" - <|> parseChar #"\"" - <|> parseChar #"\\") <?> "string escape") - <|> (satisfy (fn c => c <> #"\"" andalso c <> #"\\") <?> "string character") - - val stringConstant : string parser = - lexeme - (parseString "\"" >> - bind (implode <$> many stringInternalChar) (fn stringContent => - parseString "\"" >> - const stringContent)) - - val builtin : Syntax.expr parser = - reserved "__builtin" >> - Syntax.EBuiltin <$> stringConstant - - fun between (left : 'a parser) (right : 'b parser) (p : 'c parser) : 'c parser = - left >> - bind p (fn x => - right >> - const x) - - fun parseTycons (ty : Syntax.etype) : Syntax.etype parser = - bind tycon (fn longtycon => - parseTycons (Syntax.Tycon ([ty], longtycon))) - <|> const ty - - val rec parseSingleType : Syntax.etype parser = fn st => - (Syntax.Tyvar <$> (tyvar <|> tycon) - <|> bind (between (symbol "(") (symbol ")") (sepBy1 parseType (symbol ","))) (fn types => - case types of - [x] => const x - | _ => bind tycon (fn longtycon => - const (Syntax.Tycon (types, longtycon))))) st - and parseTycon : Syntax.etype parser = - fn st => - bind parseSingleType parseTycons st - and parseTupleType : Syntax.etype parser = - fn st => - bind (sepBy1 parseTycon (reserved "*")) (fn types => - const - (case types of - [ty] => ty - | _ => Syntax.TyTuple types)) st - and parseType : Syntax.etype parser = - fn st => - bind parseTupleType (fn ty => - (reserved "->" >> - bind parseType (fn ty' => - const (Syntax.Tyfun (ty, ty')))) - <|> const ty) st - - fun leftOp (i : int) : string parser = - bind getUserState (fn {infixTable, ...} => - let val (leftOps, _) = Vector.sub (infixTable, i) - in - case (map reserved leftOps) of - [] => unexpected "left-associative operator" - | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops - end) - - fun rightOp (i : int) : string parser = - bind getUserState (fn {infixTable, ...} => - let val (_, rightOps) = Vector.sub (infixTable, i) - in - case (map reserved rightOps) of - [] => unexpected "right-associative operator" - | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops - end) - - val rec atpat : Syntax.pat parser = fn st => - (Syntax.PWild <$ reserved "_" - <|> Syntax.PInt <$> integer - <|> bind (between (symbol "(") (symbol ")") (sepBy pat (symbol ","))) (fn pats => - const - (case pats of - [p] => p - | _ => Syntax.PTuple pats)) - <|> bind longIdentifier (fn [i] => const (Syntax.PVar i) | is => const (Syntax.PCon (is, Syntax.PTuple [])))) st - and appPat : Syntax.pat parser = fn st => - (bind longIdentifier (fn ident => - bind atpat (fn arg => - const (Syntax.PCon (ident, arg))) - <|> const (case ident of - [i] => Syntax.PVar i - | _ => Syntax.PCon (ident, Syntax.PTuple []))) - <|> atpat) st - and pat : Syntax.pat parser = fn st => - foldl - (fn (i, patLower) => - let - fun patLeft pat1 = - bind (leftOp i) (fn opEx => - bind patLower (fn pat2 => - let val app = Syntax.PCon ([opEx], Syntax.PTuple [pat1, pat2]) - in patLeft app <|> const app - end)) - fun patRight pat1 = - bind (rightOp i) (fn opEx => - bind patLower (fn pat2 => - bind (patRight pat2 <|> const pat2) (fn rest => - const (Syntax.PCon ([opEx], Syntax.PTuple [pat1, rest]))))) - in - bind patLower (fn pat1 => - patLeft pat1 <|> patRight pat1 <|> const pat1) - end) - appPat - (List.tabulate (10, fn i => 9 - i)) st - - val rec atom : Syntax.expr parser = - fn st => - (Syntax.EInt <$> integer - <|> Syntax.EStr <$> stringConstant - <|> Syntax.EIdent <$> longIdentifier - <|> (reserved "op" >> Syntax.EIdent <$> longInfixIdentifier) - <|> builtin - <|> (reserved "let" >> - bind (many dec) (fn decs => - reserved "in" >> - bind expr (fn e => - reserved "end" >> - const (Syntax.ELet (List.mapPartial (fn x => x) decs, e))))) - <|> (symbol "(" >> - bind (sepBy expr (symbol ",")) (fn exprs => - symbol ")" >> - const - (case exprs of - [x] => x - | _ => Syntax.ETuple exprs)))) st - and appExp : Syntax.expr parser = - fn st => - bind atom (fn e0 => - foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st - and infixExp : Syntax.expr parser = - fn st => - foldl - (fn (i, exprLower) => - let - fun exprLeft expr1 = - bind (leftOp i) (fn opEx => - bind exprLower (fn expr2 => - let val app = Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, expr2]) - in exprLeft app <|> const app - end)) - fun exprRight expr1 = - bind (rightOp i) (fn opEx => - bind exprLower (fn expr2 => - bind (exprRight expr2 <|> const expr2) (fn rest => - const (Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest]))))) - in - bind exprLower (fn expr1 => - exprLeft expr1 <|> exprRight expr1 <|> const expr1) - end) - appExp - (List.tabulate (10, fn i => 9 - i)) st - and typedExp : Syntax.expr parser = - fn st => - bind infixExp (fn e => - (reserved ":" >> - bind parseType (fn ty => - const (Syntax.ETyped (e, ty)))) - <|> const e) st - and andalsoExp : Syntax.expr parser = - fn st => - bind typedExp (fn e1 => - (reserved "andalso" >> - bind andalsoExp (fn e2 => - const (Syntax.EAndAlso (e1, e2)))) - <|> const e1) st - and orelseExpr : Syntax.expr parser = - fn st => - bind andalsoExp (fn e1 => - (reserved "orelse" >> - bind orelseExpr (fn e2 => - const (Syntax.EOrElse (e1, e2)))) - <|> const e1) st - and expr : Syntax.expr parser = fn st => - ((reserved "fn" >> - bind pat (fn p => - reserved "=>" >> - bind expr (fn e => - const (Syntax.ELambda (p, e))))) - <|> (reserved "case" >> - bind expr (fn e => - reserved "of" >> - bind - (sepBy1 - (bind pat (fn p => - reserved "=>" >> - bind expr (fn e => - const (p, e)))) - (reserved "|")) (fn arms => - const (Syntax.ECase (e, arms))))) - <|> orelseExpr) st - and dec : Syntax.dec option parser = fn st => - (bind (false <$ reserved "infix" <|> true <$ reserved "infixr") (fn direction => - bind (integer <|> const 0) (fn level => - bind (many1 identifier) (fn ops => - updateUserState - (fn {infixTable} => - let val (leftOps, rightOps) = Vector.sub (infixTable, level) - in - if direction - then {infixTable = Vector.update (infixTable, level, (leftOps, ops @ rightOps))} - else {infixTable = Vector.update (infixTable, level, (ops @ leftOps, rightOps))} - end) >> - const NONE))) - <|> (reserved "datatype" >> - (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ",")) - <|> (fn x => [x]) <$> tyvar - <|> const []) >> - bind identifier (fn name => - reserved "=" >> - bind - (sepBy1 - (bind (infixIdentifier <|> identifier) (fn con => - (reserved "of" >> - bind parseType (fn ty => - const (con, SOME ty))) - <|> const (con, NONE))) - (reserved "|")) (fn cons => - const (SOME (Syntax.DDatatype (name, cons)))))) - <|> (reserved "val" >> - bind (true <$ reserved "rec" <|> const false) (fn isRec => - bind pat (fn p => - reserved "=" >> - bind expr (fn e => - const - (SOME - (if isRec - then Syntax.DValRec (p, e) - else Syntax.DVal (p, e))))))) - <|> (reserved "fun" >> - bind - (sepBy1 - (bind (bind atpat (fn pat1 => - bind infixIdentifier (fn infixOp => - bind atpat (fn pat2 => - const (infixOp, [Syntax.PTuple [pat1, pat2]]))) - <|> (case pat1 of - Syntax.PVar name => - bind (many1 atpat) (fn args => - const (name, args)) - | _ => unexpected "pattern"))) (fn (name, args) => - reserved "=" >> - bind expr (fn body => - const (name, args, body)))) - (reserved "|")) (fn cases => - let val (name, _, _) = hd cases - in - if not (List.all (fn (n, _, _) => n = name) cases) - then raise Fail "clauses do not all have same function name" - else const (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases))) - end))) st - - val rec strdec : Syntax.dec option parser = fn st => - ((reserved "structure" >> - bind identifier (fn strID => - reserved "=" >> - reserved "struct" >> - bind (many strdec) (fn bindings => - reserved "end" >> - 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 (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 |