diff options
| -rw-r--r-- | Parser.sml | 24 | ||||
| -rw-r--r-- | ShowSyntax.sml | 4 | ||||
| -rw-r--r-- | Syntax.sml | 3 | ||||
| -rw-r--r-- | Types.sml | 3 | ||||
| -rw-r--r-- | generate-show-syntax.sml | 2 | ||||
| -rw-r--r-- | tests/23-signature.sml | 10 |
6 files changed, 40 insertions, 6 deletions
@@ -619,9 +619,28 @@ struct val rec strdec : Syntax.dec option parser = fn st => ((reserved "structure" >> bind identifier (fn strID => + bind + (((reserved ":" <|> reserved ":>") >> + SOME <$> identifier) + <|> const NONE) + (fn s => reserved "=" >> bind structExpr (fn str => - const (SOME (Syntax.DStruct (strID, 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 => ((reserved "struct" >> @@ -655,7 +674,8 @@ 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, str)) = Syntax.DStruct (name, fixStructExprConstructors constructors str) + | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixStructExprConstructors 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 diff --git a/ShowSyntax.sml b/ShowSyntax.sml index f28895d..53cc2af 100644 --- a/ShowSyntax.sml +++ b/ShowSyntax.sml @@ -87,7 +87,9 @@ and decToStringI (indent : string) (Syntax.DVal x : Syntax.dec) : string = | decToStringI (indent : string) (Syntax.DType x : Syntax.dec) : string = "DType " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ etypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x | decToStringI (indent : string) (Syntax.DStruct x : Syntax.dec) : string = - "DStruct " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ structExprToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + "DStruct " ^ (fn indent => fn (x0, x1, x2) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ optionToString (stringToStringI) indent' x1 ^ ",\n" ^ indent' ^ structExprToStringI indent' x2 ^ "\n" ^ indent ^ ")" end) indent x + | decToStringI (indent : string) (Syntax.DSig x : Syntax.dec) : string = + "DSig " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ etypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x and decToString (x : Syntax.dec) : string = decToStringI "" x and structExprToStringI (indent : string) (Syntax.SIdent x : Syntax.structExpr) : string = @@ -36,7 +36,8 @@ struct | DFun of string * (pat list * expr) list | DDatatype of string list * string * (string * etype option) list | DType of string * etype - | DStruct of string * structExpr + | DStruct of string * string option * structExpr + | DSig of string * (string * etype) list and structExpr = SIdent of string @@ -368,9 +368,10 @@ structure Types = struct let val env = bindType (vars, name, data) env in (env, SOME (Syntax.TDDatatype (name, map (fn (name, ty) => (name, Option.map (tyToSyntaxTy o (etypeToTy env)) ty)) data))) end | tagDec _ (Syntax.DType _) = raise Fail "TODO" - | tagDec env (Syntax.DStruct (name, str)) = + | tagDec env (Syntax.DStruct (name, _, str)) = let val (str, strType) = tagStructExpr env str in (bindStruct name strType env, SOME (Syntax.TDStruct (name, (str, structTypeToSyntaxStructType strType)))) end + | tagDec env (Syntax.DSig (s, decls)) = (env, NONE) | tagDec _ _ = raise Fail "invalid expr" and tagDecs env [] = (env, []) diff --git a/generate-show-syntax.sml b/generate-show-syntax.sml index c1e104f..708d1b7 100644 --- a/generate-show-syntax.sml +++ b/generate-show-syntax.sml @@ -45,7 +45,7 @@ val ast = | Result.Right x => x val (structName, decls) = case ast of - Syntax.ELet (Syntax.DStruct (structName, Syntax.SStruct decls) :: _, _) => (structName, decls) + Syntax.ELet (Syntax.DStruct (structName, _, Syntax.SStruct decls) :: _, _) => (structName, decls) | _ => raise Fail "ast has unexpected format (I can't print it sorry)" val out = TextIO.openOut (!(#o opts)) val _ = TextIO.output (out, "(*\n This file was generated by generate-show-syntax.sml. Do not edit manually.\n To regenerate, use\n\n sml generate-show-syntax.sml -o " ^ !(#o opts) ^ " " ^ filename ^ "\n*)\n\n") diff --git a/tests/23-signature.sml b/tests/23-signature.sml new file mode 100644 index 0000000..01a8494 --- /dev/null +++ b/tests/23-signature.sml @@ -0,0 +1,10 @@ +signature SIG = sig + val x : int +end + +structure Struct :> SIG = struct + val privateField = 41 + val x = 42 +end + +val _ = __builtin "exit" Struct.x |