desugar-decode-syntax.sml 8.19 KB
Newer Older
mb0's avatar
mb0 committed
1

2
structure DesugarDecode = struct
mb0's avatar
mb0 committed
3
4
5
   structure VS = VectorSlice
   structure CM = CompilationMonad
   structure DT = DesugaredTree
mb0's avatar
Up.    
mb0 committed
6
   structure Set = IntBinarySet
7
   structure Pat = DesugaredTree.Pat
mb0's avatar
mb0 committed
8

9
   open DT 
mb0's avatar
mb0 committed
10

mb0's avatar
Up.    
mb0 committed
11
12
   val granularity: int ref = ref 8
   
mb0's avatar
mb0 committed
13
14
15
16
17
18
19
20
21
22
23
   fun insert (map, k, i) = let
      val s =
         case StringMap.find (map, k) of
            NONE => Set.singleton i
          | SOME s => Set.add (s, i)
   in
      StringMap.insert (map, k, s)
   end

   val tok = Atom.atom "tok"
   val slice = Atom.atom "slice"
mb0's avatar
mb0 committed
24
   val return = Atom.atom "return"
mb0's avatar
mb0 committed
25
26
27
28
29
30
31
32
33
34

   fun freshTok () = let
      val (tab, sym) =
         VarInfo.fresh (!SymbolTables.varTable, tok)
   in
      sym before SymbolTables.varTable := tab
   end

   fun consumeTok () = let
      val tok = freshTok ()
mb0's avatar
Up.    
mb0 committed
35
36
      val tokSz = Int.toString(!granularity)
      val consume = Atom.atom("consume"^tokSz)
mb0's avatar
mb0 committed
37
38
39
40
41
42
43
44
      val consume =
         Exp.ID
            (VarInfo.lookup
               (!SymbolTables.varTable, consume))
   in
      (tok, Exp.BIND (tok, consume))
   end

45
   fun unconsumeTok () = let
mb0's avatar
Up.    
mb0 committed
46
47
      val tokSz = Int.toString(!granularity)
      val unconsume = Atom.atom("unconsume"^tokSz)
48
49
50
51
52
53
54
55
      val unconsume =
         Exp.ID
            (VarInfo.lookup
               (!SymbolTables.varTable, unconsume))
   in
      Exp.ACTION unconsume
   end

mb0's avatar
mb0 committed
56
57
58
59
60
61
62
63
   fun sliceExp (tok, offs, sz) = let
      open Exp
      fun INT i = LIT (SpecAbstractTree.INTlit (IntInf.fromInt i))
      val slice =
         ID
            (VarInfo.lookup
               (!SymbolTables.varTable, slice))
   in
mb0's avatar
mb0 committed
64
      APP (slice, [ID tok, INT offs, INT sz])
mb0's avatar
mb0 committed
65
66
   end

mb0's avatar
mb0 committed
67
68
69
70
71
72
73
   fun returnExp tok = let
      open Exp
      val return =
         ID
            (VarInfo.lookup
               (!SymbolTables.varTable, return))
   in
mb0's avatar
mb0 committed
74
      APP (return, [ID tok]) 
mb0's avatar
mb0 committed
75
76
   end

mb0's avatar
mb0 committed
77
78
79
80
81
82
83
84
85
86
87
88
   fun buildEquivClass decls = let
      fun buildEquiv (i, (toks, _), map) =
         insert
            (map,
             if VS.length toks = 0
               then "" (* as placeholder for the real wildcard pattern "_" *)
             else toWildcardPattern (VS.sub (toks, 0)),
             i)
   in
      VS.foldli buildEquiv StringMap.empty decls
   end

mb0's avatar
mb0 committed
89
   fun isBacktrackPattern p = String.size p = 0
90

mb0's avatar
mb0 committed
91
92
   fun layoutDecls (decls: (Pat.t list VS.slice * Exp.t) VS.slice) = let
      open Layout Pretty
mb0's avatar
mb0 committed
93
      fun pats ps = vector (VS.map (fn ps => list (map DT.PP.pat ps)) ps)
mb0's avatar
mb0 committed
94
   in
