Merge pull request #184 from MatthewFluet/applicative-universal

Implement `structure Universal` with an applicative exception declaration

Author: shwestrick

basis-library/schedulers/par-pcall/Universal.sml

@@ -8,12 +8,12 @@ struct
 
   fun 'a embed () =
     let
-      exception E of 'a
+      exception UnivTag of 'a
       fun project (e: t): 'a option =
         case e of
-          E a => SOME a
+          UnivTag a => SOME a
         | _ => NONE
     in
-      (E, project)
+      (UnivTag, project)
     end
 end

basis-library/schedulers/par-pcall/sources.mlb

@@ -26,7 +26,11 @@ local
   ../shh/queue/DequeABP.sml
   (*Stack.sml*)
   ../shh/Result.sml
-  Universal.sml
+  ann
+     "exnDecElab app"
+  in
+     Universal.sml
+  end
   ann
     "allowFFI true"
     "allowPrim true"

mlton/atoms/atoms.fun

@@ -80,6 +80,8 @@ structure Atoms =
                              structure RealSize = RealSize
                              structure WordSize = WordSize)
 
+      structure ExnDecElab = ExnDecElab ()
+
       structure Prod = Prod ()
       structure Handler = Handler (structure Label = Label)
       structure Return = Return (structure Label = Label

mlton/atoms/atoms.sig

@@ -24,6 +24,7 @@ signature ATOMS' =
       structure CharSize: CHAR_SIZE
       structure Con: CON
       structure Const: CONST
+      structure ExnDecElab: EXN_DEC_ELAB
       structure Ffi: FFI
       structure Field: FIELD
       structure Func: FUNC
@@ -95,6 +96,7 @@ signature ATOMS =
       sharing Cases = Atoms.Cases
       sharing Con = Atoms.Con
       sharing Const = Atoms.Const
+      sharing ExnDecElab = Atoms.ExnDecElab
       sharing Ffi = Atoms.Ffi
       sharing Field = Atoms.Field
       sharing Func = Atoms.Func

mlton/atoms/exn-dec-elab.fun

@@ -0,0 +1,26 @@
+(* Copyright (C) 2024 Matthew Fluet.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor ExnDecElab (S: EXN_DEC_ELAB_STRUCTS): EXN_DEC_ELAB =
+struct
+
+open S
+
+open Control.Elaborate.ExnDecElab
+
+val all = [App, Gen]
+
+val layout = Layout.str o toString
+
+val parse =
+   let
+      open Parse
+      infix 3 *>
+   in
+      any (List.map (all, fn ede => kw (toString ede) *> pure ede))
+   end
+
+end

mlton/atoms/exn-dec-elab.sig

@@ -0,0 +1,19 @@
+(* Copyright (C) 2024 Matthew Fluet.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature EXN_DEC_ELAB_STRUCTS =
+   sig
+   end
+
+signature EXN_DEC_ELAB =
+   sig
+      include EXN_DEC_ELAB_STRUCTS
+
+      datatype t = App | Gen
+
+      val layout: t -> Layout.t
+      val parse: t Parse.t
+   end

mlton/atoms/sources.cm

@@ -15,6 +15,7 @@ signature CHAR_SIZE
 signature CONST
 signature C_FUNCTION
 signature C_TYPE
+signature EXN_DEC_ELAB
 signature HASH_TYPE
 signature ID
 signature INT_SIZE
@@ -108,6 +109,8 @@ cases.sig
 cases.fun
 prim.sig
 prim.fun
+exn-dec-elab.sig
+exn-dec-elab.fun
 prod.sig
 prod.fun
 handler.sig

mlton/atoms/sources.mlb

@@ -70,6 +70,8 @@ local
    cases.fun
    prim.sig
    prim.fun
+   exn-dec-elab.sig
+   exn-dec-elab.fun
    prod.sig
    prod.fun
    handler.sig
@@ -97,6 +99,7 @@ in
    signature CONST
    signature C_FUNCTION
    signature C_TYPE
+   signature EXN_DEC_ELAB
    signature HASH_TYPE
    signature ID
    signature INT_SIZE

mlton/control/control-flags.sig

@@ -134,6 +134,12 @@ signature CONTROL_FLAGS =
                      Default
                    | Ignore
                end
+            structure ExnDecElab :
+               sig
+                  datatype t = App | Gen
+                  val toString: t -> string
+               end
+
             structure ResolveScope :
                sig
                   datatype t =
@@ -154,6 +160,7 @@ signature CONTROL_FLAGS =
             val allowRedefineSpecialIds: (bool,bool) t
             val allowSpecifySpecialIds: (bool,bool) t
             val deadCode: (bool,bool) t
+            val exnDecElab: (ExnDecElab.t,ExnDecElab.t) t
             val forceUsed: (unit,bool) t
             val ffiStr: (string,string option) t
             val nonexhaustiveBind: (DiagEIW.t,DiagEIW.t) t

mlton/control/control-flags.sml

@@ -356,6 +356,20 @@ structure Elaborate =
                 | Ignore => "ignore"
          end
 
+      structure ExnDecElab =
+         struct
+            datatype t = App | Gen
+
+            val fromString: string -> t option =
+               fn "app" => SOME App
+                | "gen" => SOME Gen
+                | _ => NONE
+
+            val toString: t -> string =
+               fn App => "app"
+                | Gen => "gen"
+         end
+
       structure ResolveScope =
          struct
             datatype t =
@@ -658,6 +672,19 @@ structure Elaborate =
          val (deadCode, ac) =
             makeBool ({name = "deadCode",
                        default = false, expert = true}, ac)
+         val (exnDecElab, ac) =
+            make ({choices = SOME [ExnDecElab.App, ExnDecElab.Gen],
+                   default = ExnDecElab.Gen,
+                   expert = true,
+                   toString = ExnDecElab.toString,
+                   name = "exnDecElab",
+                   newCur = fn (_,ede) => ede,
+                   newDef = fn (_,ede) => ede,
+                   parseArgs = fn args' =>
+                               case args' of
+                                  [arg'] => ExnDecElab.fromString arg'
+                                | _ => NONE},
+                  ac)
          val (forceUsed, ac) =
             make ({choices = NONE,
                    default = false,

mlton/core-ml/core-ml.fun

@@ -166,7 +166,8 @@ datatype dec =
                 tycon: Tycon.t,
                 tyvars: Tyvar.t vector} vector
  | Exception of {arg: Type.t option,
-                 con: Con.t}
+                 con: Con.t,
+                 elab: ExnDecElab.t}
  | Fun of {decs: {lambda: lambda,
                   var: Var.t} vector,
            tyvars: unit -> Tyvar.t vector}
@@ -248,8 +249,11 @@ in
                         align
                         (separateLeft (Vector.toListMap (cons, layoutConArg),
                                        "| "))]))]
