-------------------------------------------------------------------------------
-- Copyright (c) 2006-2013 Fabien Fleutot and others.
--
-- All rights reserved.
--
-- This program and the accompanying materials are made available
-- under the terms of the Eclipse Public License v1.0 which
-- accompanies this distribution, and is available at
-- http://www.eclipse.org/legal/epl-v10.html
--
-- This program and the accompanying materials are also made available
-- under the terms of the MIT public license which accompanies this
-- distribution, and is available at http://www.lua.org/license.html
--
-- Contributors:
--     Fabien Fleutot - API and implementation
--
-------------------------------------------------------------------------------

require 'metalua.extension.match'

module ('spmatch', package.seeall)

require 'metalua.walk.id'

-{extension 'log'}

----------------------------------------------------------------------
-- Back-end for statements
-- "match function ..." and "local match function...".
-- Tag must be either "Localrec" or "Set".
----------------------------------------------------------------------
named_match_function_builder = |tag| function (x)
   local func_name, _, cases = unpack(x)
   local arity = #cases[1][1][1]
   if arity==0 then
      error "There must be at least 1 case in match function"
   end
   local args = { }
   for i=1, arity do args[i] = mlp.gensym("arg."..i) end
   local body = match_builder{args, cases}
   return { tag=tag, {func_name}, { `Function{ args, {body} } } }
end

-- Get rid of the former parser, it will be blended in a multiseq:
mlp.stat:del 'match'

----------------------------------------------------------------------
-- "match function", "match ... with"
----------------------------------------------------------------------
mlp.stat:add{ 'match',
   gg.multisequence{

      ----------------------------------------------------------------
      -- Shortcut for declaration of functions containing only a match:
      -- "function f($1) match $1 with $2 end end" can be written:
      -- "match function f $2 end"
      ----------------------------------------------------------------
      { 'function', mlp.expr, gg.optkeyword '|',
         match_cases_list_parser, 'end',
         builder = named_match_function_builder 'Set' },

      ----------------------------------------------------------------
      -- Reintroduce the original match statement:
      ----------------------------------------------------------------
      default = gg.sequence{
         mlp.expr_list, 'with', gg.optkeyword '|',
         match_cases_list_parser, 'end',
         builder = |x| match_builder{ x[1], x[3] } } } }

----------------------------------------------------------------------
-- Shortcut: "local match function f $cases end" translates to:
-- "local function f($args) match $args with $cases end end"
----------------------------------------------------------------------
mlp.stat:get'local'[2]:add{
   'match', 'function', mlp.expr, gg.optkeyword '|',
   match_cases_list_parser, 'end',
   builder = named_match_function_builder 'Localrec' }

----------------------------------------------------------------------
-- "match...with" expressions and "match function..."
----------------------------------------------------------------------
mlp.expr:add{ 'match', builder = |x| x[1], gg.multisequence{

      ----------------------------------------------------------------
      -- Anonymous match functions:
      -- "function ($1) match $1 with $2 end end" can be written:
      -- "match function $2 end"
      ----------------------------------------------------------------
      { 'function', gg.optkeyword '|',
         match_cases_list_parser,
         'end',
         builder = function(x)
            local _, cases = unpack(x)
            local v        = mlp.gensym()
            local body     = match_builder{v, cases}
            return `Function{ {v}, {body} }
         end },

      ----------------------------------------------------------------
      -- match expressions: you can put a match where an expression
      -- is expected. The case bodies are then expected to be
      -- expressions, not blocks.
      ----------------------------------------------------------------
      default = gg.sequence{
         mlp.expr_list, 'with', gg.optkeyword '|',
         gg.list{  name = "match cases list",
            gg.sequence{ name = "match expr case",
               gg.list{ name  = "match expr case patterns list",
                  primary     = mlp.expr_list,
                  separators  = "|",
                  terminators = { "->", "if" } },
               gg.onkeyword{ "if", mlp.expr, consume = true },
               "->",
               mlp.expr }, -- Notice: expression, not block!
            separators  = "|" },
         -- Notice: no "end" keyword!
         builder = function (x)
            local tested_term_seq, _, cases = unpack(x)
            local v = mlp.gensym 'match_expr'
            -- Replace expressions with blocks
            for case in ivalues (cases) do
               local body = case[3]
               case[3] = { `Set{ {v}, {body} } }
            end
            local m = match_builder { tested_term_seq, cases }
            return `Stat{ { `Local{{v}}; m }, v }
         end } } }

function bind (x)
   local patterns, values = unpack(x)

   -------------------------------------------------------------------
   -- Generate pattern code: "bind vars = vals" translates to:
   -- do
   --   pattern matching code, goto 'fail' on mismatch
   --   goto 'success'
   --   label 'fail': error "..."
   --   label success
   -- end
   -- vars is the set of variables used by the pattern
   -------------------------------------------------------------------
   local code, vars do
      local match_cfg = {
         on_failure = mlp.gensym 'mismatch' [1],
         locals = { },
         code = { } }
      pattern_seq_builder(patterns, values, match_cfg)
      local on_success = mlp.gensym 'on_success' [1]
      code = {
         match_cfg.code;
         `Goto{ on_success };
         `Label{ match_cfg.on_failure };
         +{error "bind error"};
         `Label{ on_success } }
      vars = match_cfg.locals
   end

   -------------------------------------------------------------------
   -- variables that actually appear in the pattern:
   -------------------------------------------------------------------
   local vars_in_pattern do
      vars_in_pattern = { }
      local walk_cfg = { id = { } }
      function walk_cfg.id.free(v) vars_in_pattern[v[1]]=true end
      walk_id.expr_list(walk_cfg, patterns)
   end

   -------------------------------------------------------------------
   -- temp variables that are generated for destructuring,
   -- but aren't explicitly typed by the user. These must be made
   -- local.
   -------------------------------------------------------------------
   local vars_not_in_pattern do
      vars_not_in_pattern = { }
      for k in keys(vars) do
         if not vars_in_pattern[k] then
            vars_not_in_pattern[k] = true
         end
      end
   end

   -------------------------------------------------------------------
   -- Declare the temp variables as local to the statement.
   -------------------------------------------------------------------
   if next(vars_not_in_pattern) then
      local loc = { }
      for k in keys (vars_not_in_pattern) do
         table.insert (loc, `Id{k})
      end
      table.insert (code, 1, `Local{ loc, { } })
   end

   -------------------------------------------------------------------
   -- Transform the set of pattern variable names into a list of `Id{}
   -------------------------------------------------------------------
   local decl_list do
      decl_list = { }
      for k in keys (vars_in_pattern) do
         table.insert (decl_list, `Id{k})
      end
   end

   return code, decl_list
end

function local_bind(x)
   local code, vars = bind (x)
   return { `Local{ vars, { } }; code }
end

function non_local_bind(x)
   local code, _ = bind (x)
   code.tag = 'Do'
   return code
end

----------------------------------------------------------------------
-- Syntax front-end
----------------------------------------------------------------------
mlp.lexer:add 'bind'

----------------------------------------------------------------------
-- bind patterns = vars
----------------------------------------------------------------------
mlp.stat:add{ 'bind', mlp.expr_list, '=', mlp.expr_list,
   builder = non_local_bind }

----------------------------------------------------------------------
-- local bind patterns = vars
-- Some monkey-patching of "local ..." must take place
----------------------------------------------------------------------
mlp.stat:get'local'[2]:add{ 'bind', mlp.expr_list, '=', mlp.expr_list,
   builder = local_bind }