mb0's avatar
mb0 committed
95
96
97
98
99
100
      align
         [str "decls:", 
          vector (VS.map
            (fn pse =>
               tuple2 (pats, DT.PP.exp) pse) decls),
          str " "]
mb0's avatar
mb0 committed
101
   end
102

103
104
105
106
107
108
109
110
111
112
   fun desugar ds = let
      fun lp (ds, acc) =
         case ds of
            [] => rev acc
          | (toks, e)::ds => lp (ds, (toVec toks, e)::acc)
   in
      desugarCases (toVec (lp (ds, [])))
   end

   and desugarCases (decls: (Pat.t list VS.slice * Exp.t) VS.slice) = let
mb0's avatar
mb0 committed
113
114
      fun grabExp () = 
         if VS.length decls <> 1 
115
            then raise Fail "overlapping patterns detected, guess where!"
mb0's avatar
mb0 committed
116
117
118
         else #2 (VS.sub (decls, 0))
      fun isEmpty (vs, _) = VS.length vs = 0
      val bottom = VS.all isEmpty decls
mb0's avatar
mb0 committed
119
120
   in
      if bottom
121
         then grabExp ()
mb0's avatar
mb0 committed
122
123
124
125
126
127
128
129
130
131
132
133
134
      else
         let
            val (tok, bindTok) = consumeTok ()
         in
            Exp.SEQ
               [bindTok,
                Exp.ACTION
                  (Exp.CASE
                     (Exp.ID tok, desugarMatches tok decls))]
         end
   end

   and desugarMatches tok decls = let
mb0's avatar
mb0 committed
135
      (* +DEBUG:overlapping-patterns *)
136
      (* val () = Pretty.prettyTo (TextIO.stdOut, layoutDecls decls) *)
mb0's avatar
mb0 committed
137
      val equiv = buildEquivClass decls
mb0's avatar
Up.    
mb0 committed
138
139
140
141
142
      (* +DEBUG:overlapping-patterns *)
      (* val () =
         Pretty.prettyTo
            (TextIO.stdOut,
             Pretty.stringtab Pretty.intset equiv) *)
mb0's avatar
mb0 committed
143
144
      
      fun genBindSlices indices = let
145
         open DT.Pat
mb0's avatar
mb0 committed
146
147
148
149
150
151
152
         fun grabSlices (i, acc) = let
            val (toks, e) = VS.sub (decls, i)
            fun grab (pats, offs, acc) =
               case pats of
                  [] => acc
                | pat::ps =>
                     case pat of
153
                        VEC _ => grab (ps, offs + size pat, acc)
154
                      | BND (n, _) =>
mb0's avatar
mb0 committed
155
156
157
                           let
                              val sz = size pat
                           in
mb0's avatar
Up.    
mb0 committed
158
                              if offs = 0 andalso sz = !granularity
mb0's avatar
mb0 committed
159
160
161
162
163
164
165
166
167
168
169
                                 then
                                    grab (ps, offs + sz,
                                       Exp.BIND (n, returnExp tok)::acc)
                              else
                                 grab
                                    (ps,
                                     offs + sz,
                                     Exp.BIND
                                       (n,
                                        sliceExp (tok, offs, sz))::acc)
                           end
mb0's avatar
mb0 committed
170
171
172
         in
            if VS.length toks = 0
               then acc
mb0's avatar
mb0 committed
173
            else grab (rev (VS.sub (toks, 0)), 0, acc)
mb0's avatar
mb0 committed
174
175
176
177
178
         end
      in
         rev (Set.foldl grabSlices [] indices)
      end

mb0's avatar
mb0 committed
179
180
      fun backtrack () =
         case StringMap.find (equiv, "") of
mb0's avatar
mb0 committed
181
            NONE => raise Fail "desugarCases.bug.unboundedBacktrackPattern"
