lib/mlton/basic/intermediate-computation.sml

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure IntermediateComputation: INTERMEDIATE_COMPUTATION =
   9 struct
  10
  11 structure In = In0
  12 structure Int = Pervasive.Int
  13
  14 structure Result =
  15    struct
  16       datatype t =
  17          Raise
  18        | Return of unit -> Layout.t
  19
  20       local open Layout
  21       in
  22          fun layout r =
  23             case r of
  24                Raise => str "raise"
  25              | Return f => f()
  26       end
  27    end
  28
  29 structure Computation =
  30    struct
  31       structure Time = Time
  32
  33       datatype t = T of callResult list
  34       withtype callResult = {name: string,
  35                              layoutArg: unit -> Layout.t,
  36                              time: Time.t option,
  37                              body: t,
  38                              result: Result.t}
  39
  40       structure CR =
  41          struct
  42             open Layout
  43
  44             type t = callResult
  45
  46             fun layoutName({name, ...}:t) = str(name ^ " ")
  47
  48             fun layoutCall(cr as {layoutArg, ...}:t) =
  49                seq[layoutName cr, layoutArg()]
  50
  51             val darrow = str "==> "
  52
  53             fun layoutDarrow _ = darrow
  54
  55             fun layoutTime({time, ...}:t) =
  56                case time of
  57                   SOME t => Time.layout t
  58                 | NONE => empty
  59
  60             fun layoutReturn({result, ...}:t) =
  61                seq[darrow, Result.layout result]
  62          end
  63
  64       fun time(T crs) = List.fold(crs, Time.zero, fn ({time, ...}, t) =>
  65                                   case time of
  66                                      NONE => t
  67                                    | SOME t' => Time.+(t, t'))
  68
  69       fun keepAll(c, pred) =
  70          let
  71             fun keepAll(T crs) =
  72                T(List.foldr(crs, [],
  73                             fn ({name, body, layoutArg, time, result}, crs) =>
  74                             let val body as T crs' = keepAll body
  75                             in if pred name
  76                                   then {name = name, body = body,
  77                                         layoutArg = layoutArg, time = time,
  78                                         result = result} :: crs
  79                                else crs' @ crs
  80                             end))
  81          in keepAll c
  82          end
  83
  84       fun makeOutputs(pre, post, filter) out =
  85          let val indentation = ref 0
  86             val space = 3
  87             fun left() = indentation := !indentation - space
  88             fun right() = indentation := !indentation + space
  89             fun print l = (Layout.output(Layout.indent(l, !indentation), out)
  90                            ; Out.newline out)
  91             fun output(T crs) = List.foreach(crs, outputCr)
  92             and outputCr(cr as {body, ...}) =
  93                let val printCr = filter cr
  94                in if printCr
  95                      then (print(pre cr); right())
  96                   else ()
  97                      ; output body
  98                      ; if printCr then (left(); print(post cr)) else ()
  99                end
 100          in (output, outputCr)
 101          end
 102
 103       val makeOutput =
 104          makeOutputs(CR.layoutCall, CR.layoutReturn, fn _ => true)
 105       fun output(c, out) = #1(makeOutput out) c
 106       fun outputCr(cr, out) = #2(makeOutput out) cr
 107
 108       val makeOutputCalls =
 109          makeOutputs(CR.layoutName, CR.layoutDarrow, fn _ => true)
 110       fun outputCalls(c, out) = #1(makeOutputCalls out) c
 111       fun outputCrCalls(cr, out) = #2(makeOutputCalls out) cr
 112
 113       fun outputTimes(c, out) =
 114          #1(makeOutputs(CR.layoutName, CR.layoutTime,
 115                         fn {time, ...} =>
 116                         case time of
 117                            NONE => false
 118                          | SOME _ => true) out) c
 119
 120       local
 121          val out = Out.error
 122          val print = Out.outputc out
 123
 124          structure Int =
 125             struct
 126                open Int
 127
 128                exception Input
 129                fun input i = (In.ignoreSpaces i
 130                               ; (case fromString(In.inputToSpace i) of
 131                                     NONE => raise Input
 132                                   | SOME n => n))
 133
 134                fun inputBetween{ins, error: unit -> unit, min, max} =
 135                   let
 136                      fun loop() =
 137                         let fun continue() = (error() ; loop())
 138                         in let val n = input ins
 139                            in if min <= n andalso n <= max
 140                                  then n
 141                               else continue()
 142                            end handle Input => continue()
 143                         end
 144                   in loop()
 145                   end
 146
 147                val layout = Layout.str o toString
 148             end
 149
 150          fun inputBetween(min, max) =
 151            Int.inputBetween{ins = In.standard,
 152                             error = fn () => Out.output(out, "? "),
 153                             min = min, max = max}
 154
 155          fun choose (choices: (string * 'a) list): 'a =
 156             let
 157                val n =
 158                   List.fold(choices, 0, fn ((name, _),n) =>
 159                             (Layout.output(Int.layout n, out)
 160                              ; print(concat[". ", name, "\n"])
 161                              ; n+1))
 162                val _ = Out.output(out, "? ")
 163                val m = inputBetween(0,n-1)
 164             in #2(List.nth(choices, m))
 165             end
 166
 167          fun chooseThunk cs = choose cs ()
 168
 169          exception Quit
 170          exception Back
 171
 172          val standardChoices = [("quit", fn () => raise Quit),
 173                                 ("back", fn () => raise Back)]
 174
 175          fun inspect(c as T crs) =
 176             case crs of
 177                [cr] => inspectCr cr
 178              | _ =>
 179                   let
 180                      fun loop() =
 181                         (chooseThunk
 182                          (standardChoices
 183                           @ [("skip raises", fn () =>
 184                               (skipRaises c; raise Back)),
 185                              ("output", fn () => output(c, out)),
 186                              ("output calls",
 187                               fn () => outputCalls(c, out))]
 188                           @ choices c)
 189                          ; loop())
 190                   in loop() handle Back => ()
 191                   end
 192          and choices(T crs) =
 193             List.map(crs, fn cr as {name, ...} =>
 194                      ("  " ^ name, fn () => inspectCr cr))
 195          and inspectCr(cr as {name, layoutArg, body, result, time = _}) =
 196             (print(concat["Call to ", name, "\n"])
 197              ; let
 198                   fun loop() =
 199                      (chooseThunk
 200                       (standardChoices
 201                        @ [("skip raises", fn () =>
 202                            (skipRaisesCr cr; raise Back)),
 203                           ("output", fn () =>
 204                            outputCr(cr, out)),
 205                           ("output calls", fn () =>
 206                            outputCrCalls(cr, out)),
 207                           ("argument", fn () =>
 208                            (Layout.output(layoutArg(), out)
 209                             ; Out.newline out)),
 210                           ("result", fn () =>
 211                            (Layout.output(Result.layout result, out)
 212                             ; Out.newline out))]
 213                        @ choices body)
 214                       ; loop())
 215                in loop() handle Back => ()
 216                end)
 217          and skipRaises(c as T crs) =
 218             case crs of
 219                [] => ()
 220              | _ => (skipRaisesCr(List.last crs)
 221                      ; inspect c)
 222          and skipRaisesCr(cr as {result, body, ...}) =
 223             (case result of
 224                 Result.Raise => skipRaises body
 225               | Result.Return _ => ()
 226              ; inspectCr cr)
 227       in val inspect = fn c => inspect c handle Quit => ()
 228       end
 229
 230    end
 231
 232 (*---------------------------------------------------*)
 233 (*                   Main Datatype                   *)
 234 (*---------------------------------------------------*)
 235
 236 datatype t =
 237    T of {calls: {name: string,
 238                   layoutArg: unit -> Layout.t,
 239                   prev: Computation.callResult list} list ref,
 240          after: Computation.callResult list ref}
 241
 242 fun empty() = T{calls = ref [],
 243                 after = ref []}
 244
 245 fun atTopLevel(T{calls, ...}) = List.isEmpty(!calls)
 246
 247 fun call(T{calls, after},name, layoutArg) =
 248    (List.push(calls, {name = name, layoutArg = layoutArg, prev = !after})
 249     ; after := [])
 250
 251 fun return(T{calls, after}, result, time) =
 252    case !calls of
 253       [] => Error.bug "IntermediateComputation.return: without a call"
 254     | {name, layoutArg, prev} :: cs =>
 255          (calls := cs
 256           ; after := {name = name, layoutArg = layoutArg,
 257                       result = result, time = time,
 258                       body = Computation.T(List.rev(!after))} :: prev)
 259
 260 fun raisee(c, t) = return(c, Result.Raise, t)
 261 val return = fn (c, r, t) => return(c, Result.Return r, t)
 262
 263 fun finish(c as T{calls, after}) =
 264    let
 265       fun loop() =
 266          case !calls of
 267             [] => Computation.T(List.rev(!after))
 268           | _ => (raisee(c, NONE); loop())
 269    in loop()
 270    end
 271
 272 end