mlton/ast/ast-programs.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor AstPrograms (S: AST_PROGRAMS_STRUCTS): AST_PROGRAMS =
  11 struct
  12
  13 open S
  14
  15 structure AstModules = AstModules (S)
  16
  17 open AstModules Layout
  18
  19 structure Program =
  20    struct
  21       datatype t = T of Topdec.t list list
  22
  23       val empty = T []
  24
  25       fun layout (T dss) =
  26          Layout.align (List.map (dss, fn ds =>
  27                                  Layout.paren
  28                                  (Layout.align (List.map (ds, Topdec.layout)))))
  29
  30       fun checkSyntax (T dss) =
  31          List.foreach (dss, fn ds => List.foreach (ds, Topdec.checkSyntax))
  32
  33       fun coalesce (T dss): t =
  34          let
  35             fun finish (sds, ac) =
  36                case sds of
  37                   [] => ac
  38                 | _ =>
  39                      let
  40                         val t =
  41                            Topdec.makeRegion
  42                            (Topdec.Strdec (Strdec.makeRegion
  43                                            (Strdec.Seq (rev sds), Region.bogus)),
  44                             Region.bogus)
  45                      in
  46                         t :: ac
  47                      end
  48             fun loop (ds, sds, ac) =
  49                case ds of
  50                   [] => finish (sds, ac)
  51                 | d :: ds =>
  52                      case Topdec.node d of
  53                         Topdec.Strdec d => loop (ds, d :: sds, ac)
  54                       | _ => loop (ds, [], d :: finish (sds, ac))
  55          in
  56             T (List.map (dss, fn ds => rev (loop (ds, [], []))))
  57          end
  58
  59       val coalesce =
  60          Trace.trace ("AstPrograms.Program.coalesce", layout, layout) coalesce
  61
  62       fun size (T dss): int =
  63          let
  64             val n = ref 0
  65             fun inc () = n := 1 + !n
  66             fun dec (d: Dec.t): unit =
  67                let
  68                   datatype z = datatype Dec.node
  69                in
  70                   case Dec.node d of
  71                      Abstype {body, ...} => dec body
  72                    | Exception cs => Vector.foreach (cs, fn _ => inc ())
  73                    | Fun {fbs, ...} =>
  74                         Vector.foreach (fbs, fn clauses =>
  75                                         Vector.foreach (clauses, exp o #body))
  76                    | Local (d, d') => (dec d; dec d')
  77                    | SeqDec ds => Vector.foreach (ds, dec)
  78                    | Val {vbs, rvbs, ...} =>
  79                         (Vector.foreach (vbs, exp o #exp)
  80                          ; Vector.foreach (rvbs, match o #match))
  81                    | _ => ()
  82                end
  83             and exp (e: Exp.t): unit =
  84                let
  85                   val _ = inc ()
  86                   datatype z = datatype Exp.node
  87                in
  88                   case Exp.node e of
  89                      Andalso (e1, e2) => (exp e1; exp e2)
  90                    | App (e, e') => (exp e; exp e')
  91                    | Case (e, m) => (exp e; match m)
  92                    | Constraint (e, _) => exp e
  93                    | FlatApp es => exps es
  94                    | Fn m => match m
  95                    | Handle (e, m) => (exp e; match m)
  96                    | If (e1, e2, e3) => (exp e1; exp e2; exp e3)
  97                    | Let (d, e) => (dec d; exp e)
  98                    | List es => Vector.foreach (es, exp)
  99                    | Orelse (e1, e2) => (exp e1; exp e2)
 100                    | Raise exn => exp exn
 101                    | Record r => Record.foreach (r, exp o #2)
 102                    | Seq es => exps es
 103                    | While {test, expr} => (exp test; exp expr)
 104                    | _ => ()
 105                end
 106             and exps es = Vector.foreach (es, exp)
 107             and match m =
 108                let
 109                   val Match.T rules = Match.node m
 110                in
 111                   Vector.foreach (rules, exp o #2)
 112                end
 113             fun strdec d =
 114                let
 115                   datatype z = datatype Strdec.node
 116                in
 117                   case Strdec.node d of
 118                      Core d => dec d
 119                    | Local (d, d') => (strdec d; strdec d')
 120                    | Seq ds => List.foreach (ds, strdec)
 121                    | ShowBasis _ => ()
 122                    | Structure ds =>
 123                         Vector.foreach (ds, fn {def, ...} => strexp def)
 124                end
 125             and strexp e =
 126                let
 127                   datatype z = datatype Strexp.node
 128                in
 129                   case Strexp.node e of
 130                      Struct d => strdec d
 131                    | Constrained (e, _) => strexp e
 132                    | App (_, e) => strexp e
 133                    | Let (d, e) => (strdec d; strexp e)
 134                    | _ => ()
 135                end
 136
 137             fun topdec d =
 138                let
 139                   datatype z = datatype Topdec.node
 140                in
 141                   case Topdec.node d of
 142                      Functor ds =>
 143                         Vector.foreach (ds, fn {body, ...} => strexp body)
 144                    | Strdec d => strdec d
 145                    | _ => ()
 146                end
 147             val _ = List.foreach (dss, fn ds => List.foreach (ds, topdec))
 148          in
 149             !n
 150          end
 151       (* quell unused warning *)
 152       val _ = size
 153    end
 154
 155 end