mb0's avatar
mb0 committed
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
          | SOME ix =>
               (case Set.listItems ix of
                  [i] => 
                     let
                        val (_,e) = VS.sub (decls,i)
                     in
                        Exp.SEQ [unconsumeTok(),Exp.ACTION e]
                     end
                | _ => raise Fail "desugarCases.bug.overlappingBacktrackPattern")

      fun extendBacktrackPath ds =
         case StringMap.find (equiv, "") of
            NONE => ds
          | SOME ix =>
               (case Set.listItems ix of
                  [i] => 
                     let
                        val (tok,e) = VS.sub (decls,i)
                     in
                        (tok, Exp.SEQ [unconsumeTok(), Exp.ACTION e])::ds
                     end
                | _ => raise Fail "desugarCases.bug.overlappingBacktrackPattern")

205
206
207
208
209
210
211
      fun isFullWildcard toks =
         let
            val tok = VS.sub(toks,0)
         in
            CharVector.all (fn c => c = #".") (toWildcardPattern tok)
         end

mb0's avatar
mb0 committed
212
      fun stepDown indices = let
mb0's avatar
mb0 committed
213
214
215
216
217
218
219
         fun nextIdx (i, acc) = let
            val (toks, e) = VS.sub (decls, i)
         in
            if VS.length toks = 0
               then (toVec [], e)::acc
            else (VS.subslice (toks, 1, NONE), e)::acc
         end
mb0's avatar
mb0 committed
220
221
222
223
         val decls = Set.foldl nextIdx [] indices
         val decls = 
            case decls of
               [(toks,e)] =>
224
                  if VS.length toks = 0 orelse isFullWildcard toks
mb0's avatar
mb0 committed
225
226
227
228
                     then decls
                  else extendBacktrackPath decls
             | _ => extendBacktrackPath decls
         val decls = toVec (rev decls)
mb0's avatar
mb0 committed
229
230
231
232
233
234
235
236
         val slices = genBindSlices indices
      in
         if null slices
            then desugarCases decls
         else Exp.SEQ (slices @ [Exp.ACTION (desugarCases decls)])
      end

      fun buildMatch (pat, indices, pats) =
mb0's avatar
mb0 committed
237
238
239
         if isBacktrackPattern pat
            then (Core.Pat.BIT pat, backtrack())::pats
         else (Core.Pat.BIT pat, stepDown indices)::pats
mb0's avatar
mb0 committed
240
241
242
243
244
   in
      StringMap.foldli buildMatch [] equiv
   end
end

245
structure DesugarDecodeSyntax : sig
mb0's avatar
mb0 committed
246
   val run:
247
      DesugaredTree.spec ->
mb0's avatar
mb0 committed
248
         Core.Spec.t CompilationMonad.t
mb0's avatar
mb0 committed
249
250
251
252
253
end = struct

   structure CM = CompilationMonad
   structure DT = DesugaredTree

254
255
256
   fun desugar ds =
      List.map
         (fn (n, ds) =>
mb0's avatar
mb0 committed
257
             (n, [], DesugarDecode.desugar ds))
258
         (SymMap.listItemsi ds)
mb0's avatar
mb0 committed
259

260
   fun dumpPre (os, spec) = Pretty.prettyTo (os, DT.PP.spec spec)
mb0's avatar
mb0 committed
261
   fun dumpPost (os, spec) = Pretty.prettyTo (os, Core.PP.spec spec)
mb0's avatar
mb0 committed
262
263
264
265
266

   fun pass t =
      Spec.upd
         (fn (vs, ds) =>
            let
mb0's avatar
Up.    
mb0 committed
267
268
269
               val _ =
                  DesugarDecode.granularity := 
                     IntInf.toInt (Spec.get#granularity t)
270
               val vss = desugar ds
mb0's avatar
mb0 committed
271
            in
mb0's avatar
mb0 committed
272
               vs@vss
mb0's avatar
mb0 committed
273
274
275
276
            end) t
      
   val pass =
      BasicControl.mkKeepPass
277
         {passName="desugarDecodeSyntax",
mb0's avatar
mb0 committed
278
279
280
281
282
283
284
          registry=DesugarControl.registry,
          pass=pass,
          preExt="ast",
          preOutput=dumpPre,
          postExt="ast",
          postOutput=dumpPost}

mb0's avatar
mb0 committed
285
   fun run spec = CM.return (pass spec)
mb0's avatar
mb0 committed
286
end