mlton/control/region.sml

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2006, 2008 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 structure Region: REGION =
  11 struct
  12
  13 datatype t =
  14    Bogus
  15  | T of {left: SourcePos.t,
  16          right: SourcePos.t}
  17
  18 val bogus = Bogus
  19
  20 local
  21    fun make f r =
  22       case r of
  23          Bogus => NONE
  24        | T r => SOME (f r)
  25 in
  26    val left = make #left
  27    val right = make #right
  28 end
  29
  30 val extendRight =
  31    fn (Bogus, _) => Bogus
  32     | (T {left, ...}, right) => T {left = left, right = right}
  33
  34 val toString =
  35    fn Bogus => SourcePos.toString (SourcePos.bogus)
  36     | T {left, right} =>
  37          if SourcePos.isBogus left
  38             orelse SourcePos.isBogus right
  39             orelse not (SourcePos.fileEquals (left, right))
  40             then SourcePos.toString left
  41             else concat [SourcePos.toString left, "-",
  42                          SourcePos.posToString right]
  43
  44 val layout = Layout.str o toString
  45
  46 val make = T
  47
  48 val append =
  49    fn (Bogus, r) => r
  50     | (r, Bogus) => r
  51     | (T {left, ...}, T {right, ...}) => T {left = left, right = right}
  52
  53 fun compare (r, r') =
  54    case (left r, left r') of
  55       (NONE, NONE) => EQUAL
  56     | (NONE, _) => LESS
  57     | (_, NONE) => GREATER
  58     | (SOME p, SOME p') => SourcePos.compare (p, p')
  59
  60 val compare =
  61    Trace.trace2 ("Region.compare", layout, layout, Relation.layout) compare
  62
  63 fun equals (r, r') = compare (r, r') = EQUAL
  64
  65 fun r <= r' =
  66    case compare (r, r') of
  67       EQUAL => true
  68     | GREATER => false
  69     | LESS => true
  70
  71 structure Wrap =
  72    struct
  73       type region = t
  74       datatype 'a t = T of {node: 'a,
  75                             region: region}
  76
  77       fun node (T {node, ...}) = node
  78       fun region (T {region, ...}) = region
  79       fun makeRegion (node, region) = T {node = node, region = region}
  80       fun makeRegion' (node, left, right) = T {node = node,
  81                                                region = make {left = left,
  82                                                               right = right}}
  83
  84       fun dest (T {node, region}) = (node, region)
  85    end
  86
  87 end