1structure locn :> locn =
2struct
3
4  datatype locn_point = LocP of int
5                              * int
6                              * int
7                      | LocA of int
8                              * int
9                      | LocPBeg of int
10                      | LocPEnd of int
11
12  fun locn_point_toString (LocP(nf,r,c))
13      = "frag "^Int.toString(nf)^" row "^Int.toString(r)^" col "^Int.toString(c)
14    | locn_point_toString (LocA(r,c))
15      = "line "^Int.toString(r+1)^", character "^Int.toString(c+1)
16    | locn_point_toString (LocPBeg(nf))
17      = "beginning of frag "^Int.toString(nf)
18    | locn_point_toString (LocPEnd(nf))
19      = "end of frag "^Int.toString(nf)
20
21  fun rel_to_abs row col (LocP(nf,r,c))
22      = if r = 0 then
23            LocA(row,col+c)
24        else
25            LocA(row+r,c)
26    | rel_to_abs row col locp
27      = locp
28
29  datatype locn = Loc of locn_point * locn_point (* start and end character *)
30                | Loc_None                       (* compiler-generated *)
31                | Loc_Unknown
32                | Loc_Near of locn
33
34  (* trying to be a little clever about common cases *)
35  fun toString (Loc(LocP(nf1,r1,c1),LocP(nf2,r2,c2)))
36      = if nf1 <> nf2 then
37            "between frag "^
38            Int.toString(nf1)^" row "^Int.toString(r1)^" col "^Int.toString(c1)^
39            " and frag "^
40            Int.toString(nf2)^" row "^Int.toString(r2)^" col "^Int.toString(c2)
41        else if r1 <> r2 then
42            "in frag "^Int.toString(nf1)^", between row "^
43            Int.toString(r1)^" col "^Int.toString(c1)^
44            " and row "^
45            Int.toString(r2)^" col "^Int.toString(c2)
46        else if c1 <> c2 then
47            "on frag "^Int.toString(nf1)^" row "^Int.toString(r1)^
48            ", between cols "^
49            Int.toString(c1)^" and "^Int.toString(c2)
50        else
51            "at frag "^Int.toString(nf1)^" row "^Int.toString(r1)^" col "^Int.toString(c1)
52    | toString (Loc(LocA(r1,c1),LocA(r2,c2)))
53      = if r1 <> r2 then
54            "between line "^
55            Int.toString(r1+1)^", character "^Int.toString c1^
56            " and line "^
57            Int.toString(r2+1)^", character "^Int.toString c2
58        else if c1 <> c2 then
59            "on line "^Int.toString(r1+1)^
60            ", characters "^
61            Int.toString c1^"-"^Int.toString c2
62        else
63            "at line "^Int.toString(r1+1)^", character "^Int.toString c1
64    | toString (Loc(s,e))
65      = if s = e then
66            "at "^locn_point_toString s
67        else
68            "between "^locn_point_toString s^" and "^locn_point_toString e
69    | toString (Loc_None)
70      = "in compiler-generated text"
71    | toString (Loc_Unknown)
72      = "in unknown location"
73    | toString (Loc_Near(locn))
74      = "roughly "^toString locn
75
76  fun toShortString loc = let
77    fun p2str lp =
78        case lp of
79          LocP(f,l,c) => "f"^Int.toString f^":"^Int.toString l^":"^
80                         Int.toString c
81        | LocA(l,c) => Int.toString (l+1)^":"^ Int.toString c
82        | LocPBeg i => "f"^Int.toString i
83        | LocPEnd i => "f"^Int.toString i
84  in
85    case loc of
86      Loc(p1,p2) => p2str p1 ^ "-" ^ p2str p2
87    | Loc_None => "<no loc>"
88    | Loc_Unknown => "<??>"
89    | Loc_Near loc => "~" ^ toShortString loc
90  end
91
92  fun locp p = Loc(p,p)
93
94  fun locfrag nf = Loc(LocPBeg nf,LocPEnd nf)
95
96  fun move_start delta (Loc(LocP(nf,r,c),e)) = Loc(LocP(nf,r,c+delta),e)
97    | move_start delta (Loc(LocA(r,c),e))    = Loc(LocA(r,c+delta),e)
98    | move_start delta locn                  = locn
99
100  fun split_at delta (Loc(LocP(nf,r,c),e))
101      = (Loc(LocP(nf,r,c),LocP(nf,r,c+delta-1)),
102         Loc(LocP(nf,r,c+delta),e))
103    | split_at delta (Loc(LocA(r,c),e))
104      = (Loc(LocA(r,c),LocA(r,c+delta-1)),
105         Loc(LocA(r,c+delta),e))
106    | split_at delta locn
107      = (locn,locn)
108
109  fun near (loc as Loc_Near _) = loc
110    | near  loc                = Loc_Near loc
111
112  fun between (Loc(lploc,_))  (Loc(_,rploc))  = Loc(lploc,rploc)
113    | between  Loc_None        rloc           = rloc
114    | between  lloc            Loc_None       = lloc
115    | between  Loc_Unknown     rloc           = near rloc
116    | between  lloc            Loc_Unknown    = near lloc
117    | between (Loc_Near lloc)  rloc           = near (between lloc rloc)
118    | between  lloc           (Loc_Near rloc) = near (between lloc rloc)
119
120  type 'a located = 'a * locn
121
122end;
123