mlton/elaborate/precedence-parse.fun

   1 (* Heavily modified from the SML/NJ sources. *)
   2
   3 (* Copyright 1996 by AT&T Bell Laboratories *)
   4 (* precedence.sml *)
   5
   6 functor PrecedenceParse (S: PRECEDENCE_PARSE_STRUCTS): PRECEDENCE_PARSE =
   7 struct
   8
   9 open S
  10
  11 local open Ast
  12 in structure Exp = Exp
  13    structure Fixity = Fixity
  14    structure Fixop = Fixop
  15    structure Longvid = Longvid
  16    structure Pat = Pat
  17    structure Vid = Vid
  18 end
  19
  20 structure Exp =
  21 struct
  22    open Exp
  23    fun apply {func, arg} = Exp.app (func, arg)
  24    fun applyInfix {func, argl, argr} =
  25       let
  26          val arg = Exp.tuple (Vector.new2 (argl, argr))
  27       in
  28          Exp.makeRegion (Exp.App (func, arg),
  29                          Exp.region arg)
  30       end
  31 end
  32
  33 structure Pat =
  34 struct
  35    open Pat
  36    local
  37       fun finishApply {func, arg, region, ctxt} =
  38          case Pat.node func of
  39             Pat.Var {name, ...} =>
  40                Pat.makeRegion (Pat.App (Longvid.toLongcon name, arg),
  41                                region)
  42           | _ =>
  43                let
  44                   val () =
  45                      Control.error
  46                      (region,
  47                       Layout.str "non-constructor applied to argument in pattern",
  48                       ctxt ())
  49                in
  50                   Pat.wild
  51                end
  52    in
  53       fun apply ctxt {func, arg} =
  54          finishApply {func = func, arg = arg,
  55                       region = Region.append (Pat.region func, Pat.region arg),
  56                       ctxt = ctxt}
  57       fun applyInfix ctxt {func, argl, argr} =
  58          let
  59             val arg = Pat.tuple (Vector.new2 (argl, argr))
  60          in
  61             finishApply {func = func, arg = arg,
  62                          region = Pat.region arg,
  63                          ctxt = ctxt}
  64          end
  65    end
  66 end
  67
  68 structure Fixval =
  69    struct
  70       datatype t = Nonfix | Infix of int * int
  71
  72       fun eval (f: Fixity.t): t =
  73          case f of
  74             Fixity.Infix NONE => Infix (0, 1)
  75           | Fixity.Infix (SOME n) => Infix (n+n, n+n+1)
  76           | Fixity.Infixr NONE => Infix (1, 0)
  77           | Fixity.Infixr (SOME n) => Infix (n+n+1, n+n)
  78           | Fixity.Nonfix => Nonfix
  79
  80       fun make ({name: Longvid.t, fixop: Fixop.t}, E: Env.t): t =
  81          case (fixop, Longvid.split name) of
  82             (Fixop.None, ([], vid)) =>
  83                (case Env.peekFix (E, vid) of
  84                    NONE => Nonfix
  85                  | SOME f => eval f)
  86           | _ => Nonfix
  87
  88       fun makePat (p: Pat.t, E: Env.t): t =
  89          case Pat.node p of
  90             Pat.Var r => make (r, E)
  91           | _ => Nonfix
  92
  93       fun makeExp (e: Exp.t, E: Env.t): t =
  94          case Exp.node e of
  95             Exp.Var r => make (r, E)
  96           | _ => Nonfix
  97    end
  98
  99 (*---------------------------------------------------*)
 100 (*           from elaborate/precedence.sml           *)
 101 (*---------------------------------------------------*)
 102
 103 datatype 'a precStack =
 104    INf of int * 'a * 'a precStack
 105  | NONf of 'a * 'a precStack
 106  | NILf
 107
 108 fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a,
 109               applyInfix: {func: 'a, argl: 'a, argr: 'a} -> 'a,
 110               ctxt: unit -> Layout.t,
 111               fixval: 'a -> Fixval.t,
 112               items: 'a vector,
 113               name: string,
 114               region: 'a -> Region.t,
 115               toString: 'a -> string}: 'a =
 116    let
 117       fun error (r: Region.t, msg: string) =
 118          Control.error (r, Layout.str msg, ctxt ())
 119       fun ensureNONf ((e, f), p, start) =
 120          let
 121             val _ =
 122                case f of
 123                   Fixval.Nonfix => ()
 124                 | _ =>
 125                      error
 126                      (region e,
 127                       concat [if start
 128                                  then name ^ " starts with infix identifier: "
 129                                  else "identifier must be used infix: ",
 130                               toString e])
 131          in
 132             NONf (e, p)
 133          end
 134       fun start token = ensureNONf (token, NILf, true)
 135       (* parse an expression *)
 136       fun parse (stack: 'a precStack, (item: 'a, fixval: Fixval.t)) =
 137          case (stack, (item, fixval)) of
 138             (NONf (e, r), (e', Fixval.Nonfix)) => NONf (apply {func = e, arg = e'}, r)
 139           | (p as INf _, token) => ensureNONf (token, p, false)
 140           | (p as NONf (e1, INf (bp, e2, NONf (e3, r))),
 141              (e4, f as Fixval.Infix (lbp, rbp))) =>
 142             if lbp > bp then INf (rbp, e4, p)
 143             else (if lbp = bp
 144                      then error (Region.append (region e2, region e4),
 145                                  concat ["infix identifiers with equal precedence but mixed associativity: ", toString e2, ", ", toString e4])
 146                   else ();
 147                   parse (NONf (applyInfix {func = e2, argl = e3, argr = e1},
 148                                r),
 149                          (e4, f)))
 150            | (p as NONf _, (e', Fixval.Infix (_, rbp))) => INf (rbp, e', p)
 151            | _ => Error.bug "PrecedenceParse.parse.parse"
 152       (* clean up the stack *)
 153       fun finish stack =
 154          case stack of
 155             NONf (e1, INf (_, e2, NONf (e3, r))) =>
 156                finish (NONf (applyInfix {func = e2, argl = e3, argr = e1},
 157                              r))
 158           | NONf (e1, NILf) => e1
 159           | INf (_, e1, NONf (e2, p)) =>
 160                (error (region e1, concat [name, " ends with infix identifier: ", toString e1])
 161                 ; finish (NONf (apply {func = e2, arg = e1}, p)))
 162           | NILf => Error.bug "PrecedenceParse.parse.finish: NILf"
 163           | _ => Error.bug "PrecedenceParse.parse.finish"
 164       fun getfix x = (x, fixval x)
 165    in
 166       if Vector.isEmpty items
 167          then
 168             Error.bug "PrecedenceParse.parse"
 169       else
 170          let
 171             val item = Vector.first items
 172          in
 173             finish (Vector.foldFrom
 174                     (items, 1, start (getfix item), fn (item, state) =>
 175                      parse (state, getfix item)))
 176          end
 177    end
 178
 179 fun parsePat (ps, E, ctxt) =
 180    parse {apply = Pat.apply ctxt,
 181           applyInfix = Pat.applyInfix ctxt,
 182           ctxt = ctxt,
 183           fixval = fn p => Fixval.makePat (p, E),
 184           items = ps,
 185           name = "pattern",
 186           region = Pat.region,
 187           toString = Layout.toString o Pat.layout}
 188
 189 val parsePat =
 190    Trace.trace ("PrecedenceParse.parsePat",
 191                 fn (ps, _, _) => Vector.layout Pat.layout ps,
 192                 Ast.Pat.layout)
 193    parsePat
 194
 195 fun parseExp (es, E, ctxt) =
 196    parse {apply = Exp.apply,
 197           applyInfix = Exp.applyInfix,
 198           ctxt = ctxt,
 199           fixval = fn e => Fixval.makeExp (e, E),
 200           items = es,
 201           name = "expression",
 202           region = Exp.region,
 203           toString = Layout.toString o Exp.layout}
 204
 205 val parseExp =
 206    Trace.trace ("PrecedenceParse.parseExp",
 207                 fn (es, _, _) => Vector.layout Exp.layout es,
 208                 Ast.Exp.layout)
 209    parseExp
 210
 211 (*---------------------------------------------------*)
 212 (*                    parseClause                    *)
 213 (*---------------------------------------------------*)
 214
 215 structure ClausePat =
 216    struct
 217       datatype t =
 218          Apply of {func: t, arg: t}
 219        | ApplyInfix of {func: t, argl: t, argr: t}
 220        | Pat of Pat.t
 221
 222       fun region p =
 223          case p of
 224             Apply {func, arg} =>
 225                Region.append (region func, region arg)
 226           | ApplyInfix {argl, argr, ...} =>
 227                Region.append (region argl, region argr)
 228           | Pat p => Pat.region p
 229
 230       local
 231          fun toPat p =
 232             case p of
 233                Apply {func, arg} =>
 234                   let
 235                      val func = toPat func
 236                      val arg = toPat arg
 237                   in
 238                      Pat.makeRegion
 239                      (Pat.FlatApp (Vector.new2 (func, arg)),
 240                       Region.append (Pat.region func, Pat.region arg))
 241                   end
 242              | ApplyInfix {func, argl, argr} =>
 243                   let
 244                      val func = toPat func
 245                      val argl = toPat argl
 246                      val argr = toPat argr
 247                   in
 248                      Pat.makeRegion
 249                      (Pat.FlatApp (Vector.new3 (argl, func, argr)),
 250                       Region.append (Pat.region argl, Pat.region argr))
 251                   end
 252              | Pat p => p
 253       in
 254          val layout = Pat.layout o toPat
 255       end
 256    end
 257
 258 fun parseClausePats (ps, E, ctxt) =
 259    parse {apply = ClausePat.Apply,
 260           applyInfix = ClausePat.ApplyInfix,
 261           ctxt = ctxt,
 262           fixval = fn ClausePat.Pat p => Fixval.makePat (p, E)
 263                     | _ => Fixval.Nonfix,
 264           items = Vector.map (ps, ClausePat.Pat),
 265           name = "function clause",
 266           region = ClausePat.region,
 267           toString = Layout.toString o ClausePat.layout}
 268
 269 fun parseClause (pats: Pat.t vector, E: Env.t, ctxt) =
 270    let
 271       fun error (region, msg) =
 272          Control.error (region, msg, ctxt ())
 273       fun improper region =
 274          error
 275          (region, Layout.str "function clause with improper infix pattern")
 276
 277       fun toPat p=
 278          case p of
 279             ClausePat.Pat p => p
 280           | ClausePat.Apply {func, arg} =>
 281                Pat.apply ctxt
 282                {func = toPat func,
 283                 arg = toPat arg}
 284           | ClausePat.ApplyInfix {func, argl, argr} =>
 285                Pat.applyInfix ctxt
 286                {func = toPat func,
 287                 argl = toPat argl,
 288                 argr = toPat argr}
 289       fun toPatTop p =
 290          case p of
 291             ClausePat.Pat p => p
 292           | _ => (improper (ClausePat.region p)
 293                   ; toPat p)
 294       fun toPatList p =
 295          let
 296             fun loop (p, args) =
 297                case p of
 298                   ClausePat.Apply {func, arg} =>
 299                      loop (func, (toPatTop arg)::args)
 300                 | _ => (toPatTop p)::args
 301          in
 302             loop (p, [])
 303          end
 304
 305       fun done (func: Pat.t, args: Pat.t list) =
 306          let
 307             fun illegalName () =
 308                (error (Pat.region func,
 309                        Layout.seq [Layout.str "function clause with illegal name: ",
 310                                    Pat.layout func])
 311                 ; Ast.Var.bogus)
 312             val func =
 313                case Pat.node func of
 314                   Pat.Var {name, ...} =>
 315                      (case Longvid.split name of
 316                          ([], x) => Vid.toVar x
 317                        | _ => illegalName ())
 318                 | _ => illegalName ()
 319             val args = Vector.fromList args
 320             val _ =
 321                if Vector.isEmpty args
 322                   then error (Region.append (Pat.region (Vector.sub (pats, 0)),
 323                                              Pat.region (Vector.last pats)),
 324                               Layout.str "function clause with no arguments")
 325                   else ()
 326          in
 327             {func = func, args = args}
 328          end
 329       fun doneApplyInfix ({func, argl, argr}, rest) =
 330          let
 331             val func = toPatTop func
 332             val argl = toPatTop argl
 333             val argr = toPatTop argr
 334          in
 335             done (func, (Pat.tuple (Vector.new2 (argl, argr)))::rest)
 336          end
 337    in
 338       case parseClausePats (pats, E, ctxt) of
 339          ClausePat.ApplyInfix func_argl_argr =>
 340             doneApplyInfix (func_argl_argr, [])
 341        | p =>
 342             (case toPatList p of
 343                 [] => Error.bug "PrecedenceParse.parseClause: empty"
 344               | p::rest =>
 345                    let
 346                       val improper = fn () =>
 347                          (improper (Pat.region p)
 348                           ; done (Pat.var Ast.Var.bogus, rest))
 349                    in
 350                       case Pat.node p of
 351                          Pat.Paren p' =>
 352                             (case Pat.node p' of
 353                                 Pat.FlatApp pats =>
 354                                    (case parseClausePats (pats, E, ctxt) of
 355                                        ClausePat.ApplyInfix func_argl_argr =>
 356                                           doneApplyInfix (func_argl_argr, rest)
 357                                      | _ => improper ())
 358                               | _ => improper ())
 359                        | _ => done (p, rest)
 360                    end)
 361    end
 362
 363 end