mlyacc/src/absyn.sml

   1 (* Modified by Vesa Karvonen on 2007-12-18.
   2  * Create line directives in output.
   3  *)
   4 (* ML-Yacc Parser Generator (c) 1991 Andrew W. Appel, David R. Tarditi *)
   5
   6 structure Absyn : ABSYN =
   7   struct
   8     datatype exp
   9       = CODE of {text : string, pos : Header.pos}
  10       | EAPP of exp * exp
  11       | EINT of int
  12       | ETUPLE of exp list
  13       | EVAR of string
  14       | FN of pat * exp
  15       | LET of decl list * exp
  16       | SEQ of exp * exp
  17       | UNIT
  18     and pat
  19       = PVAR of string
  20       | PAPP of string * pat
  21       | PINT of int
  22       | PLIST of pat list * pat option
  23       | PTUPLE of pat list
  24       | WILD
  25       | AS of string * pat
  26     and decl = VB of pat * exp
  27     and rule = RULE of pat * exp
  28
  29     fun idchar #"'" = true
  30       | idchar #"_" = true
  31       | idchar c = Char.isAlpha c orelse Char.isDigit c
  32
  33     fun code_to_ids s = let
  34           fun g(nil,r) = r
  35             | g(a as (h::t),r) = if Char.isAlpha h then f(t,[h],r) else g(t,r)
  36           and f(nil,accum,r)= implode(rev accum)::r
  37             | f(a as (h::t),accum,r) =
  38                 if idchar h then f(t,h::accum,r) else g(a,implode (rev accum) :: r)
  39           in g(explode s,nil)
  40           end
  41
  42          val simplifyRule : rule -> rule = fn (RULE(p,e)) =>
  43             let val used : (string -> bool) =
  44                let fun f(CODE s) = code_to_ids (#text s)
  45                      | f(EAPP(a,b)) = f a @ f b
  46                      | f(ETUPLE l) = List.concat (map f l)
  47                      | f(EVAR s) = [s]
  48                      | f(FN(_,e)) = f e
  49                      | f(LET(dl,e)) =
  50                           (List.concat (map (fn VB(_,e) => f e) dl)) @ f e
  51                      | f(SEQ(a,b)) = f a @ f b
  52                      | f _ = nil
  53                    val identifiers = f e
  54                in fn s => List.exists (fn a=>a=s) identifiers
  55                end
  56               val simplifyPat : pat -> pat =
  57                 let fun f a =
  58                     case a
  59                     of (PVAR s) => if used s then a else WILD
  60                      | (PAPP(s,pat)) =>
  61                          (case f pat
  62                           of WILD => WILD
  63                            | pat' => PAPP(s,pat'))
  64                      | (PLIST (l, topt)) =>
  65                          let val l' = map f l
  66                              val topt' = Option.map f topt
  67                              fun notWild WILD = false
  68                                | notWild _ = true
  69                          in case topt' of
  70                                 SOME WILD => if List.exists notWild l' then
  71                                                  PLIST (l', topt')
  72                                              else WILD
  73                               | _ => PLIST (l', topt')
  74                          end
  75                      | (PTUPLE l) =>
  76                           let val l' = map f l
  77                           in if List.exists(fn WILD=>false | _ => true) l'
  78                              then PTUPLE l'
  79                              else WILD
  80                           end
  81                      | (AS(a,b)) =>
  82                          if used a then
  83                              case f b of
  84                                  WILD => PVAR a
  85                                | b' => AS(a,b')
  86                          else f b
  87                      | _ => a
  88                in f
  89                end
  90            val simplifyExp : exp -> exp =
  91                let fun f(EAPP(a,b)) = EAPP(f a,f b)
  92                      | f(ETUPLE l) = ETUPLE(map f l)
  93                      | f(FN(p,e)) = FN(simplifyPat p,f e)
  94                      | f(LET(dl,e)) =
  95                           LET(map (fn VB(p,e) =>
  96                                   VB(simplifyPat p,f e)) dl,
  97                               f e)
  98                      | f(SEQ(a,b)) = SEQ(f a,f b)
  99                      | f a = a
 100                in f
 101                end
 102        in RULE(simplifyPat p,simplifyExp e)
 103        end
 104
 105        fun printRule (say : string -> unit, sayln:string -> unit, fmtPos) r = let
 106            fun flat (a, []) = rev a
 107              | flat (a, SEQ (e1, e2) :: el) = flat (a, e1 :: e2 :: el)
 108              | flat (a, e :: el) = flat (e :: a, el)
 109            fun pl (lb, rb, c, f, [], a) = " " :: lb :: rb :: a
 110              | pl (lb, rb, c, f, h :: t, a) =
 111                  " " :: lb :: f (h, foldr (fn (x, a) => c :: f (x, a))
 112                                           (rb :: a)
 113                                           t)
 114            fun pe (CODE {text, pos}, a) =
 115                  " (" :: fmtPos (SOME pos) :: text :: fmtPos NONE :: ")" :: a
 116              | pe (EAPP (x, y as (EAPP _)), a) =
 117                  pe (x, " (" :: pe (y, ")" :: a))
 118              | pe (EAPP (x, y), a) =
 119                  pe (x, pe (y, a))
 120              | pe (EINT i, a) =
 121                  " " :: Int.toString i :: a
 122              | pe (ETUPLE l, a) = pl ("(", ")", ",", pe, l, a)
 123              | pe (EVAR v, a) =
 124                  " " :: v :: a
 125              | pe (FN (p, b), a) =
 126                  " (fn" :: pp (p, " =>" :: pe (b, ")" :: a))
 127              | pe (LET ([], b), a) =
 128                  pe (b, a)
 129              | pe (LET (dl, b), a) =
 130                let fun pr (VB (p, e), a) =
 131                        " val " :: pp (p, " =" :: pe (e, "\n" :: a))
 132                in " let" :: foldr pr (" in" :: pe (b, "\nend" :: a)) dl
 133                end
 134              | pe (SEQ (e1, e2), a) =
 135                  pl ("(", ")", ";", pe, flat ([], [e1, e2]), a)
 136              | pe (UNIT, a) =
 137                  " ()" :: a
 138            and pp (PVAR v, a) =
 139                  " " :: v :: a
 140              | pp (PAPP (x, y as PAPP _), a) =
 141                  " " :: x :: " (" :: pp (y, ")" :: a)
 142              | pp (PAPP (x, y), a) =
 143                  " " :: x :: pp (y, a)
 144              | pp (PINT i, a) =
 145                  " " :: Int.toString i :: a
 146              | pp (PLIST (l, NONE), a) =
 147                  pl ("[", "]", ",", pp, l, a)
 148              | pp (PLIST (l, SOME t), a) =
 149                  " (" :: foldr (fn (x, a) => pp (x, " ::" :: a))
 150                                (pp (t, ")" :: a))
 151                                l
 152              | pp (PTUPLE l, a) =
 153                  pl ("(", ")", ",", pp, l, a)
 154              | pp (WILD, a) =
 155                  " _" :: a
 156              | pp (AS (v, PVAR v'), a) =
 157                  " (" :: v :: " as " :: v' :: ")" :: a
 158              | pp (AS (v, p), a) =
 159                  " (" :: v :: " as (" :: pp (p, "))" :: a)
 160            fun out "\n" = sayln ""
 161              | out s = say s
 162        in
 163            case simplifyRule r of
 164                RULE (p, e) => app out (pp (p, " =>" :: pe (e, ["\n"])))
 165        end
 166 end;