Standard ML generic testing

generics.mlb

ann "milletDiagnosticsIgnore all" in
  ./mltonlib/com/ssh/extended-basis/unstable/basis.mlb
  ./mltonlib/com/ssh/generic/unstable/lib.mlb
  ./mltonlib/com/ssh/generic/unstable/with/generic.sml
  ./mltonlib/com/ssh/generic/unstable/with/eq.sml
  ./mltonlib/com/ssh/generic/unstable/with/type-hash.sml
  ./mltonlib/com/ssh/generic/unstable/with/type-info.sml
  ./mltonlib/com/ssh/generic/unstable/with/hash.sml
  ./mltonlib/com/ssh/generic/unstable/with/uniplate.sml
  ./mltonlib/com/ssh/generic/unstable/with/ord.sml
  ./mltonlib/com/ssh/generic/unstable/with/pretty.sml
  ./mltonlib/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
end
generics.sml

generics.sml

infix &

val _ =
  let
    fun add a b = a + b
  in
    print ("i: " ^ Int.toString (Fn.uncurry add (1, 2)) ^ "\n")
  end

type 'a person = {name: string, age: int, data: 'a}

fun person a =
  let
    open Generic
  in
    record' (R' "name" string *` R' "age" int *` R' "data" a)
      ( fn {name, age, data} => name & age & data
      , fn (name & age & data) => {name = name, age = age, data = data}
      )
  end

structure Bop =
struct
  datatype t = Add | Sub | Mul | Div

  val t =
    let
      open Generic
    in
      data' (C0' "Add" +` C0' "Sub" +` C0' "Mul" +` C0' "Div")
        ( fn Div => INR ()
           | Mul => INL (INR ())
           | Sub => INL (INL (INR ()))
           | Add => INL (INL (INL ()))
        , fn INR () => Div
           | INL (INR ()) => Mul
           | INL (INL (INR ())) => Sub
           | INL (INL (INL ())) => Add
        )
    end
end

fun tuple5 (a, b, c, d, e) =
  let
    open Generic
  in
    tuple' (T a *` T b *` T c *` T d *` T e)
      ( fn (a, b, c, d, e) => a & b & c & d & e
      , fn a & b & c & d & e => (a, b, c, d, e)
      )
  end

structure Anf =
struct
  type var = string
  datatype value = Int of int | Var of var | Glob of var

  val value =
    let
      open Generic
    in
      data' (C1' "Int" int +` C1' "Var" string +` C1' "Glob" string)
        ( fn Int i => INL (INL i) | Var v => INL (INR v) | Glob v => INR v
        , fn INL (INL i) => Int i | INL (INR v) => Var v | INR v => Glob v
        )
    end

  datatype t =
    Halt of value
  | Fun of var * var list * t * t
  | Join of var * var option * t * t
  | Jump of var * value option
  | App of var * var * value list * t
  | Bop of var * Bop.t * value * value * t
  | If of value * t * t
  | Tuple of var * value list * t
  | Proj of var * var * int * t

  val t =
    let
      open Generic
    in
      Tie.fix Y (fn t =>
        data'
          (C1' "Halt" value +` C1' "Fun" (tuple4 (string, list string, t, t)) +`
             C1' "Join" (tuple4 (string, option string, t, t)) +` C1' "Jump"
             (tuple2 (string, option value)) +` C1' "App"
             (tuple4 (string, string, list value, t)) +` C1' "Bop"
             (tuple5 (string, Bop.t, value, value, t)) +` C1' "If"
             (tuple3 (value, t, t)) +` C1' "Tuple"
             (tuple3 (string, list value, t)) +` C1' "Proj"
             (tuple4 (string, string, int, t)))
          ( fn Proj ? => INR ?
             | Tuple ? => INL (INR ?)
             | If ? => INL (INL (INR ?))
             | Bop ? => INL (INL (INL (INR ?)))
             | App ? => INL (INL (INL (INL (INR ?))))
             | Jump ? => INL (INL (INL (INL (INL (INR ?)))))
             | Join ? => INL (INL (INL (INL (INL (INL (INR ?))))))
             | Fun ? => INL (INL (INL (INL (INL (INL (INL (INR ?)))))))
             | Halt ? => INL (INL (INL (INL (INL (INL (INL (INL ?)))))))
          , fn INR ? => Proj ?
             | INL (INR ?) => Tuple ?
             | INL (INL (INR ?)) => If ?
             | INL (INL (INL (INR ?))) => Bop ?
             | INL (INL (INL (INL (INR ?)))) => App ?
             | INL (INL (INL (INL (INL (INR ?))))) => Jump ?
             | INL (INL (INL (INL (INL (INL (INR ?)))))) => Join ?
             | INL (INL (INL (INL (INL (INL (INL (INR ?))))))) => Fun ?
             | INL (INL (INL (INL (INL (INL (INL (INL ?))))))) => Halt ?
          ))
    end
end

datatype stmt =
  Assign of string * expr
| If of expr * stmt list * stmt list
and expr =
  Stmt of stmt
| Int of int
| Bop of expr * expr

val stmt & expr =
  let
    open Generic
  in
    Tie.fix (Tie.*` (Y, Y)) (fn stmt & expr =>
      data'
        (C1' "Assign" (tuple2 (string, expr)) +` C1' "If"
           (tuple3 (expr, list stmt, list stmt)))
        ( fn If ? => INR ? | Assign ? => INL ?
        , fn INR ? => If ? | INL ? => Assign ?
        )
      &
      data'
        (C1' "Stmt" stmt +` C1' "Int" int +` C1' "Bop" (tuple2 (expr, expr)))
        ( fn Bop ? => INR ? | Int ? => INL (INR ?) | Stmt ? => INL (INL ?)
        , fn INR ? => Bop ? | INL (INR ?) => Int ? | INL (INL ?) => Stmt ?
        ))
  end

val sampleExpr = Stmt (If
  ( Bop (Int 0, Int 1)
  , [Assign ("a", Int 2)]
  , [Assign ("b", (Bop (Int 3, Int 4)))]
  ))

val _ =
  let
    open Generic
  in
    print (show (list int) [1, 2, 3] ^ "\n");
    print (show (option (list int)) (SOME [1, 2, 3]) ^ "\n");
    print (Word.toString (hash (list int) [1, 2, 3]) ^ "\n");
    print (show (person int) {name = "bob", age = 25, data = 420} ^ "\n");
    print (show Anf.t (Anf.Halt (Anf.Int 1)) ^ "\n");
    print (show expr sampleExpr ^ "\n");
    (* Test uniplate *)
    print
      ((show (list expr) (children expr (Bop
          (Bop (Int 1, Int 2), Bop (Int 3, Int 4))))) ^ "\n")
  end