diff options
Diffstat (limited to 'Parser.sml')
| -rw-r--r-- | Parser.sml | 115 |
1 files changed, 70 insertions, 45 deletions
@@ -123,6 +123,8 @@ struct | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err))) | (consumed, Result.Left err) => (consumed, Result.Left err) + fun thunk (f : unit -> 'a parser) : 'a parser = fn st => f () st + fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2) fun (p : 'a parser) <?> (msg : string) : 'a parser = @@ -451,25 +453,22 @@ struct typedPat (List.tabulate (10, fn i => 9 - i)) st - fun makeConvolutedEDotSyntax ([i] : string list) : Syntax.expr = Syntax.EIdent i - | makeConvolutedEDotSyntax (i :: is) = + fun makeConvolutedEDotSyntax (ty : Syntax.identType) ([i] : string list) : Syntax.expr = + Syntax.EIdent (ty, i) + | makeConvolutedEDotSyntax (ty : Syntax.identType) (i :: is : string list) : Syntax.expr = let - val structSelectors = List.take (is, length is - 1) - val exprSelector = List.last is - in - Syntax.EDot - ( foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent i) structSelectors - , exprSelector - ) - end - | makeConvolutedEDotSyntax _ = raise Fail "bad identifier" + fun go acc [i] = Syntax.EDot (acc, (ty, i)) + | go acc (i :: is) = go (Syntax.EDot (acc, (Syntax.ITStruct, i))) is + | go _ _ = raise Fail "unreachable" + in go (Syntax.EIdent (Syntax.ITStruct, i)) is end + | makeConvolutedEDotSyntax _ _ = raise Fail "bad identifier" val rec atom : Syntax.expr parser = fn st => (Syntax.EInt <$> integer <|> Syntax.EStr <$> stringConstant - <|> makeConvolutedEDotSyntax <$> longIdentifier - <|> (reserved "op" >> makeConvolutedEDotSyntax <$> longInfixIdentifier) + <|> makeConvolutedEDotSyntax Syntax.ITVar <$> longIdentifier + <|> (reserved "op" >> makeConvolutedEDotSyntax Syntax.ITVar <$> longInfixIdentifier) <|> builtin <|> (reserved "let" >> bind (many dec) (fn decs => @@ -496,14 +495,14 @@ struct fun exprLeft expr1 = bind (leftOp i) (fn opEx => bind exprLower (fn expr2 => - let val app = Syntax.EApp (Syntax.EIdent opEx, Syntax.ETuple [expr1, expr2]) + let val app = Syntax.EApp (Syntax.EIdent (Syntax.ITVar, 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]))))) + const (Syntax.EApp (Syntax.EIdent (Syntax.ITVar, opEx), Syntax.ETuple [expr1, rest]))))) in bind exprLower (fn expr1 => exprLeft expr1 <|> exprRight expr1 <|> const expr1) @@ -605,6 +604,7 @@ struct bind (many1 atpat) (fn args => const (name, args)) | _ => unexpected "pattern"))) (fn (name, args) => + ((reserved ":" >> () <$ parseType) <|> const ()) >> reserved "=" >> bind expr (fn body => const (name, args, body)))) @@ -627,27 +627,19 @@ struct reserved "=" >> bind structExpr (fn str => const (SOME (Syntax.DStruct (strID, s, str))))))) - <|> (reserved "signature" >> - bind identifier (fn sigID => - reserved "=" >> - reserved "sig" >> - bind - (many - (reserved "val" >> - bind identifier (fn id => - reserved ":" >> - bind parseType (fn ty => - const (id, ty))))) - (fn bindings => - reserved "end" >> - const (SOME (Syntax.DSig (sigID, bindings)))))) <|> dec) st - and structExpr : Syntax.structExpr parser = fn st => + and structExpr : Syntax.expr parser = fn st => ((reserved "struct" >> bind (many strdec) (fn bindings => reserved "end" >> - const (Syntax.SStruct (List.mapPartial (fn x => x) bindings)))) - <|> (fn is => foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent (hd is)) (tl is)) <$> longIdentifier) st + const (Syntax.EStruct (List.mapPartial (fn x => x) bindings)))) + <|> bind longIdentifier (fn is => + (symbol "(" >> + thunk (fn () => if length is <> 1 then raise Fail "bad functor has a dot" else + bind structExpr (fn arg => + symbol ")" >> + const (Syntax.EFunctorApp (Syntax.EIdent (Syntax.ITFunctor, hd is), arg))))) + <|> const (makeConvolutedEDotSyntax Syntax.ITStruct is))) st (* There's ambiguity between pattern variables and constructors that can only * be resolved by checking for constructors in scope *) @@ -674,19 +666,9 @@ struct Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms) | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl | fixDecConstructors _ (decl as Syntax.DType _) = decl - | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixStructExprConstructors constructors str) + | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixConstructors constructors str) | fixDecConstructors constructors (s as Syntax.DSig _) = s - - and fixStructExprConstructors (constructors : unit StringMap.map) (Syntax.SStruct decls) : Syntax.structExpr = - let val constructors = ref constructors in - Syntax.SStruct - (map - (fn dec => - (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; - fixDecConstructors (!constructors) dec)) - decls) - end - | fixStructExprConstructors _ expr = expr + | fixDecConstructors constructors (Syntax.DFunctor (name, arg, ty, body)) = Syntax.DFunctor (name, arg, ty, fixConstructors constructors body) and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr = Syntax.ETuple (map (fixConstructors constructors) exprs) @@ -715,11 +697,54 @@ struct 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 constructors (Syntax.EStruct decls) = + let val constructors = ref constructors in + Syntax.EStruct + (map + (fn dec => + (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; + fixDecConstructors (!constructors) dec)) + decls) + end | fixConstructors _ expr = expr + val spec : (string * Syntax.etype) parser = + reserved "val" >> + bind identifier (fn id => + reserved ":" >> + bind parseType (fn ty => + const (id, ty))) + + val sigexp : (string * Syntax.etype) list parser = + between (reserved "sig") (reserved "end") (many spec) + + val sigdec : Syntax.dec parser = + reserved "signature" >> + bind identifier (fn sigID => + reserved "=" >> + bind sigexp (fn vals => + const (Syntax.DSig (sigID, vals)))) + + val fundec : Syntax.dec parser = + reserved "functor" >> + bind identifier (fn funID => + symbol "(" >> + bind identifier (fn arg => + reserved ":" >> + bind identifier (fn sigID => + symbol ")" >> + reserved "=" >> + reserved "struct" >> + bind (many strdec) (fn bindings => + reserved "end" >> + const (Syntax.DFunctor (funID, arg, sigID, Syntax.EStruct (List.mapPartial (fn x => x) bindings))))))) + + val topdec : Syntax.dec option parser = + strdec <|> SOME <$> sigdec <|> SOME <$> fundec + val program : Syntax.expr parser = whiteSpace >> - bind (many strdec) (fn decs => + bind (many topdec) (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 |