1(*
2    Copyright (c) 2009, 2015, 2016 David C.J. Matthews
3
4    This library is free software; you can redistribute it and/or
5    modify it under the terms of the GNU Lesser General Public
6    License version 2.1 as published by the Free Software Foundation.
7    
8    This library is distributed in the hope that it will be useful,
9    but WITHOUT ANY WARRANTY; without even the implied warranty of
10    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11    Lesser General Public License for more details.
12    
13    You should have received a copy of the GNU Lesser General Public
14    License along with this library; if not, write to the Free Software
15    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
16*)
17
18functor ExportTree(
19structure STRUCTVALS : STRUCTVALSIG
20structure PRETTY: PRETTYSIG
21): EXPORTTREESIG =
22struct
23    open PRETTY STRUCTVALS
24
25(*
26    datatype ptProperties =
27        PTprint of FixedInt.int -> pretty (* Print the tree *)
28    |   PTtype of types (* Type of an expression *)
29    |   PTdeclaredAt of location (* Declaration location for id. *)
30    |   PTopenedAt of location (* When an identifier comes from an "open" the location of the open. *)
31    |   PTstructureAt of location (* When an identifier comes from open S or S.a the declaration of S. *)
32    |   PTreferences of bool * location list (* The references to the ID.  The first is true if this is exported. *)
33    |   PTparent of unit -> exportTree
34    |   PTpreviousSibling of unit -> exportTree
35    |   PTnextSibling of unit -> exportTree
36    |   PTfirstChild of unit -> exportTree
37    |   PTbreakPoint of bool ref
38    |   PTcompletions of string list
39    withtype exportTree = location * ptProperties list *)
40    local
41        open Address
42        fun cast p = toAddress(toMachineWord p)
43    in
44        type ptProperties = address
45        type exportTree = location * ptProperties list
46
47        fun PTbreakPoint(bpt: bool ref): ptProperties = cast(0w0, bpt)
48        and PTcompletions(sl: string list): ptProperties = cast(0w1, sl)
49        and PTdeclaredAt(loc: location): ptProperties = cast(0w2, loc)
50        and PTdefId(id: FixedInt.int): ptProperties = cast(0w3, id)
51        and PTfirstChild(entry: unit -> exportTree): ptProperties = cast(0w4, entry)
52        and PTnextSibling(entry: unit -> exportTree): ptProperties = cast(0w5, entry)
53        and PTopenedAt(loc: location): ptProperties = cast(0w6, loc)
54        and PTparent(entry: unit -> exportTree): ptProperties = cast(0w7, entry)
55        and PTpreviousSibling(entry: unit -> exportTree): ptProperties = cast(0w8, entry)
56        and PTprint(pr: FixedInt.int -> pretty): ptProperties = cast(0w9, pr)
57        and PTreferences(exp: bool, locs: location list): ptProperties = cast(0w10, exp, locs)
58        and PTrefId(id: FixedInt.int): ptProperties = cast(0w11, id)
59        and PTstructureAt(loc: location): ptProperties = cast(0w12, loc)
60        and PTtype(typ: types): ptProperties = cast(0w13, typ)
61    end
62
63    (* This representation is exported so we have to use a *)
64
65    type navigation =
66        {parent: (unit -> exportTree) option,
67         next: (unit -> exportTree) option,
68         previous: (unit -> exportTree) option}
69
70    (* Navigate within a list *)
71    fun exportList _ [] = []
72    |   exportList(exp, parent) sl =
73    let
74        fun getEntry(this as (s :: sl), getPrevious) () =
75            exp(
76                {
77                    parent = parent,
78                    previous = getPrevious,
79                    (* If we have a successor then that is the entry and
80                       its predecessor returns here. *)
81                    next =
82                        case sl of
83                            [] => NONE
84                        |   t  => SOME(getEntry(t, SOME(getEntry(this, getPrevious))))
85                },
86                s
87                )
88        |   getEntry _ () = raise Empty
89    in
90        [PTfirstChild (getEntry(sl, NONE))]
91    end
92
93    fun exportNavigationProps{parent, previous, next} =
94    let
95        fun mapProps(_, NONE) = [] | mapProps(f, SOME v) = [f v]
96    in
97        (* Common properties for navigation and printing. *)
98        mapProps(PTparent, parent) @
99        mapProps(PTpreviousSibling, previous) @
100        mapProps(PTnextSibling, next)
101    end
102
103    fun getStringAsTree (navigation, s: string, location: location, otherProps) =
104         (location, otherProps @ exportNavigationProps navigation @ [PTprint(fn _ => PrettyString s)])
105
106    (* Tag used to indicate the root tree node in the compiler arguments. *)
107    val rootTreeTag: navigation Universal.tag = Universal.tag()
108
109    (* Map value locations into properties.  This is used for a reference to
110       an id. *)
111    fun mapLocationProps locs =
112    let
113        fun prop (DeclaredAt loc) = PTdeclaredAt loc
114        |   prop (OpenedAt loc) = PTopenedAt loc
115        |   prop (StructureAt loc) = PTstructureAt loc
116        |   prop (SequenceNo id) = PTrefId id
117    in
118        List.map prop locs
119    end
120    
121    (* Defining location.  This sequence Id is a PTdefId.
122       Leave PTdeclaredAt for the moment although it's probably unnecessary
123       since this is the declaration location. *)
124    fun definingLocationProps locs =
125    let
126        fun prop (DeclaredAt loc, l) = PTdeclaredAt loc :: l
127        |   prop (SequenceNo id, l) = PTdefId id :: l
128        |   prop (_, l) = l
129    in
130        List.foldl prop [] locs
131    end
132
133    (* Types that can be shared. *)
134    structure Sharing =
135    struct
136        type types          = types
137        and  locationProp   = locationProp
138        and  pretty         = pretty
139        and  ptProperties   = ptProperties
140    end
141
142end;
143