lib/mlton/basic/choice-pattern.sml

   1 (* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure ChoicePattern: CHOICE_PATTERN =
   9 struct
  10
  11 datatype t =
  12    Concat of t vector
  13  | Choice of t vector
  14  | String of string
  15
  16 fun layout t =
  17    let
  18       open Layout
  19    in
  20       case t of
  21          Concat v => seq [str "Concat ", Vector.layout layout v]
  22        | Choice v => seq [str "Choice ", Vector.layout layout v]
  23        | String s => seq [str "\"", String.layout s, str "\""]
  24    end
  25
  26 fun fromString (s: string): t Result.t =
  27    let
  28       val n = String.size s
  29       exception Error of string
  30       fun error ss = raise Error (concat ss)
  31       datatype state =
  32          Nest of {start: int}
  33         | Normal
  34       fun loop (cur: int,
  35                 ac: char list,
  36                 prev: t list,
  37                 prevChoices: t list,
  38                 state: state): int * t =
  39          let
  40             fun accum () = String (String.fromListRev ac) :: prev
  41             fun finishChoice () =
  42                Concat (Vector.fromListRev (accum ())) :: prevChoices
  43             fun keepChar cur =
  44                loop (cur + 1, String.sub (s, cur) :: ac,
  45                      prev, prevChoices, state)
  46          in
  47             if cur < n
  48                then
  49                   let
  50                      val c = String.sub (s, cur)
  51                   in
  52                      case c of
  53                         #"{" => let
  54                                    val (cur, t) =
  55                                       loop (cur + 1, [], [], [],
  56                                             Nest {start = cur})
  57                                 in
  58                                    loop (cur, [], t :: accum (), prevChoices,
  59                                          state)
  60                                 end
  61                       | #"}" =>
  62                            (case state of
  63                                Nest _ =>
  64                                   (cur + 1,
  65                                    Choice (Vector.fromList (finishChoice ())))
  66                              | Normal =>
  67                                   error ["unmatched } at position ",
  68                                          Int.toString cur])
  69                       | #"," =>
  70                            (case state of
  71                                Nest _ => loop (cur + 1, [], [], finishChoice (),
  72                                                state)
  73                              | Normal => keepChar cur)
  74                       | #"\\" =>
  75                            let
  76                               val cur = cur + 1
  77                            in
  78                               if cur = n
  79                                  then error ["terminating backslash"]
  80                               else keepChar cur
  81                            end
  82                       | _ => keepChar cur
  83                   end
  84             else
  85                (case state of
  86                    Nest {start} =>
  87                       error ["unmatched { at position ",
  88                              Int.toString start]
  89                  | Normal =>
  90                       (cur, Concat (Vector.fromListRev (accum ()))))
  91          end
  92    in
  93       Result.Yes (#2 (loop (0, [], [], [], Normal)))
  94       handle Error s => Result.No s
  95    end
  96
  97 val fromString =
  98    Trace.trace ("ChoicePattern.fromString", String.layout, Result.layout layout)
  99    fromString
 100
 101 fun foldDown (v, a, f) =
 102    let
 103       fun loop (i, a) =
 104          if i < 0
 105             then a
 106          else loop (i - 1, f (Vector.sub (v, i), a))
 107    in
 108       loop (Vector.length v - 1, a)
 109    end
 110
 111 fun expandTree (t: t): string list =
 112    case t of
 113       Choice v =>
 114          Vector.fold (v, [], fn (t, ac) =>
 115                       expandTree t @ ac)
 116     | Concat v =>
 117          foldDown (v, [""], fn (t, ac) =>
 118                    List.fold
 119                    (expandTree t, [], fn (s, all) =>
 120                     List.fold
 121                     (ac, all, fn (s', all) =>
 122                      concat [s, s'] :: all)))
 123     | String s => [s]
 124
 125 fun expand (s: string): string list Result.t =
 126    Result.map (fromString s, expandTree)
 127
 128 end