-       | Exception ca =>
-            seq [str "exception ", layoutConArg ca]
+       | Exception {con, arg, elab} =>
+            seq [str "exception ",
+                 ExnDecElab.layout elab,
+                 str " ",
+                 layoutConArg {con = con, arg = arg}]
        | Fun {decs, tyvars, ...} => layoutFuns (tyvars, decs)
        | Val {rvbs, tyvars, vbs, ...} =>
             align [layoutFuns (tyvars, rvbs),

mlton/core-ml/core-ml.sig

@@ -163,7 +163,8 @@ signature CORE_ML =
                             tycon: Tycon.t,
                             tyvars: Tyvar.t vector} vector
              | Exception of {arg: Type.t option,
-                             con: Con.t}
+                             con: Con.t,
+                             elab: ExnDecElab.t}
              | Fun of {decs: {lambda: Lambda.t,
                               var: Var.t} vector,
                        tyvars: unit -> Tyvar.t vector}

mlton/defunctorize/defunctorize.fun

@@ -744,9 +744,10 @@ fun defunctorize (CoreML.Program.T {decs}) =
          in
             case d of
                Datatype _ => e
-             | Exception {arg, con} =>
+             | Exception {arg, con, elab} =>
                   prefix (Xdec.Exception {arg = Option.map (arg, loopTy),
-                                          con = con})
+                                          con = con,
+                                          elab = elab})
              | Fun {decs, tyvars} =>
                   prefix (Xdec.Fun {decs = processLambdas decs,
                                     tyvars = tyvars ()})

mlton/elaborate/elaborate-core.fun

@@ -15,6 +15,7 @@ open S
 local
    open Control.Elaborate
 in
+   val exnDecElab = fn () => current exnDecElab
    val nonexhaustiveBind = fn () => current nonexhaustiveBind
    val nonexhaustiveExnBind = fn () => current nonexhaustiveExnBind
    val nonexhaustiveExnMatch = fn () => current nonexhaustiveExnMatch
@@ -137,6 +138,7 @@ in
    structure Convention = CFunction.Convention
    structure Cdec = Dec
    structure Cexp = Exp
+   structure ExnDecElab = ExnDecElab
    structure Ffi = Ffi
    structure IntSize = IntSize
    structure Lambda = Lambda
@@ -2336,10 +2338,17 @@ fun elaborateDec (d, {env = E, nest}) =
                                                      end
                                             val scheme = Scheme.fromType ty
                                             val _ = Env.extendExn (E, exn, exn', scheme)
+                                            val elab =
+                                               case exnDecElab () of
+                                                  Control.Elaborate.ExnDecElab.App =>
+                                                     ExnDecElab.App
+                                                | Control.Elaborate.ExnDecElab.Gen =>
+                                                     ExnDecElab.Gen
                                          in
                                             Decs.add (decs,
                                                       Cdec.Exception {arg = arg,
-                                                                      con = exn'})
+                                                                      con = exn',
+                                                                      elab = elab})
                                          end
                              in
                                 decs

mlton/main/compile.fun

@@ -225,7 +225,8 @@ local
          List.concat [[Datatype primitiveDatatypes],
                       List.map
                       (primitiveExcons, fn c =>
-                       Exception {con = c, arg = NONE})]
+                       Exception {con = c, arg = NONE,
+                                  elab = CoreML.ExnDecElab.Gen})]
       end
 
 in