src/lib/metalua/extension/match.mlua

   1 ----------------------------------------------------------------------
   2 -- Metalua samples:  $Id$
   3 --
   4 -- Summary: Structural pattern matching for metalua ADT.
   5 --
   6 ----------------------------------------------------------------------
   7 --
   8 -- Copyright (c) 2006-2008, Fabien Fleutot <metalua@gmail.com>.
   9 --
  10 -- This software is released under the MIT Licence, see licence.txt
  11 -- for details.
  12 --
  13 --------------------------------------------------------------------------------
  14 --
  15 -- Glossary:
  16 --
  17 -- * term_seq: the tested stuff, a sequence of terms
  18 -- * pattern_element: might match one term of a term seq. Represented
  19 --   as expression ASTs.
  20 -- * pattern_seq: might match a term_seq
  21 -- * pattern_group: several pattern seqs, one of them might match
  22 --                  the term seq.
  23 -- * case: pattern_group * guard option * block
  24 -- * match_statement: tested term_seq * case list
  25 --
  26 -- Hence a complete match statement is a:
  27 --
  28 -- { list(expr),  list{ list(list(expr)), expr or false, block } }
  29 --
  30 -- Implementation hints
  31 -- ====================
  32 --
  33 -- The implementation is made as modular as possible, so that parts
  34 -- can be reused in other extensions. The priviledged way to share
  35 -- contextual information across functions is through the 'cfg' table
  36 -- argument. Its fields include:
  37 --
  38 -- * code: code generated from pattern. A pattern_(element|seq|group)
  39 --   is compiled as a sequence of instructions which will jump to
  40 --   label [cfg.on_failure] if the tested term doesn't match.
  41 --
  42 -- * on_failure: name of the label where the code will jump if the
  43 --   pattern doesn't match
  44 --
  45 -- * locals: names of local variables used by the pattern. This
  46 --   includes bound variables, and temporary variables used to
  47 --   destructure tables. Names are stored as keys of the table,
  48 --   values are meaningless.
  49 --
  50 -- * after_success: label where the code must jump after a pattern
  51 --   succeeded to capture a term, and the guard suceeded if there is
  52 --   any, and the conditional block has run.
  53 --
  54 -- * ntmp: number of temporary variables used to destructurate table
  55 --   in the current case.
  56 --
  57 -- Code generation is performed by acc_xxx() functions, which accumulate
  58 -- code in cfg.code:
  59 --
  60 -- * acc_test(test, cfg) will generate a jump to cfg.on_failure
  61 --   *when the test returns TRUE*
  62 --
  63 -- * acc_stat accumulates a statement
  64 --
  65 -- * acc_assign accumulate an assignment statement, and makes sure that
  66 --   the LHS variable the registered as local in cfg.locals.
  67 --
  68 ----------------------------------------------------------------------
  69
  70 -- TODO: hygiene wrt type()
  71 -- TODO: cfg.ntmp isn't reset as often as it could. I'm not even sure
  72 --       the corresponding locals are declared.
  73
  74 module ('spmatch', package.seeall)
  75
  76 ----------------------------------------------------------------------
  77 -- This would have been best done through library 'metalua.walk',
  78 -- but walk depends on match, so we have to break the dependency.
  79 -- It replaces all instances of `...' in `ast' with `term', unless
  80 -- it appears in a function.
  81 ----------------------------------------------------------------------
  82 function replace_dots (ast, term)
  83    local function rec (x)
  84       if type(x) == 'table' then
  85          if x.tag=='Dots' then
  86             if term=='ambiguous' then
  87                error ("You can't use `...' on the right of a match case when it appears "..
  88                       "more than once on the left")
  89             else
  90                x <- term
  91             end
  92          elseif x.tag=='Function' then return
  93          else for y in ivalues (x) do rec (y) end end
  94       end
  95    end
  96    return rec (ast)
  97 end
  98
  99 tmpvar_base = mlp.gensym 'submatch.' [1]
 100 function next_tmpvar(cfg)
 101    assert (cfg.ntmp, "No cfg.ntmp imbrication level in the match compiler")
 102    cfg.ntmp = cfg.ntmp+1
 103    return `Id{ tmpvar_base .. cfg.ntmp }
 104 end
 105
 106 -- Code accumulators
 107 acc_stat = |x,cfg| table.insert (cfg.code, x)
 108 acc_test = |x,cfg| acc_stat(+{stat: if -{x} then -{`Goto{cfg.on_failure}} end}, cfg)
 109 -- lhs :: `Id{ string }
 110 -- rhs :: expr
 111 function acc_assign (lhs, rhs, cfg)
 112    assert(lhs.tag=='Id')
 113    cfg.locals[lhs[1]] = true
 114    acc_stat (`Set{ {lhs}, {rhs} }, cfg)
 115 end
 116
 117 literal_tags = table.transpose{ 'String', 'Number', 'True', 'False', 'Nil' }
 118
 119 -- pattern :: `Id{ string }
 120 -- term    :: expr
 121 function id_pattern_element_builder (pattern, term, cfg)
 122    assert (pattern.tag == "Id")
 123    if pattern[1] == "_" then
 124       -- "_" is used as a dummy var ==> no assignment, no == checking
 125       cfg.locals._ = true
 126    elseif cfg.locals[pattern[1]] then
 127       -- This var is already bound ==> test for equality
 128       acc_test (+{ -{term} ~= -{pattern} }, cfg)
 129    else
 130       -- Free var ==> bind it, and remember it for latter linearity checking
 131       acc_assign (pattern, term, cfg)
 132       cfg.locals[pattern[1]] = true
 133    end
 134 end
 135
 136 -- Concatenate code in [cfg.code], that will jump to label
 137 -- [cfg.on_failure] if [pattern] doesn't match [term]. [pattern]
 138 -- should be an identifier, or at least cheap to compute and
 139 -- side-effects free.
 140 --
 141 -- pattern :: pattern_element
 142 -- term    :: expr
 143 function pattern_element_builder (pattern, term, cfg)
 144    if literal_tags[pattern.tag] then
 145       acc_test (+{ -{term} ~= -{pattern} }, cfg)
 146    elseif "Id" == pattern.tag then
 147       id_pattern_element_builder (pattern, term, cfg)
 148    elseif "Op" == pattern.tag and "div" == pattern[1] then
 149       regexp_pattern_element_builder (pattern, term, cfg)
 150    elseif "Op" == pattern.tag and "eq" == pattern[1] then
 151       eq_pattern_element_builder (pattern, term, cfg)
 152    elseif "Table" == pattern.tag then
 153       table_pattern_element_builder (pattern, term, cfg)
 154    else
 155       error ("Invalid pattern: "..table.tostring(pattern, "nohash"))
 156    end
 157 end
 158
 159 function eq_pattern_element_builder (pattern, term, cfg)
 160    local _, pat1, pat2 = unpack (pattern)
 161    local ntmp_save = cfg.ntmp
 162    pattern_element_builder (pat1, term, cfg)
 163    cfg.ntmp = ntmp_save
 164    pattern_element_builder (pat2, term, cfg)
 165 end
 166
 167 -- pattern :: `Op{ 'div', string, list{`Id string} or `Id{ string }}
 168 -- term    :: expr
 169 function regexp_pattern_element_builder (pattern, term, cfg)
 170    local op, regexp, sub_pattern = unpack(pattern)
 171
 172    -- Sanity checks --
 173    assert (op=='div', "Don't know what to do with that op in a pattern")
 174    assert (regexp.tag=="String",
 175            "Left hand side operand for '/' in a pattern must be "..
 176            "a literal string representing a regular expression")
 177    if sub_pattern.tag=="Table" then
 178       for x in ivalues(sub_pattern) do
 179          assert (x.tag=="Id" or x.tag=='Dots',
 180                  "Right hand side operand for '/' in a pattern must be "..
 181                  "a list of identifiers")
 182       end
 183    else
 184       assert (sub_pattern.tag=="Id",
 185               "Right hand side operand for '/' in a pattern must be "..
 186               "an identifier or a list of identifiers")
 187    end
 188
 189    -- Regexp patterns can only match strings
 190    acc_test (+{ type(-{term}) ~= 'string' }, cfg)
 191    -- put all captures in a list
 192    local capt_list  = +{ { string.strmatch(-{term}, -{regexp}) } }
 193    -- save them in a var_n for recursive decomposition
 194    local v2 = next_tmpvar(cfg)
 195    acc_stat (+{stat: local -{v2} = -{capt_list} }, cfg)
 196    -- was capture successful?
 197    acc_test (+{ not next (-{v2}) }, cfg)
 198    pattern_element_builder (sub_pattern, v2, cfg)
 199 end
 200
 201 -- pattern :: pattern and `Table{ }
 202 -- term    :: expr
 203 function table_pattern_element_builder (pattern, term, cfg)
 204    local seen_dots, len = false, 0
 205    acc_test (+{ type( -{term} ) ~= "table" }, cfg)
 206    for i = 1, #pattern do
 207       local key, sub_pattern
 208       if pattern[i].tag=="Pair" then -- Explicit key/value pair
 209          key, sub_pattern = unpack (pattern[i])
 210          assert (literal_tags[key.tag], "Invalid key")
 211       else -- Implicit key
 212          len, key, sub_pattern = len+1, `Number{ len+1 }, pattern[i]
 213       end
 214
 215       -- '...' can only appear in final position
 216       -- Could be fixed actually...
 217       assert (not seen_dots, "Wrongly placed `...' ")
 218
 219       if sub_pattern.tag == "Id" then
 220          -- Optimization: save a useless [ v(n+1)=v(n).key ]
 221          id_pattern_element_builder (sub_pattern, `Index{ term, key }, cfg)
 222          if sub_pattern[1] ~= "_" then
 223             acc_test (+{ -{sub_pattern} == nil }, cfg)
 224          end
 225       elseif sub_pattern.tag == "Dots" then
 226          -- Remember where the capture is, and thatt arity checking shouldn't occur
 227          seen_dots = true
 228       else
 229          -- Business as usual:
 230          local v2 = next_tmpvar(cfg)
 231          acc_assign (v2, `Index{ term, key }, cfg)
 232          pattern_element_builder (sub_pattern, v2, cfg)
 233          -- TODO: restore ntmp?
 234       end
 235    end
 236    if seen_dots then -- remember how to retrieve `...'
 237       -- FIXME: check, but there might be cases where the variable -{term}
 238       -- will be overridden in contrieved tables.
 239       -- ==> save it now, and clean the setting statement if unused
 240       if cfg.dots_replacement then cfg.dots_replacement = 'ambiguous'
 241       else cfg.dots_replacement = +{ select (-{`Number{len}}, unpack(-{term})) } end
 242    else -- Check arity
 243       acc_test (+{ #-{term} ~= -{`Number{len}} }, cfg)
 244    end
 245 end
 246
 247 -- Jumps to [cfg.on_faliure] if pattern_seq doesn't match
 248 -- term_seq.
 249 function pattern_seq_builder (pattern_seq, term_seq, cfg)
 250    if #pattern_seq ~= #term_seq then error ("Bad seq arity") end
 251    cfg.locals = { } -- reset bound variables between alternatives
 252    for i=1, #pattern_seq do
 253       cfg.ntmp = 1 -- reset the tmp var generator
 254       pattern_element_builder(pattern_seq[i], term_seq[i], cfg)
 255    end
 256 end
 257
 258 --------------------------------------------------
 259 -- for each case i:
 260 --   pattern_seq_builder_i:
 261 --    * on failure, go to on_failure_i
 262 --    * on success, go to on_success
 263 --   label on_success:
 264 --   block
 265 --   goto after_success
 266 --   label on_failure_i
 267 --------------------------------------------------
 268 function case_builder (case, term_seq, cfg)
 269    local patterns_group, guard, block = unpack(case)
 270    local on_success = mlp.gensym 'on_success' [1]
 271    for i = 1, #patterns_group do
 272       local pattern_seq = patterns_group[i]
 273       cfg.on_failure = mlp.gensym 'match_fail' [1]
 274       cfg.dots_replacement = false
 275       pattern_seq_builder (pattern_seq, term_seq, cfg)
 276       if i<#patterns_group then
 277          acc_stat (`Goto{on_success}, cfg)
 278          acc_stat (`Label{cfg.on_failure}, cfg)
 279       end
 280    end
 281    acc_stat (`Label{on_success}, cfg)
 282    if guard then acc_test (+{not -{guard}}, cfg) end
 283    if cfg.dots_replacement then
 284       replace_dots (block, cfg.dots_replacement)
 285    end
 286    block.tag = 'Do'
 287    acc_stat (block, cfg)
 288    acc_stat (`Goto{cfg.after_success}, cfg)
 289    acc_stat (`Label{cfg.on_failure}, cfg)
 290 end
 291
 292 function match_builder (x)
 293    local term_seq, cases = unpack(x)
 294    local cfg = {
 295       code          = `Do{ },
 296       after_success = mlp.gensym "_after_success" }
 297
 298
 299    -- Some sharing issues occur when modifying term_seq,
 300    -- so it's replaced by a copy new_term_seq.
 301    -- TODO: clean that up, and re-suppress the useless copies
 302    -- (cf. remarks about capture bug below).
 303    local new_term_seq = { }
 304
 305    local match_locals
 306
 307    -- Make sure that all tested terms are variables or literals
 308    for i=1, #term_seq do
 309       local t = term_seq[i]
 310       -- Capture problem: the following would compile wrongly:
 311       --    `match x with x -> end'
 312       -- Temporary workaround: suppress the condition, so that
 313       -- all external variables are copied into unique names.
 314       --if t.tag ~= 'Id' and not literal_tags[t.tag] then
 315          local v = mlp.gensym 'v'
 316          if not match_locals then match_locals = `Local{ {v}, {t} } else
 317             table.insert(match_locals[1], v)
 318             table.insert(match_locals[2], t)
 319          end
 320          new_term_seq[i] = v
 321       --end
 322    end
 323    term_seq = new_term_seq
 324
 325    if match_locals then acc_stat(match_locals, cfg) end
 326
 327    for i=1, #cases do
 328       local case_cfg = {
 329          after_success    = cfg.after_success,
 330          code             = `Do{ }
 331          -- locals    = { } -- unnecessary, done by pattern_seq_builder
 332       }
 333       case_builder (cases[i], term_seq, case_cfg)
 334       if next (case_cfg.locals) then
 335          local case_locals = { }
 336          table.insert (case_cfg.code, 1, `Local{ case_locals, { } })
 337          for v in keys (case_cfg.locals) do
 338             table.insert (case_locals, `Id{ v })
 339          end
 340       end
 341       acc_stat(case_cfg.code, cfg)
 342    end
 343    acc_stat(+{error 'mismatch'}, cfg)
 344    acc_stat(`Label{cfg.after_success}, cfg)
 345    return cfg.code
 346 end
 347
 348 ----------------------------------------------------------------------
 349 -- Syntactical front-end
 350 ----------------------------------------------------------------------
 351
 352 mlp.lexer:add{ "match", "with", "->" }
 353 mlp.block.terminators:add "|"
 354
 355 match_cases_list_parser = gg.list{ name = "match cases list",
 356    gg.sequence{ name = "match case",
 357       gg.list{ name  = "match case patterns list",
 358          primary     = mlp.expr_list,
 359          separators  = "|",
 360          terminators = { "->", "if" } },
 361       gg.onkeyword{ "if", mlp.expr, consume = true },
 362       "->",
 363       mlp.block },
 364    separators  = "|",
 365    terminators = "end" }
 366
 367 mlp.stat:add{ name = "match statement",
 368    "match",
 369    mlp.expr_list,
 370    "with", gg.optkeyword "|",
 371    match_cases_list_parser,
 372    "end",
 373    builder = |x| match_builder{ x[1], x[3] } }
 374