~technomancy/shevek

34fcfc4485d1d5a249415f2c0f58bbfd9febaac2 — Phil Hagelberg 1 year, 8 months ago
Initial commit.
6 files changed, 2725 insertions(+), 0 deletions(-)

A LICENSE
A bencode.lua
A fennel
A fennel.lua
A readme.md
A shevek.fnl
A  => LICENSE +165 -0
@@ 1,165 @@
                   GNU LESSER GENERAL PUBLIC LICENSE
                       Version 3, 29 June 2007

 Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.


  This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.

  0. Additional Definitions.

  As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.

  "The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.

  An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.

  A "Combined Work" is a work produced by combining or linking an
Application with the Library.  The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".

  The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.

  The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.

  1. Exception to Section 3 of the GNU GPL.

  You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.

  2. Conveying Modified Versions.

  If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:

   a) under this License, provided that you make a good faith effort to
   ensure that, in the event an Application does not supply the
   function or data, the facility still operates, and performs
   whatever part of its purpose remains meaningful, or

   b) under the GNU GPL, with none of the additional permissions of
   this License applicable to that copy.

  3. Object Code Incorporating Material from Library Header Files.

  The object code form of an Application may incorporate material from
a header file that is part of the Library.  You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:

   a) Give prominent notice with each copy of the object code that the
   Library is used in it and that the Library and its use are
   covered by this License.

   b) Accompany the object code with a copy of the GNU GPL and this license
   document.

  4. Combined Works.

  You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:

   a) Give prominent notice with each copy of the Combined Work that
   the Library is used in it and that the Library and its use are
   covered by this License.

   b) Accompany the Combined Work with a copy of the GNU GPL and this license
   document.

   c) For a Combined Work that displays copyright notices during
   execution, include the copyright notice for the Library among
   these notices, as well as a reference directing the user to the
   copies of the GNU GPL and this license document.

   d) Do one of the following:

       0) Convey the Minimal Corresponding Source under the terms of this
       License, and the Corresponding Application Code in a form
       suitable for, and under terms that permit, the user to
       recombine or relink the Application with a modified version of
       the Linked Version to produce a modified Combined Work, in the
       manner specified by section 6 of the GNU GPL for conveying
       Corresponding Source.

       1) Use a suitable shared library mechanism for linking with the
       Library.  A suitable mechanism is one that (a) uses at run time
       a copy of the Library already present on the user's computer
       system, and (b) will operate properly with a modified version
       of the Library that is interface-compatible with the Linked
       Version.

   e) Provide Installation Information, but only if you would otherwise
   be required to provide such information under section 6 of the
   GNU GPL, and only to the extent that such information is
   necessary to install and execute a modified version of the
   Combined Work produced by recombining or relinking the
   Application with a modified version of the Linked Version. (If
   you use option 4d0, the Installation Information must accompany
   the Minimal Corresponding Source and Corresponding Application
   Code. If you use option 4d1, you must provide the Installation
   Information in the manner specified by section 6 of the GNU GPL
   for conveying Corresponding Source.)

  5. Combined Libraries.

  You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:

   a) Accompany the combined library with a copy of the same work based
   on the Library, uncombined with any other library facilities,
   conveyed under the terms of this License.

   b) Give prominent notice with the combined library that part of it
   is a work based on the Library, and explaining where to find the
   accompanying uncombined form of the same work.

  6. Revised Versions of the GNU Lesser General Public License.

  The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.

  Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.

  If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

A  => bencode.lua +97 -0
@@ 1,97 @@
-- needed for nrepl client
local encode, decode

local function decode_list(str, t, total_len)
   -- print("  list", str, lume.serialize(t))
   if(str:sub(1,1) == "e") then return t, total_len + 1 end
   local value, v_len = decode(str)
   if(not value) then return value, v_len end
   table.insert(t, value)
   total_len = total_len + v_len
   return decode_list(str:sub(v_len + 1), t, total_len)
end

local function decode_table(str, t, total_len)
   -- print("  table", str, lume.serialize(t))
   if(str:sub(1,1) == "e") then return t, total_len + 1 end
   local key, k_len = decode(str)
   if(not key) then return key, k_len end
   local value, v_len = decode(str:sub(k_len+1))
   if(not value) then return value, v_len end
   local end_pos = 1 + k_len + v_len
   t[key] = value
   total_len = total_len + k_len + v_len
   return decode_table(str:sub(end_pos), t, total_len)
end

function decode(str)
   -- print("decoding", str)
   if(str:sub(1,1) == "l") then
      return decode_list(str:sub(2), {}, 1)
   elseif(str:sub(1,1) == "d") then
      return decode_table(str:sub(2), {}, 1)
   elseif(str:sub(1,1) == "i") then
      -- print("  number", tonumber(str:sub(2, str:find("e") - 1)))
      return(tonumber(str:sub(2, str:find("e") - 1))), str:find("e")
   elseif(str:match("[0-9]+")) then
      local num_str = str:match("[0-9]+")
      local beginning_of_string = #num_str + 2
      local str_len = tonumber(num_str)
      local total_len = beginning_of_string + str_len - 1
      -- print("  string", str:sub(beginning_of_string))
      return str:sub(beginning_of_string, total_len), total_len
   else
      return false, "Could not parse "..str
   end
end

local function decode_all(str, already)
   local decoded, len_or_err = decode(str)
   if(not decoded) then return decoded, len_or_err, already end
   already = already or {}
   table.insert(already, decoded)
   if(decoded and #str == len_or_err) then
      return already
   elseif(decoded) then
      return decode_all(str:sub(len_or_err + 1), already)
   else
      return false, len_or_err
   end
end

local function encode_str(s) return #s .. ":" .. s end
local function encode_int(n) return "i" .. tostring(n) .. "e" end

local function encode_table(t)
   local s = "d"
   for k,v in pairs(t) do s = s .. encode(k) .. encode(v) end
   return s .. "e"
end

local function encode_list(l)
   local s = "l"
   for _,x in ipairs(l) do s = s .. encode(x) end
   return s .. "e"
end

local function count(tbl)
   local i = 0
   for _ in pairs(tbl) do i = i + 1 end
   return i
end

function encode(x)
   if(type(x) == "table" and select("#", unpack(x)) == count(x)) then
      return encode_list(x)
   elseif(type(x) == "table") then
      return encode_table(x)
   elseif(type(x) == "number" and math.floor(x) == x) then
      return encode_int(x)
   elseif(type(x) == "string") then
      return encode_str(x)
   else
      return false, "Could not encode " .. type(x) .. ": " .. tostring(x)
   end
end

return {decode=decode, decode_all=decode_all, encode=encode}

A  => fennel +133 -0
@@ 1,133 @@
#!/usr/bin/env lua

local fennel_dir = arg[0]:match("(.-)[^\\/]+$")
package.path = fennel_dir .. "?.lua;" .. package.path
local fennel = require('fennel')
local unpack = unpack or table.unpack

local help = [[
Usage: fennel [FLAG] [FILE]

Run fennel, a lisp programming language for the Lua runtime.

  --repl                  : Launch an interactive repl session
  --compile FILES         : Compile files and write their Lua to stdout

  --no-searcher           : Skip installing package.searchers entry
  --indent VAL            : Indent compiler output with VAL
  --add-package-path PATH : Add PATH to package.path for finding Lua modules
  --add-fennel-path  PATH : Add PATH to fennel.path for finding Fennel modules

  --help                  : Display this text
  --version               : Show version

  When not given a flag, runs the file given as the first argument.
  When given neither flag nor file, launches a repl.

  If ~/.fennelrc exists, loads it before launching a repl.]]

local options = {
    sourcemap = true
}

local function dosafe(filename, opts, args)
    local ok, val = xpcall(function()
        return fennel.dofile(filename, opts, unpack(args))
    end, fennel.traceback)
    if not ok then
        io.stderr:write(val .. "\n")
        os.exit(1)
    end
    return val
end

for i=#arg, 1, -1 do
    if arg[i] == "--no-searcher" then
        options.no_searcher = true
        table.remove(arg, i)
    elseif arg[i] == "--indent" then
        options.indent = table.remove(arg, i+1)
        if options.indent == "false" then options.indent = false end
        table.remove(arg, i)
    elseif arg[i] == "--add-package-path" then
        local entry = table.remove(arg, i+1)
        package.path = entry .. ";" .. package.path
        table.remove(arg, i)
    elseif arg[i] == "--add-fennel-path" then
        local entry = table.remove(arg, i+1)
        fennel.path = entry .. ";" .. fennel.path
        table.remove(arg, i)
    elseif arg[i] == "--sourcemap" then
        options.sourcemap = table.remove(arg, i+1)
        if options.sourcemap == "false" then options.sourcemap = false end
        table.remove(arg, i)
    end
end

if not options.no_searcher then
    table.insert((package.loaders or package.searchers),
        fennel.make_searcher({correlate = true}))
end

-- Try to load readline library
local function tryReadline(opts)
    local ok, readline = pcall(require, "readline")
    if ok then
        readline.set_options({
            keeplines = 1000
        })
        function opts.readChunk(parserState)
            local prompt = parserState.stackSize > 0 and '.. ' or '>> '
            local str = readline.readline(prompt)
            if str then
                return str .. "\n"
            end
        end
    end
end

if arg[1] == "--repl" or #arg == 0 then
    local ppok, pp = pcall(fennel.dofile, fennel_dir .. "fennelview.fnl", options)
    if ppok then
        options.pp = pp
    else
        ppok, pp = pcall(require, "fennelview")
        if ppok then
            options.pp = pp
        end
    end
    local initFilename = (os.getenv("HOME") or "") .. "/.fennelrc"
    local init = io.open(initFilename, "rb")

    tryReadline(options)

    if init then
        init:close()
        -- pass in options so fennerlrc can make changes to it
        dosafe(initFilename, options, options)
    end
    print("Welcome to fennel!")
    fennel.repl(options)
elseif arg[1] == "--compile" then
    for i = 2, #arg do
        local f = arg[i] == "-" and io.stdin or assert(io.open(arg[i], "rb"))
        options.filename=arg[i]
        local ok, val = xpcall(function()
            return fennel.compileString(f:read("*all"), options)
        end, fennel.traceback)
        if ok then
            print(val)
        else
            io.stderr:write(val .. "\n")
            os.exit(1)
        end
        f:close()
    end
elseif arg[1] == "--version" or arg[1] == "-v" then
    print("Fennel " .. fennel.version)
elseif #arg >= 1 and arg[1] ~= "--help" then
    local filename = table.remove(arg, 1) -- let the script have remaining args
    dosafe(filename, nil, arg)
else
    print(help)
end

A  => fennel.lua +2229 -0
@@ 1,2229 @@
--[[
Copyright (c) 2016-2018 Calvin Rose and contributors
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
]]

-- Make global variables local.
local setmetatable = setmetatable
local getmetatable = getmetatable
local type = type
local assert = assert
local pairs = pairs
local ipairs = ipairs
local tostring = tostring
local unpack = unpack or table.unpack

--
-- Main Types and support functions
--

local function deref(self) return self[1] end

local SYMBOL_MT = { 'SYMBOL', __tostring = deref }
local EXPR_MT = { 'EXPR', __tostring = deref }
local VARARG = setmetatable({ '...' }, { 'VARARG', __tostring = deref })
local LIST_MT = { 'LIST',
    __tostring = function (self)
        local strs = {}
        for _, s in ipairs(self) do
            table.insert(strs, tostring(s))
        end
        return '(' .. table.concat(strs, ', ', 1, #self) .. ')'
    end
}

-- Load code with an environment in all recent Lua versions
local function loadCode(code, environment, filename)
    environment = environment or _ENV or _G
    if setfenv and loadstring then
        local f = assert(loadstring(code, filename))
        setfenv(f, environment)
        return f
    else
        return assert(load(code, filename, "t", environment))
    end
end

-- Create a new list
local function list(...)
    return setmetatable({...}, LIST_MT)
end

-- Create a new symbol
local function sym(str, scope, meta)
    local s = {str, scope = scope}
    if meta then
        for k, v in pairs(meta) do
            if type(k) == 'string' then s[k] = v end
        end
    end
    return setmetatable(s, SYMBOL_MT)
end

-- Create a new expr
-- etype should be one of
--   "literal", -- literals like numbers, strings, nil, true, false
--   "expression", -- Complex strings of Lua code, may have side effects, etc, but is an expression
--   "statement", -- Same as expression, but is also a valid statement (function calls).
--   "vargs", -- varargs symbol
--   "sym", -- symbol reference
local function expr(strcode, etype)
    return setmetatable({ strcode, type = etype }, EXPR_MT)
end

local function varg()
    return VARARG
end

local function isVarg(x)
    return x == VARARG and x
end

-- Checks if an object is a List. Returns the object if is a List.
local function isList(x)
    return type(x) == 'table' and getmetatable(x) == LIST_MT and x
end

-- Checks if an object is a symbol. Returns the object if it is a symbol.
local function isSym(x)
    return type(x) == 'table' and getmetatable(x) == SYMBOL_MT and x
end

-- Checks if an object any kind of table, EXCEPT list or symbol
local function isTable(x)
    return type(x) == 'table' and
        x ~= VARARG and
        getmetatable(x) ~= LIST_MT and getmetatable(x) ~= SYMBOL_MT and x
end

--
-- Parser
--

-- Convert a stream of chunks to a stream of bytes.
-- Also returns a second function to clear the buffer in the byte stream
local function granulate(getchunk)
    local c = ''
    local index = 1
    local done = false
    return function (parserState)
        if done then return nil end
        if index <= #c then
            local b = c:byte(index)
            index = index + 1
            return b
        else
            c = getchunk(parserState)
            if not c or c == '' then
                done = true
                return nil
            end
            index = 2
            return c:byte(1)
        end
    end, function ()
        c = ''
    end
end

-- Convert a string into a stream of bytes
local function stringStream(str)
    local index = 1
    return function()
        local r = str:byte(index)
        index = index + 1
        return r
    end
end

-- Table of delimiter bytes - (, ), [, ], {, }
-- Opener keys have closer as the value, and closers keys
-- have true as their value.
local delims = {
    [40] = 41,        -- (
    [41] = true,      -- )
    [91] = 93,        -- [
    [93] = true,      -- ]
    [123] = 125,      -- {
    [125] = true      -- }
}

local function iswhitespace(b)
    return b == 32 or (b >= 9 and b <= 13) or b == 44
end

local function issymbolchar(b)
    return b > 32 and
        not delims[b] and
        b ~= 127 and -- "<BS>"
        b ~= 34 and -- "\""
        b ~= 39 and -- "'"
        b ~= 59 and -- ";"
        b ~= 44 and -- ","
        b ~= 96 -- "`"
end

local prefixes = { -- prefix chars substituted while reading
    [96] = 'quote', -- `
    [64] = 'unquote' -- @
}

-- Parse one value given a function that
-- returns sequential bytes. Will throw an error as soon
-- as possible without getting more bytes on bad input. Returns
-- if a value was read, and then the value read. Will return nil
-- when input stream is finished.
local function parser(getbyte, filename)

    -- Stack of unfinished values
    local stack = {}

    -- Provide one character buffer and keep
    -- track of current line and byte index
    local line = 1
    local byteindex = 0
    local lastb
    local function ungetb(ub)
        if ub == 10 then line = line - 1 end
        byteindex = byteindex - 1
        lastb = ub
    end
    local function getb()
        local r
        if lastb then
            r, lastb = lastb, nil
        else
            r = getbyte({ stackSize = #stack })
        end
        byteindex = byteindex + 1
        if r == 10 then line = line + 1 end
        return r
    end
    local function parseError(msg)
        return error(msg .. ' in ' .. (filename or 'unknown') .. ':' .. line, 0)
    end

    -- Parse stream
    return function()

        -- Dispatch when we complete a value
        local done, retval
        local function dispatch(v)
            if #stack == 0 then
                retval = v
                done = true
            elseif stack[#stack].prefix then
                local stacktop = stack[#stack]
                stack[#stack] = nil
                return dispatch(list(sym(stacktop.prefix), v))
            else
                table.insert(stack[#stack], v)
            end
        end

        -- The main parse loop
        repeat
            local b

            -- Skip whitespace
            repeat
                b = getb()
            until not b or not iswhitespace(b)
            if not b then
                if #stack > 0 then parseError 'unexpected end of source' end
                return nil
            end

            if b == 59 then -- ; Comment
                repeat
                    b = getb()
                until not b or b == 10 -- newline
            elseif type(delims[b]) == 'number' then -- Opening delimiter
                table.insert(stack, setmetatable({
                    closer = delims[b],
                    line = line,
                    filename = filename,
                    bytestart = byteindex
                }, LIST_MT))
            elseif delims[b] then -- Closing delimiter
                if #stack == 0 then parseError 'unexpected closing delimiter' end
                local last = stack[#stack]
                local val
                if last.closer ~= b then
                    parseError('unexpected delimiter ' .. string.char(b) ..
                               ', expected ' .. string.char(last.closer))
                end
                last.byteend = byteindex -- Set closing byte index
                if b == 41 then -- )
                    val = last
                elseif b == 93 then -- ]
                    val = {}
                    for i = 1, #last do
                        val[i] = last[i]
                    end
                else -- }
                    if #last % 2 ~= 0 then
                        parseError('expected even number of values in table literal')
                    end
                    val = {}
                    for i = 1, #last, 2 do
                        val[last[i]] = last[i + 1]
                    end
                end
                stack[#stack] = nil
                dispatch(val)
            elseif b == 34 or b == 39 then -- Quoted string
                local start = b
                local state = "base"
                local chars = {start}
                repeat
                    b = getb()
                    chars[#chars + 1] = b
                    if state == "base" then
                        if b == 92 then
                            state = "backslash"
                        elseif b == start then
                            state = "done"
                        end
                    else
                        -- state == "backslash"
                        state = "base"
                    end
                until not b or (state == "done")
                if not b then parseError('unexpected end of source') end
                local raw = string.char(unpack(chars))
                local formatted = raw:gsub("[\1-\31]", function (c) return '\\' .. c:byte() end)
                local loadFn = loadCode(('return %s'):format(formatted), nil, filename)
                dispatch(loadFn())
            elseif prefixes[b] then -- expand prefix byte into wrapping form eg. '`a' into '(quote a)'
                table.insert(stack, {
                    prefix = prefixes[b]
                })
            else -- Try symbol
                local chars = {}
                local bytestart = byteindex
                repeat
                    chars[#chars + 1] = b
                    b = getb()
                until not b or not issymbolchar(b)
                if b then ungetb(b) end
                local rawstr = string.char(unpack(chars))
                if rawstr == 'true' then dispatch(true)
                elseif rawstr == 'false' then dispatch(false)
                elseif rawstr == '...' then dispatch(VARARG)
                elseif rawstr:match('^:.+$') then -- keyword style strings
                    dispatch(rawstr:sub(2))
                else
                    local forceNumber = rawstr:match('^%d')
                    local numberWithStrippedUnderscores = rawstr:gsub("_", "")
                    local x
                    if forceNumber then
                        x = tonumber(numberWithStrippedUnderscores) or
                            parseError('could not read token "' .. rawstr .. '"')
                    else
                        x = tonumber(numberWithStrippedUnderscores) or
                            sym(rawstr, nil, { line = line,
                                               filename = filename,
                                               bytestart = bytestart,
                                               byteend = byteindex, })
                    end
                    dispatch(x)
                end
            end
        until done
        return true, retval
    end, function ()
        stack = {}
    end
end

--
-- Compilation
--

-- Create a new Scope, optionally under a parent scope. Scopes are compile time constructs
-- that are responsible for keeping track of local variables, name mangling, and macros.
-- They are accessible to user code via the '*compiler' special form (may change). They
-- use metatables to implement nesting via inheritance.
local function makeScope(parent)
    return {
        unmanglings = setmetatable({}, {
            __index = parent and parent.unmanglings
        }),
        manglings = setmetatable({}, {
            __index = parent and parent.manglings
        }),
        specials = setmetatable({}, {
            __index = parent and parent.specials
        }),
        symmeta = setmetatable({}, {
            __index = parent and parent.symmeta
        }),
        parent = parent,
        vararg = parent and parent.vararg,
        depth = parent and ((parent.depth or 0) + 1) or 0
    }
end

-- Assert a condition and raise a compile error with line numbers. The ast arg
-- should be unmodified so that its first element is the form being called.
local function assertCompile(condition, msg, ast)
    -- if we use regular `assert' we can't provide the `level' argument of zero
    if not condition then
        error(string.format("Compile error in '%s' %s:%s: %s",
                            isSym(ast[1]) and ast[1][1] or ast[1] or '()',
                            ast.filename or "unknown", ast.line or '?', msg), 0)
    end
    return condition
end

local GLOBAL_SCOPE = makeScope()
GLOBAL_SCOPE.vararg = true
local SPECIALS = GLOBAL_SCOPE.specials
local COMPILER_SCOPE = makeScope(GLOBAL_SCOPE)

local luaKeywords = {
    'and', 'break', 'do', 'else', 'elseif', 'end', 'false', 'for', 'function',
    'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return', 'then', 'true',
    'until', 'while'
}
for i, v in ipairs(luaKeywords) do
    luaKeywords[v] = i
end

local function isValidLuaIdentifier(str)
    return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
end

-- Allow printing a string to Lua, also keep as 1 line.
local serializeSubst = {
    ['\a'] = '\\a',
    ['\b'] = '\\b',
    ['\f'] = '\\f',
    ['\n'] = 'n',
    ['\t'] = '\\t',
    ['\v'] = '\\v'
}
local function serializeString(str)
    local s = ("%q"):format(str)
    s = s:gsub('.', serializeSubst):gsub("[\128-\255]", function(c)
        return "\\" .. c:byte()
    end)
    return s
end

-- A multi symbol is a symbol that is actually composed of
-- two or more symbols using the dot syntax. The main differences
-- from normal symbols is that they cannot be declared local, and
-- they may have side effects on invocation (metatables)
local function isMultiSym(str)
    if type(str) ~= 'string' then return end
    local parts = {}
    for part in str:gmatch('[^%.]+') do
        parts[#parts + 1] = part
    end
    return #parts > 0 and
    str:match('%.') and
    (not str:match('%.%.')) and
    str:byte() ~= string.byte '.' and
    str:byte(-1) ~= string.byte '.' and
    parts
end

-- Mangler for global symbols. Does not protect against collisions,
-- but makes them unlikely. This is the mangling that is exposed to
-- to the world.
local function globalMangling(str)
    if isValidLuaIdentifier(str) then
        return str
    end
    -- Use underscore as escape character
    return '__fnl_global__' .. str:gsub('[^%w]', function (c)
        return ('_%02x'):format(c:byte())
    end)
end

-- Reverse a global mangling. Takes a Lua identifier and
-- returns the fennel symbol string that created it.
local function globalUnmangling(identifier)
    local rest = identifier:match('^__fnl_global__(.*)$')
    if rest then
        return rest:gsub('_[%da-f][%da-f]', function (code)
            return string.char(tonumber(code:sub(2), 16))
        end)
    else
        return identifier
    end
end

-- Creates a symbol from a string by mangling it.
-- ensures that the generated symbol is unique
-- if the input string is unique in the scope.
local function localMangling(str, scope, ast)
    if scope.manglings[str] then
        return scope.manglings[str]
    end
    local append = 0
    local mangling = str
    assertCompile(not isMultiSym(str), 'did not expect multi symbol ' .. str, ast)

    -- Mapping mangling to a valid Lua identifier
    if luaKeywords[mangling] or mangling:match('^%d') then
        mangling = '_' .. mangling
    end
    mangling = mangling:gsub('-', '_')
    mangling = mangling:gsub('[^%w_]', function (c)
        return ('_%02x'):format(c:byte())
    end)

    local raw = mangling
    while scope.unmanglings[mangling] do
        mangling = raw .. append
        append = append + 1
    end
    scope.unmanglings[mangling] = str
    scope.manglings[str] = mangling
    return mangling
end

-- Combine parts of a symbol
local function combineParts(parts, scope)
    local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
    for i = 2, #parts do
        if isValidLuaIdentifier(parts[i]) then
            ret = ret .. '.' .. parts[i]
        else
            ret = ret .. '[' .. serializeString(parts[i]) .. ']'
        end
    end
    return ret
end

-- Generates a unique symbol in the scope.
local function gensym(scope)
    local mangling
    local append = 0
    repeat
        mangling = '_' .. append .. '_'
        append = append + 1
    until not scope.unmanglings[mangling]
    scope.unmanglings[mangling] = true
    return mangling
end

-- Declare a local symbol
local function declareLocal(symbol, meta, scope, ast)
    local name = symbol[1]
    assertCompile(not isMultiSym(name), "did not expect mutltisym", ast)
    local mangling = localMangling(name, scope, ast)
    scope.symmeta[name] = meta
    return mangling
end

-- If there's a provided list of allowed globals, don't let references
-- thru that aren't on the list. This list is set at the compiler
-- entry points of compile and compileStream.
local allowedGlobals

local function globalAllowed(name)
    if not allowedGlobals then return true end
    for _, g in ipairs(allowedGlobals) do
        if g == name then return true end
    end
end

-- Convert symbol to Lua code. Will only work for local symbols
-- if they have already been declared via declareLocal
local function symbolToExpression(symbol, scope, isReference)
    local name = symbol[1]
    local parts = isMultiSym(name) or {name}
    local etype = (#parts > 1) and "expression" or "sym"
    local isLocal = scope.manglings[parts[1]]
    -- if it's a reference and not a symbol which introduces a new binding
    -- then we need to check for allowed globals
    assertCompile(not isReference or isLocal or globalAllowed(parts[1]),
                  'unknown global in strict mode: ' .. parts[1], symbol)
    return expr(combineParts(parts, scope), etype)
end


-- Emit Lua code
local function emit(chunk, out, ast)
    if type(out) == 'table' then
        table.insert(chunk, out)
    else
        table.insert(chunk, {leaf = out, ast = ast})
    end
end

-- Do some peephole optimization.
local function peephole(chunk)
    if chunk.leaf then return chunk end
    -- Optimize do ... end in some cases.
    if #chunk == 3 and
        chunk[1].leaf == 'do' and
        not chunk[2].leaf and
        chunk[3].leaf == 'end' then
        return peephole(chunk[2])
    end
    -- Recurse
    for i, v in ipairs(chunk) do
        chunk[i] = peephole(v)
    end
    return chunk
end

-- correlate line numbers in input with line numbers in output
local function flattenChunkCorrelated(mainChunk)
    local function flatten(chunk, out, lastLine, file)
        if chunk.leaf then
            out[lastLine] = (out[lastLine] or "") .. " " .. chunk.leaf
        else
            for _, subchunk in ipairs(chunk) do
                -- Ignore empty chunks
                if subchunk.leaf or #subchunk > 0 then
                    -- don't increase line unless it's from the same file
                    if subchunk.ast and file == subchunk.ast.file then
                        lastLine = math.max(lastLine, subchunk.ast.line or 0)
                    end
                    lastLine = flatten(subchunk, out, lastLine, file)
                end
            end
        end
        return lastLine
    end
    local out = {}
    local last = flatten(mainChunk, out, 1, mainChunk.file)
    for i = 1, last do
        if out[i] == nil then out[i] = "" end
    end
    return table.concat(out, "\n")
end

-- Flatten a tree of indented Lua source code lines.
-- Tab is what is used to indent a block.
local function flattenChunk(sm, chunk, tab, depth)
    if type(tab) == 'boolean' then tab = tab and '  ' or '' end
    if chunk.leaf then
        local code = chunk.leaf
        local info = chunk.ast
        -- Just do line info for now to save memory
        if sm then sm[#sm + 1] = info and info.line or -1 end
        return code
    else
        local parts = {}
        for i = 1, #chunk do
            -- Ignore empty chunks
            if chunk[i].leaf or #(chunk[i]) > 0 then
                local sub = flattenChunk(sm, chunk[i], tab, depth + 1)
                if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
                table.insert(parts, sub)
            end
        end
        return table.concat(parts, '\n')
    end
end

-- Some global state for all fennel sourcemaps. For the time being,
-- this seems the easiest way to store the source maps.
-- Sourcemaps are stored with source being mapped as the key, prepended
-- with '@' if it is a filename (like debug.getinfo returns for source).
-- The value is an array of mappings for each line.
local fennelSourcemap = {}
-- TODO: loading, unloading, and saving sourcemaps?

local function makeShortSrc(source)
    source = source:gsub('\n', ' ')
    if #source <= 49 then
        return '[fennel "' .. source .. '"]'
    else
        return '[fennel "' .. source:sub(1, 46) .. '..."]'
    end
end

-- Return Lua source and source map table
local function flatten(chunk, options)
    local sm = options.sourcemap and {}
    chunk = peephole(chunk)
    if(options.correlate) then
        return flattenChunkCorrelated(chunk), {}
    else
        local ret = flattenChunk(sm, chunk, options.indent, 0)
        if sm then
            local key, short_src
            if options.filename then
                short_src = options.filename
                key = '@' .. short_src
            else
                key = ret
                short_src = makeShortSrc(options.source or ret)
            end
            sm.short_src = short_src
            sm.key = key
            fennelSourcemap[key] = sm
        end
        return ret, sm
    end
end

-- Convert expressions to Lua string
local function exprs1(exprs)
    local t = {}
    for _, e in ipairs(exprs) do
        t[#t + 1] = e[1]
    end
    return table.concat(t, ', ')
end

-- Compile side effects for a chunk
local function keepSideEffects(exprs, chunk, start, ast)
    start = start or 1
    for j = start, #exprs do
        local se = exprs[j]
        -- Avoid the rogue 'nil' expression (nil is usually a literal,
        -- but becomes an expression if a special form
        -- returns 'nil'.)
        if se.type == 'expression' and se[1] ~= 'nil' then
            emit(chunk, ('do local _ = %s end'):format(tostring(se)), ast)
        elseif se.type == 'statement' then
            emit(chunk, tostring(se), ast)
        end
    end
end

-- Does some common handling of returns and register
-- targets for special forms. Also ensures a list expression
-- has an acceptable number of expressions if opts contains the
-- "nval" option.
local function handleCompileOpts(exprs, parent, opts, ast)
    if opts.nval then
        local n = opts.nval
        if n ~= #exprs then
            local len = #exprs
            if len > n then
                -- Drop extra
                keepSideEffects(exprs, parent, n + 1, ast)
                for i = n, len do
                    exprs[i] = nil
                end
            else
                -- Pad with nils
                for i = #exprs + 1, n do
                    exprs[i] = expr('nil', 'literal')
                end
            end
        end
    end
    if opts.tail then
        emit(parent, ('return %s'):format(exprs1(exprs)), ast)
    end
    if opts.target then
        emit(parent, ('%s = %s'):format(opts.target, exprs1(exprs)), ast)
    end
    if opts.tail or opts.target then
        -- Prevent statements and expression from being used twice if they
        -- have side-effects. Since if the target or tail options are set,
        -- the expressions are already emitted, we should not return them. This
        -- is fine, as when these options are set, the caller doesn't need the result
        -- anyways.
        exprs = {}
    end
    return exprs
end

-- Compile an AST expression in the scope into parent, a tree
-- of lines that is eventually compiled into Lua code. Also
-- returns some information about the evaluation of the compiled expression,
-- which can be used by the calling function. Macros
-- are resolved here, as well as special forms in that order.
-- the 'ast' param is the root AST to compile
-- the 'scope' param is the scope in which we are compiling
-- the 'parent' param is the table of lines that we are compiling into.
-- add lines to parent by appending strings. Add indented blocks by appending
-- tables of more lines.
-- the 'opts' param contains info about where the form is being compiled.
-- Options include:
--   'target' - mangled name of symbol(s) being compiled to.
--      Could be one variable, 'a', or a list, like 'a, b, _0_'.
--   'tail' - boolean indicating tail position if set. If set, form will generate a return
--   instruction.
local function compile1(ast, scope, parent, opts)
    opts = opts or {}
    local exprs = {}

    -- Compile the form
    if isList(ast) then
        -- Function call or special form
        local len = #ast
        assertCompile(len > 0, "expected a function to call", ast)
        -- Test for special form
        local first = ast[1]
        if isSym(first) then -- Resolve symbol
            first = first[1]
        end
        local special = scope.specials[first]
        if special and isSym(ast[1]) then
            -- Special form
            exprs = special(ast, scope, parent, opts) or expr('nil', 'literal')
            -- Be very accepting of strings or expression
            -- as well as lists or expressions
            if type(exprs) == 'string' then exprs = expr(exprs, 'expression') end
            if getmetatable(exprs) == EXPR_MT then exprs = {exprs} end
            -- Unless the special form explicitly handles the target, tail, and nval properties,
            -- (indicated via the 'returned' flag, handle these options.
            if not exprs.returned then
                exprs = handleCompileOpts(exprs, parent, opts, ast)
            elseif opts.tail or opts.target then
                exprs = {}
            end
            exprs.returned = true
            return exprs
        else
            -- Function call
            local fargs = {}
            local fcallee = compile1(ast[1], scope, parent, {
                nval = 1
            })[1]
            assertCompile(fcallee.type ~= 'literal',
                          'cannot call literal value', ast)
            fcallee = tostring(fcallee)
            for i = 2, len do
                local subexprs = compile1(ast[i], scope, parent, {
                    nval = i ~= len and 1 or nil
                })
                fargs[#fargs + 1] = subexprs[1] or expr('nil', 'literal')
                if i == len then
                    -- Add sub expressions to function args
                    for j = 2, #subexprs do
                        fargs[#fargs + 1] = subexprs[j]
                    end
                else
                    -- Emit sub expression only for side effects
                    keepSideEffects(subexprs, parent, 2, ast[i])
                end
            end
            local call = ('%s(%s)'):format(tostring(fcallee), exprs1(fargs))
            exprs = handleCompileOpts({expr(call, 'statement')}, parent, opts, ast)
        end
    elseif isVarg(ast) then
        assertCompile(scope.vararg, "unexpected vararg", ast)
        exprs = handleCompileOpts({expr('...', 'varg')}, parent, opts, ast)
    elseif isSym(ast) then
        local e
        -- Handle nil as special symbol - it resolves to the nil literal rather than
        -- being unmangled. Alternatively, we could remove it from the lua keywords table.
        if ast[1] == 'nil' then
            e = expr('nil', 'literal')
        else
            e = symbolToExpression(ast, scope, true)
        end
        exprs = handleCompileOpts({e}, parent, opts, ast)
    elseif type(ast) == 'nil' or type(ast) == 'boolean' then
        exprs = handleCompileOpts({expr(tostring(ast), 'literal')}, parent, opts)
    elseif type(ast) == 'number' then
        local n = ('%.17g'):format(ast)
        exprs = handleCompileOpts({expr(n, 'literal')}, parent, opts)
    elseif type(ast) == 'string' then
        local s = serializeString(ast)
        exprs = handleCompileOpts({expr(s, 'literal')}, parent, opts)
    elseif type(ast) == 'table' then
        local buffer = {}
        for i = 1, #ast do -- Write numeric keyed values.
            local nval = i ~= #ast and 1
            buffer[#buffer + 1] = exprs1(compile1(ast[i], scope, parent, {nval = nval}))
        end
        local keys = {}
        for k, _ in pairs(ast) do -- Write other keys.
            if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
                local kstr
                if type(k) == 'string' and isValidLuaIdentifier(k) then
                    kstr = k
                else
                    kstr = '[' .. tostring(compile1(k, scope, parent, {nval = 1})[1]) .. ']'
                end
                table.insert(keys, { kstr, k })
            end
        end
        table.sort(keys, function (a, b) return a[1] < b[1] end)
        for _, k in ipairs(keys) do
            local v = ast[k[2]]
            buffer[#buffer + 1] = ('%s = %s'):format(
                k[1], tostring(compile1(v, scope, parent, {nval = 1})[1]))
        end
        local tbl = '{' .. table.concat(buffer, ', ') ..'}'
        exprs = handleCompileOpts({expr(tbl, 'expression')}, parent, opts, ast)
    else
        assertCompile(false, 'could not compile value of type ' .. type(ast), ast)
    end
    exprs.returned = true
    return exprs
end

-- SPECIALS --

-- For statements and expressions, put the value in a local to avoid
-- double-evaluating it.
local function once(val, ast, scope, parent)
    if val.type == 'statement' or val.type == 'expression' then
        local s = gensym(scope)
        emit(parent, ('local %s = %s'):format(s, tostring(val)), ast)
        return expr(s, 'sym')
    else
        return val
    end
end

-- Implements destructuring for forms like let, bindings, etc.
-- Takes a number of options to control behavior.
-- var: Whether or not to mark symbols as mutable
-- declaration: begin each assignment with 'local' in output
-- nomulti: disallow multisyms in the destructuring. Used for (local) and (global).
-- noundef: Don't set undefined bindings. (set)
-- forceglobal: Don't allow local bindings
local function destructure(to, from, ast, scope, parent, opts)
    opts = opts or {}
    local isvar = opts.isvar
    local declaration = opts.declaration
    local nomulti = opts.nomulti
    local noundef = opts.noundef
    local forceglobal = opts.forceglobal
    local forceset = opts.forceset
    local setter = declaration and "local %s = %s" or "%s = %s"

    -- Get Lua source for symbol, and check for errors
    local function getname(symbol, up1)
        local raw = symbol[1]
        assertCompile(not (nomulti and isMultiSym(raw)),
            'did not expect multisym', up1)
        if declaration then
            return declareLocal(symbol, {var = isvar}, scope, symbol)
        else
            local parts = isMultiSym(raw) or {raw}
            local meta = scope.symmeta[parts[1]]
            if #parts == 1 and not forceset then
                assertCompile(not(forceglobal and meta),
                    'expected global, found var', up1)
                assertCompile(meta or not noundef,
                    'expected local var ' .. parts[1], up1)
                assertCompile(not (meta and not meta.var),
                    'expected local var', up1)
            end
            return symbolToExpression(symbol, scope)[1]
        end
    end

    -- Recursive auxiliary function
    local function destructure1(left, rightexprs, up1)
        if isSym(left) and left[1] ~= "nil" then
            emit(parent, setter:format(getname(left, up1), exprs1(rightexprs)), left)
        elseif isTable(left) then -- table destructuring
            local s = gensym(scope)
            emit(parent, ("local %s = %s"):format(s, exprs1(rightexprs)), left)
            for k, v in pairs(left) do
                if isSym(left[k]) and left[k][1] == "&" then
                    assertCompile(type(k) == "number" and not left[k+2],
                        "expected rest argument in final position", left)
                    local subexpr = expr(('{(table.unpack or unpack)(%s, %s)}'):format(s, k),
                        'expression')
                    destructure1(left[k+1], {subexpr}, left)
                    return
                else
                    if type(k) ~= "number" then k = serializeString(k) end
                    local subexpr = expr(('%s[%s]'):format(s, k), 'expression')
                    destructure1(v, {subexpr}, left)
                end
            end
        elseif isList(left) then -- values destructuring
            local leftNames, tables = {}, {}
            for i, name in ipairs(left) do
                local symname
                if isSym(name) then -- binding directly to a name
                    symname = getname(name, up1)
                else -- further destructuring of tables inside values
                    symname = gensym(scope)
                    tables[i] = {name, expr(symname, 'sym')}
                end
                table.insert(leftNames, symname)
            end
            emit(parent, setter:
            format(table.concat(leftNames, ", "), exprs1(rightexprs)), left)
            for _, pair in pairs(tables) do -- recurse if left-side tables found
                destructure1(pair[1], {pair[2]}, left)
            end
        else
            assertCompile(false, 'unable to destructure ' .. tostring(left), up1)
        end
    end

    local rexps = compile1(from, scope, parent)
    local ret = destructure1(to, rexps, ast)
    return ret
end

-- Unlike most expressions and specials, 'values' resolves with multiple
-- values, one for each argument, allowing multiple return values. The last
-- expression, can return multiple arguments as well, allowing for more than the number
-- of expected arguments.
local function values(ast, scope, parent)
    local len = #ast
    local exprs = {}
    for i = 2, len do
        local subexprs = compile1(ast[i], scope, parent, {})
        exprs[#exprs + 1] = subexprs[1] or expr('nil', 'literal')
        if i == len then
            for j = 2, #subexprs do
                exprs[#exprs + 1] = subexprs[j]
            end
        else
            -- Emit sub expression only for side effects
            keepSideEffects(subexprs, parent, 2, ast)
        end
    end
    return exprs
end

-- Compile a list of forms for side effects
local function compileDo(ast, scope, parent, start)
    start = start or 2
    local len = #ast
    local subScope = makeScope(scope)
    for i = start, len do
        compile1(ast[i], subScope, parent, {
            nval = 0
        })
    end
end

-- Implements a do statement, starting at the 'start' element. By default, start is 2.
local function doImpl(ast, scope, parent, opts, start, chunk, subScope)
    start = start or 2
    subScope = subScope or makeScope(scope)
    chunk = chunk or {}
    local len = #ast
    local outerTarget = opts.target
    local outerTail = opts.tail
    local retexprs = {returned = true}

    -- See if we need special handling to get the return values
    -- of the do block
    if not outerTarget and opts.nval ~= 0 and not outerTail then
        if opts.nval then
            -- Generate a local target
            local syms = {}
            for i = 1, opts.nval do
                local s = gensym(scope)
                syms[i] = s
                retexprs[i] = expr(s, 'sym')
            end
            outerTarget = table.concat(syms, ', ')
            emit(parent, ('local %s'):format(outerTarget), ast)
            emit(parent, 'do', ast)
        else
            -- We will use an IIFE for the do
            local fname = gensym(scope)
            local fargs = scope.vararg and '...' or ''
            emit(parent, ('local function %s(%s)'):format(fname, fargs), ast)
            retexprs = expr(fname .. '(' .. fargs .. ')', 'statement')
            outerTail = true
            outerTarget = nil
        end
    else
        emit(parent, 'do', ast)
    end
    -- Compile the body
    if start > len then
        -- In the unlikely case we do a do with no arguments.
        compile1(nil, subScope, chunk, {
            tail = outerTail,
            target = outerTarget
        })
        -- There will be no side effects
    else
        for i = start, len do
            local subopts = {
                nval = i ~= len and 0 or opts.nval,
                tail = i == len and outerTail or nil,
                target = i == len and outerTarget or nil
            }
            local subexprs = compile1(ast[i], subScope, chunk, subopts)
            if i ~= len then
                keepSideEffects(subexprs, parent, nil, ast[i])
            end
        end
    end
    emit(parent, chunk, ast)
    emit(parent, 'end', ast)
    return retexprs
end

SPECIALS['do'] = doImpl
SPECIALS['values'] = values

-- The fn special declares a function. Syntax is similar to other lisps;
-- (fn optional-name [arg ...] (body))
-- Further decoration such as docstrings, meta info, and multibody functions a possibility.
SPECIALS['fn'] = function(ast, scope, parent)
    local fScope = makeScope(scope)
    local fChunk = {}
    local index = 2
    local fnName = isSym(ast[index])
    local isLocalFn
    fScope.vararg = false
    if fnName and fnName[1] ~= 'nil' then
        isLocalFn = not isMultiSym(fnName[1])
        if isLocalFn then
            fnName = declareLocal(fnName, {}, scope, ast)
        else
            fnName = symbolToExpression(fnName, scope)[1]
        end
        index = index + 1
    else
        isLocalFn = true
        fnName = gensym(scope)
    end
    local argList = assertCompile(isTable(ast[index]),
                                  'expected vector arg list [a b ...]', ast)
    local argNameList = {}
    for i = 1, #argList do
        if isVarg(argList[i]) then
            assertCompile(i == #argList, "expected vararg in last parameter position", ast)
            argNameList[i] = '...'
            fScope.vararg = true
        elseif(isSym(argList[i]) and argList[i][1] ~= "nil"
               and not isMultiSym(argList[i][1])) then
            argNameList[i] = declareLocal(argList[i], {}, fScope, ast)
        elseif isTable(argList[i]) then
            local raw = sym(gensym(scope))
            argNameList[i] = declareLocal(raw, {}, fScope, ast)
            destructure(argList[i], raw, ast, fScope, fChunk,
                        { declaration = true, nomulti = true })
        else
            assertCompile(false, 'expected symbol for function parameter', ast)
        end
    end
    for i = index + 1, #ast do
        compile1(ast[i], fScope, fChunk, {
            tail = i == #ast,
            nval = i ~= #ast and 0 or nil
        })
    end
    if isLocalFn then
        emit(parent, ('local function %s(%s)')
                 :format(fnName, table.concat(argNameList, ', ')), ast)
    else
        emit(parent, ('%s = function(%s)')
                 :format(fnName, table.concat(argNameList, ', ')), ast)
    end
    emit(parent, fChunk, ast)
    emit(parent, 'end', ast)
    return expr(fnName, 'sym')
end

SPECIALS['luaexpr'] = function(ast)
    return tostring(ast[2])
end

SPECIALS['luastatement'] = function(ast)
    return expr(tostring(ast[2]), 'statement')
end

-- Wrapper for table access
SPECIALS['.'] = function(ast, scope, parent)
    local len = #ast
    assertCompile(len > 1, "expected table argument", ast)
    local lhs = compile1(ast[2], scope, parent, {nval = 1})
    if len == 2 then
        return tostring(lhs[1])
    else
        local indices = {}
        for i = 3, len do
            local index = ast[i]
            if type(index) == 'string' and isValidLuaIdentifier(index) then
                table.insert(indices, '.' .. index)
            else
                index = compile1(index, scope, parent, {nval = 1})[1]
                table.insert(indices, '[' .. tostring(index) .. ']')
            end
        end
        -- extra parens are needed for table literals
        if isTable(ast[2]) then
            return '(' .. tostring(lhs[1]) .. ')' .. table.concat(indices)
        else
            return tostring(lhs[1]) .. table.concat(indices)
        end
    end
end

SPECIALS['global'] = function(ast, scope, parent)
    assertCompile(#ast == 3, "expected name and value", ast)
    if allowedGlobals then table.insert(allowedGlobals, ast[2][1]) end
    destructure(ast[2], ast[3], ast, scope, parent, {
        nomulti = true,
        forceglobal = true
    })
end

SPECIALS['set'] = function(ast, scope, parent)
    assertCompile(#ast == 3, "expected name and value", ast)
    destructure(ast[2], ast[3], ast, scope, parent, {
        noundef = true
    })
end

SPECIALS['set-forcibly!'] = function(ast, scope, parent)
    assertCompile(#ast == 3, "expected name and value", ast)
    destructure(ast[2], ast[3], ast, scope, parent, {
        forceset = true
    })
end

SPECIALS['local'] = function(ast, scope, parent)
    assertCompile(#ast == 3, "expected name and value", ast)
    destructure(ast[2], ast[3], ast, scope, parent, {
        declaration = true,
        nomulti = true
    })
end

SPECIALS['var'] = function(ast, scope, parent)
    assertCompile(#ast == 3, "expected name and value", ast)
    destructure(ast[2], ast[3], ast, scope, parent, {
        declaration = true,
        nomulti = true,
        isvar = true
    })
end

SPECIALS['let'] = function(ast, scope, parent, opts)
    local bindings = ast[2]
    assertCompile(isList(bindings) or isTable(bindings),
                  'expected table for destructuring', ast)
    assertCompile(#bindings % 2 == 0,
                  'expected even number of name/value bindings', ast)
    assertCompile(#ast >= 3, 'missing body expression', ast)
    local subScope = makeScope(scope)
    local subChunk = {}
    for i = 1, #bindings, 2 do
        destructure(bindings[i], bindings[i + 1], ast, subScope, subChunk, {
            declaration = true,
            nomulti = true
        })
    end
    return doImpl(ast, scope, parent, opts, 3, subChunk, subScope)
end

-- For setting items in a table
SPECIALS['tset'] = function(ast, scope, parent)
    assertCompile(#ast > 3,
                  ('tset form needs table, key, and value'), ast)
    local root = compile1(ast[2], scope, parent, {nval = 1})[1]
    local keys = {}
    for i = 3, #ast - 1 do
        local key = compile1(ast[i], scope, parent, {nval = 1})[1]
        keys[#keys + 1] = tostring(key)
    end
    local value = compile1(ast[#ast], scope, parent, {nval = 1})[1]
    emit(parent, ('%s[%s] = %s'):format(tostring(root),
                                        table.concat(keys, ']['),
                                        tostring(value)), ast)
end

-- The if special form behaves like the cond form in
-- many languages
SPECIALS['if'] = function(ast, scope, parent, opts)
    local doScope = makeScope(scope)
    local branches = {}
    local elseBranch = nil

    -- Calculate some external stuff. Optimizes for tail calls and what not
    local outerTail = true
    local outerTarget = nil
    local wrapper = 'iife'
    if opts.tail then
        wrapper = 'none'
    end

    -- Compile bodies and conditions
    local bodyOpts = {
        tail = outerTail,
        target = outerTarget
    }
    local function compileBody(i)
        local chunk = {}
        local cscope = makeScope(doScope)
        compile1(ast[i], cscope, chunk, bodyOpts)
        return {
            chunk = chunk,
            scope = cscope
        }
    end
    for i = 2, #ast - 1, 2 do
        local condchunk = {}
        local cond =  compile1(ast[i], doScope, condchunk, {nval = 1})
        local branch = compileBody(i + 1)
        branch.cond = cond
        branch.condchunk = condchunk
        branch.nested = i ~= 2 and next(condchunk, nil) == nil
        table.insert(branches, branch)
    end
    local hasElse = #ast > 3 and #ast % 2 == 0
    if hasElse then elseBranch = compileBody(#ast) end

    -- Emit code
    local s = gensym(scope)
    local buffer = {}
    local lastBuffer = buffer
    for i = 1, #branches do
        local branch = branches[i]
        local fstr = not branch.nested and 'if %s then' or 'elseif %s then'
        local condLine = fstr:format(tostring(branch.cond[1]))
        if branch.nested then
            emit(lastBuffer, branch.condchunk, ast)
        else
            for _, v in ipairs(branch.condchunk) do emit(lastBuffer, v, ast) end
        end
        emit(lastBuffer, condLine, ast)
        emit(lastBuffer, branch.chunk, ast)
        if i == #branches then
            if hasElse then
                emit(lastBuffer, 'else', ast)
                emit(lastBuffer, elseBranch.chunk, ast)
            end
            emit(lastBuffer, 'end', ast)
        elseif not branches[i + 1].nested then
            emit(lastBuffer, 'else', ast)
            local nextBuffer = {}
            emit(lastBuffer, nextBuffer, ast)
            emit(lastBuffer, 'end', ast)
            lastBuffer = nextBuffer
        end
    end

    if wrapper == 'iife' then
        local iifeargs = scope.vararg and '...' or ''
        emit(parent, ('local function %s(%s)'):format(tostring(s), iifeargs), ast)
        emit(parent, buffer, ast)
        emit(parent, 'end', ast)
        return expr(('%s(%s)'):format(tostring(s), iifeargs), 'statement')
    elseif wrapper == 'none' then
        -- Splice result right into code
        for i = 1, #buffer do
            emit(parent, buffer[i], ast)
        end
        return {returned = true}
    end
end

-- (each [k v (pairs t)] body...) => []
SPECIALS['each'] = function(ast, scope, parent)
    local binding = assertCompile(isTable(ast[2]), 'expected binding table', ast)
    local iter = table.remove(binding, #binding) -- last item is iterator call
    local bindVars = {}
    local destructures = {}
    for _, v in ipairs(binding) do
        assertCompile(isSym(v) or isTable(v),
                      'expected iterator symbol or table', ast)
        if(isSym(v)) then
            table.insert(bindVars, declareLocal(v, {}, scope, ast))
        else
            local raw = sym(gensym(scope))
            destructures[raw] = v
            table.insert(bindVars, declareLocal(raw, {}, scope, ast))
        end
    end
    emit(parent, ('for %s in %s do'):format(
             table.concat(bindVars, ', '),
             tostring(compile1(iter, scope, parent, {nval = 1})[1])), ast)
    local chunk = {}
    for raw, args in pairs(destructures) do
        destructure(args, raw, ast, scope, chunk,
                    { declaration = true, nomulti = true })
    end
    compileDo(ast, scope, chunk, 3)
    emit(parent, chunk, ast)
    emit(parent, 'end', ast)
end

-- (while condition body...) => []
SPECIALS['while'] = function(ast, scope, parent)
    local len1 = #parent
    local condition = compile1(ast[2], scope, parent, {nval = 1})[1]
    local len2 = #parent
    local subChunk = {}
    if len1 ~= len2 then
        -- Compound condition
        emit(parent, 'while true do', ast)
        -- Move new compilation to subchunk
        for i = len1 + 1, len2 do
            subChunk[#subChunk + 1] = parent[i]
            parent[i] = nil
        end
        emit(parent, ('if %s then break end'):format(condition[1]), ast)
    else
        -- Simple condition
        emit(parent, 'while ' .. tostring(condition) .. ' do', ast)
    end
    compileDo(ast, makeScope(scope), subChunk, 3)
    emit(parent, subChunk, ast)
    emit(parent, 'end', ast)
end

SPECIALS['for'] = function(ast, scope, parent)
    local ranges = assertCompile(isTable(ast[2]), 'expected binding table', ast)
    local bindingSym = assertCompile(isSym(table.remove(ast[2], 1)),
                                     'expected iterator symbol', ast)
    local rangeArgs = {}
    for i = 1, math.min(#ranges, 3) do
        rangeArgs[i] = tostring(compile1(ranges[i], scope, parent, {nval = 1})[1])
    end
    emit(parent, ('for %s = %s do'):format(
             declareLocal(bindingSym, {}, scope, ast),
             table.concat(rangeArgs, ', ')), ast)
    local chunk = {}
    compileDo(ast, scope, chunk, 3)
    emit(parent, chunk, ast)
    emit(parent, 'end', ast)
end

SPECIALS[':'] = function(ast, scope, parent)
    assertCompile(#ast >= 3, 'expected at least 3 arguments', ast)
    -- Compile object
    local objectexpr = compile1(ast[2], scope, parent, {nval = 1})[1]
    -- Compile method selector
    local methodstring
    local methodident = false
    if type(ast[3]) == 'string' and isValidLuaIdentifier(ast[3]) then
        methodident = true
        methodstring = ast[3]
    else
        methodstring = tostring(compile1(ast[3], scope, parent, {nval = 1})[1])
        objectexpr = once(objectexpr, ast[2], scope, parent)
    end
    -- Compile arguments
    local args = {}
    for i = 4, #ast do
        local subexprs = compile1(ast[i], scope, parent, {
            nval = i ~= #ast and 1 or nil
        })
        for j = 1, #subexprs do
            args[#args + 1] = tostring(subexprs[j])
        end
    end
    local fstring
    if methodident then
        fstring = objectexpr.type == 'literal'
            and '(%s):%s(%s)'
            or '%s:%s(%s)'
    else
        -- Make object first argument
        table.insert(args, 1, tostring(objectexpr))
        fstring = objectexpr.type == 'sym'
            and '%s[%s](%s)'
            or '(%s)[%s](%s)'
    end
    return expr(fstring:format(
        tostring(objectexpr),
        methodstring,
        table.concat(args, ', ')), 'statement')
end

local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
    local paddedOp = ' ' .. name .. ' '
    SPECIALS[name] = function(ast, scope, parent)
        local len = #ast
        if len == 1 then
            assertCompile(zeroArity ~= nil, 'Expected more than 0 arguments', ast)
            return expr(zeroArity, 'literal')
        else
            local operands = {}
            for i = 2, len do
                local subexprs = compile1(ast[i], scope, parent, {
                    nval = (i == 1 and 1 or nil)
                })
                for j = 1, #subexprs do
                    operands[#operands + 1] = tostring(subexprs[j])
                end
            end
            if #operands == 1 then
                if unaryPrefix then
                    return '(' .. unaryPrefix .. paddedOp .. operands[1] .. ')'
                else
                    return operands[1]
                end
            else
                return '(' .. table.concat(operands, paddedOp) .. ')'
            end
        end
    end
end

defineArithmeticSpecial('+', '0')
defineArithmeticSpecial('..', "''")
defineArithmeticSpecial('^')
defineArithmeticSpecial('-', nil, '')
defineArithmeticSpecial('*', '1')
defineArithmeticSpecial('%')
defineArithmeticSpecial('/', nil, '1')
defineArithmeticSpecial('//', nil, '1')
defineArithmeticSpecial('or', 'false')
defineArithmeticSpecial('and', 'true')

local function defineComparatorSpecial(name, realop)
    local op = realop or name
    SPECIALS[name] = function(ast, scope, parent)
        local len = #ast
        assertCompile(len > 2, 'expected at least two arguments', ast)
        local lhs = compile1(ast[2], scope, parent, {nval = 1})[1]
        local lastval = compile1(ast[3], scope, parent, {nval = 1})[1]
        -- avoid double-eval by introducing locals for possible side-effects
        if len > 3 then lastval = once(lastval, ast[3], scope, parent) end
        local out = ('(%s %s %s)'):
            format(tostring(lhs), op, tostring(lastval))
        if len > 3 then
            for i = 4, len do -- variadic comparison
                local nextval = once(compile1(ast[i], scope, parent, {nval = 1})[1],
                                     ast[i], scope, parent)
                out = (out .. " and (%s %s %s)"):
                    format(tostring(lastval), op, tostring(nextval))
                lastval = nextval
            end
            out = '(' .. out .. ')'
        end
        return out
    end
end

defineComparatorSpecial('>')
defineComparatorSpecial('<')
defineComparatorSpecial('>=')
defineComparatorSpecial('<=')
defineComparatorSpecial('=', '==')
defineComparatorSpecial('~=')

local function defineUnarySpecial(op, realop)
    SPECIALS[op] = function(ast, scope, parent)
        assertCompile(#ast == 2, 'expected one argument', ast)
        local tail = compile1(ast[2], scope, parent, {nval = 1})
        return (realop or op) .. tostring(tail[1])
    end
end

defineUnarySpecial('not', 'not ')
defineUnarySpecial('#')

-- Covert a macro function to a special form
local function macroToSpecial(mac)
    return function(ast, scope, parent, opts)
        local ok, transformed = pcall(mac, unpack(ast, 2))
        assertCompile(ok, transformed, ast)
        return compile1(transformed, scope, parent, opts)
    end
end

local function compile(ast, options)
    options = options or {}
    local oldGlobals = allowedGlobals
    allowedGlobals = options.allowedGlobals
    if options.indent == nil then options.indent = '  ' end
    local chunk = {}
    local scope = options.scope or makeScope(GLOBAL_SCOPE)
    local exprs = compile1(ast, scope, chunk, {tail = true})
    keepSideEffects(exprs, chunk, nil, ast)
    allowedGlobals = oldGlobals
    return flatten(chunk, options)
end

-- map a function across all pairs in a table
local function quoteTmap(f, t)
    local res = {}
    for k,v in pairs(t) do
        local nk, nv = f(k, v)
        if nk then
            res[nk] = nv
        end
    end
    return res
end

-- make a transformer for key / value table pairs, preserving all numeric keys
local function entryTransform(fk,fv)
    return function(k, v)
        if type(k) == 'number' then
            return k,fv(v)
        else
            return fk(k),fv(v)
        end
    end
end

-- consume everything return nothing
local function no() end

local function mixedConcat(t, joiner)
    local ret = ""
    local s = ""
    local seen = {}
    for k,v in ipairs(t) do
        table.insert(seen, k)
        ret = ret .. s .. v
        s = joiner
    end
    for k,v in pairs(t) do
        if not(seen[k]) then
            ret = ret .. s .. '[' .. k .. ']' .. '=' .. v
            s = joiner
        end
    end
    return ret
end

-- expand a quoted form into a data literal, evaluating unquote
local function doQuote (form, scope, parent, runtime)
    local q = function (x) return doQuote(x, scope, parent, runtime) end
    -- symbol
    if isSym(form) then
        assertCompile(not runtime, "symbols may only be used at compile time", form)
        return ("sym('%s')"):format(deref(form))
    -- unquote
    elseif isList(form) and isSym(form[1]) and (deref(form[1]) == 'unquote') then
        local payload = form[2]
        local res = unpack(compile1(payload, scope, parent))
        return res[1]
    -- list
    elseif isList(form) then
        assertCompile(not runtime, "lists may only be used at compile time", form)
        local mapped = quoteTmap(entryTransform(no, q), form)
        return 'list(' .. mixedConcat(mapped, ", ") .. ')'
    -- table
    elseif type(form) == 'table' then
        local mapped = quoteTmap(entryTransform(q, q), form)
        return '{' .. mixedConcat(mapped, ", ") .. '}'
    -- string
    elseif type(form) == 'string' then
        return serializeString(form)
    else
        return tostring(form)
    end
end

SPECIALS['quote'] = function(ast, scope, parent)
    assertCompile(#ast == 2, "quote only takes a single form")
    local runtime, thisScope = true, scope
    while thisScope do
        thisScope = thisScope.parent
        if thisScope == COMPILER_SCOPE then runtime = false end
    end
    return doQuote(ast[2], scope, parent, runtime)
end

local function compileStream(strm, options)
    options = options or {}
    local oldGlobals = allowedGlobals
    allowedGlobals = options.allowedGlobals
    if options.indent == nil then options.indent = '  ' end
    local scope = options.scope or makeScope(GLOBAL_SCOPE)
    local vals = {}
    for ok, val in parser(strm, options.filename) do
        if not ok then break end
        vals[#vals + 1] = val
    end
    local chunk = {}
    for i = 1, #vals do
        local exprs = compile1(vals[i], scope, chunk, {
            tail = i == #vals
        })
        keepSideEffects(exprs, chunk, nil, vals[i])
    end
    allowedGlobals = oldGlobals
    return flatten(chunk, options)
end

local function compileString(str, options)
    local strm = stringStream(str)
    return compileStream(strm, options)
end

---
--- Evaluation
---

-- Convert a fennel environment table to a Lua environment table.
-- This means automatically unmangling globals when getting a value,
-- and mangling values when setting a value. This means the original
-- env will see its values updated as expected, regardless of mangling rules.
local function wrapEnv(env)
    return setmetatable({}, {
        __index = function(_, key)
            if type(key) == 'string' then
                key = globalUnmangling(key)
            end
            return env[key]
        end,
        __newindex = function(_, key, value)
            if type(key) == 'string' then
                key = globalMangling(key)
            end
            env[key] = value
        end,
        -- checking the __pairs metamethod won't work automatically in Lua 5.1
        -- sadly, but it's important for 5.2+ and can be done manually in 5.1
        __pairs = function()
            local pt = {}
            for key, value in pairs(env) do
                if type(key) == 'string' then
                    pt[globalUnmangling(key)] = value
                else
                    pt[key] = value
                end
            end
            return next, pt, nil
        end,
    })
end

-- A custom traceback function for Fennel that looks similar to
-- the Lua's debug.traceback.
-- Use with xpcall to produce fennel specific stacktraces.
local function traceback(msg, start)
    local level = start or 2 -- Can be used to skip some frames
    local lines = {}
    if msg then
        table.insert(lines, msg)
    end
    table.insert(lines, 'stack traceback:')
    while true do
        local info = debug.getinfo(level, "Sln")
        if not info then break end
        local line
        if info.what == "C" then
            if info.name then
                line = ('  [C]: in function \'%s\''):format(info.name)
            else
                line = '  [C]: in ?'
            end
        else
            local remap = fennelSourcemap[info.source]
            if remap and remap[info.currentline] then
                -- And some global info
                info.short_src = remap.short_src
                local mapping = remap[info.currentline]
                -- Overwrite info with values from the mapping (mapping is now just integer,
                -- but may eventually be a table
                info.currentline = mapping
            end
            if info.what == 'Lua' then
                local n = info.name and ("'" .. info.name .. "'") or '?'
                line = ('  %s:%d: in function %s'):format(info.short_src, info.currentline, n)
            elseif info.short_src == '(tail call)' then
                line = '  (tail call)'
            else
                line = ('  %s:%d: in main chunk'):format(info.short_src, info.currentline)
            end
        end
        table.insert(lines, line)
        level = level + 1
    end
    return table.concat(lines, '\n')
end

local function currentGlobalNames(env)
    local names = {}
    for k in pairs(env or _G) do
       k = globalUnmangling(k)
       table.insert(names, k)
    end
    return names
end

local function eval(str, options, ...)
    options = options or {}
    -- eval and dofile are considered "live" entry points, so we can assume
    -- that the globals available at compile time are a reasonable allowed list
    -- UNLESS there's a metatable on env, in which case we can't assume that
    -- pairs will return all the effective globals; for instance openresty
    -- sets up _G in such a way that all the globals are available thru
    -- the __index meta method, but as far as pairs is concerned it's empty.
    if options.allowedGlobals == nil and not getmetatable(options.env) then
        options.allowedGlobals = currentGlobalNames(options.env)
    end
    local env = options.env and wrapEnv(options.env)
    local luaSource = compileString(str, options)
    local loader = loadCode(luaSource, env,
        options.filename and ('@' .. options.filename) or str)
    return loader(...)
end

local function dofileFennel(filename, options, ...)
    options = options or {sourcemap = true}
    if options.allowedGlobals == nil then
        options.allowedGlobals = currentGlobalNames(options.env)
    end
    local f = assert(io.open(filename, "rb"))
    local source = f:read("*all"):gsub("^#![^\n]*\n", "")
    f:close()
    options.filename = options.filename or filename
    return eval(source, options, ...)
end

-- Implements a configurable repl
local function repl(options)

    local opts = options or {}
    -- This would get set for us when calling eval, but we want to seed it
    -- with a value that is persistent so it doesn't get reset on each eval.
    if opts.allowedGlobals == nil then
        options.allowedGlobals = currentGlobalNames(opts.env)
    end

    local env = opts.env and wrapEnv(opts.env) or setmetatable({}, {
        __index = _ENV or _G
    })

    local function defaultReadChunk(parserState)
        io.write(parserState.stackSize > 0 and '.. ' or '>> ')
        io.flush()
        local input = io.read()
        return input and input .. '\n'
    end

    local function defaultOnValues(xs)
        io.write(table.concat(xs, '\t'))
        io.write('\n')
    end

    local function defaultOnError(errtype, err, luaSource)
        if (errtype == 'Lua Compile') then
            io.write('Bad code generated - likely a bug with the compiler:\n')
            io.write('--- Generated Lua Start ---\n')
            io.write(luaSource .. '\n')
            io.write('--- Generated Lua End ---\n')
        end
        if (errtype == 'Runtime') then
            io.write(traceback(err, 4))
            io.write('\n')
        else
            io.write(('%s error: %s\n'):format(errtype, tostring(err)))
        end
    end

    -- Read options
    local readChunk = opts.readChunk or defaultReadChunk
    local onValues = opts.onValues or defaultOnValues
    local onError = opts.onError or defaultOnError
    local pp = opts.pp or tostring

    -- Make parser
    local bytestream, clearstream = granulate(readChunk)
    local chars = {}
    local read, reset = parser(function (parserState)
        local c = bytestream(parserState)
        chars[#chars + 1] = c
        return c
    end)

    local envdbg = (opts.env or _G)["debug"]
    -- if the environment doesn't support debug.getlocal you can't save locals
    local saveLocals = opts.saveLocals ~= false and envdbg and envdbg.getlocal
    local saveSource = table.
       concat({"local ___i___ = 1",
               "while true do",
               " local name, value = debug.getlocal(1, ___i___)",
               " if(name and name ~= \"___i___\") then",
               " ___replLocals___[name] = value",
               " ___i___ = ___i___ + 1",
               " else break end end"}, "\n")

    local spliceSaveLocals = function(luaSource)
        -- we do some source munging in order to save off locals from each chunk
        -- and reintroduce them to the beginning of the next chunk, allowing
        -- locals to work in the repl the way you'd expect them to.
        env.___replLocals___ = env.___replLocals___ or {}
        local splicedSource = {}
        for line in luaSource:gmatch("([^\n]+)\n?") do
            table.insert(splicedSource, line)
        end
        -- reintroduce locals from the previous time around
        local bind = "local %s = ___replLocals___['%s']"
        for name in pairs(env.___replLocals___) do
            table.insert(splicedSource, 1, bind:format(name, name))
        end
        -- save off new locals at the end - if safe to do so (i.e. last line is a return)
        if (string.match(splicedSource[#splicedSource], "^ *return .*$")) then
            if (#splicedSource > 1) then
                table.insert(splicedSource, #splicedSource, saveSource)
            end
        end
        return table.concat(splicedSource, "\n")
    end

    local scope = makeScope(GLOBAL_SCOPE)

    -- REPL loop
    while true do
        chars = {}
        local ok, parseok, x = pcall(read)
        local srcstring = string.char(unpack(chars))
        if not ok then
            onError('Parse', parseok)
            clearstream()
            reset()
        else
            if not parseok then break end -- eof
            local compileOk, luaSource = pcall(compile, x, {
                sourcemap = opts.sourcemap,
                source = srcstring,
                scope = scope,
            })
            if not compileOk then
                clearstream()
                onError('Compile', luaSource) -- luaSource is error message in this case
            else
                if saveLocals then
                    luaSource = spliceSaveLocals(luaSource)
                end
                local luacompileok, loader = pcall(loadCode, luaSource, env)
                if not luacompileok then
                    clearstream()
                    onError('Lua Compile', loader, luaSource)
                else
                    local loadok, ret = xpcall(function () return {loader()} end,
                        function (runtimeErr)
                            onError('Runtime', runtimeErr)
                        end)
                    if loadok then
                        env._ = ret[1]
                        env.__ = ret
                        for i = 1, #ret do ret[i] = pp(ret[i]) end
                        onValues(ret)
                    end
                end
            end
        end
    end
end

local macroLoaded = {}

local module = {
    parser = parser,
    granulate = granulate,
    stringStream = stringStream,
    compile = compile,
    compileString = compileString,
    compileStream = compileStream,
    compile1 = compile1,
    mangle = globalMangling,
    unmangle = globalUnmangling,
    list = list,
    sym = sym,
    varg = varg,
    scope = makeScope,
    gensym = gensym,
    eval = eval,
    repl = repl,
    dofile = dofileFennel,
    macroLoaded = macroLoaded,
    path = "./?.fnl;./?/init.fnl",
    traceback = traceback,
    version = "0.1.1-dev",
}

local function searchModule(modulename)
    modulename = modulename:gsub("%.", "/")
    for path in string.gmatch(module.path..";", "([^;]*);") do
        local filename = path:gsub("%?", modulename)
        local file = io.open(filename, "rb")
        if(file) then
            file:close()
            return filename
        end
    end
end

module.makeSearcher = function(options)
   return function(modulename)
      local opts = {}
      for k,v in pairs(options or {}) do opts[k] = v end
      local filename = searchModule(modulename)
      if filename then
         return function(modname)
            return dofileFennel(filename, opts, modname)
         end
      end
   end
end

-- This will allow regular `require` to work with Fennel:
-- table.insert(package.loaders, fennel.searcher)
module.searcher = module.makeSearcher()
module.make_searcher = module.makeSearcher -- oops backwards compatibility

local function makeCompilerEnv(ast, scope, parent)
    return setmetatable({
        -- State of compiler if needed
        _SCOPE = scope,
        _CHUNK = parent,
        _AST = ast,
        _IS_COMPILER = true,
        _SPECIALS = SPECIALS,
        _VARARG = VARARG,
        -- Expose the module in the compiler
        fennel = module,
        -- Useful for macros and meta programming. All of Fennel can be accessed
        -- via fennel.myfun, for example (fennel.eval "(print 1)").
        list = list,
        sym = sym,
        unpack = unpack,
        gensym = function() return sym(gensym(scope)) end,
        ["list?"] = isList,
        ["multi-sym?"] = isMultiSym,
        ["sym?"] = isSym,
        ["table?"] = isTable,
        ["varg?"] = isVarg,
        ["in-scope?"] = function(symbol)
            return scope.manglings[symbol]
        end
    }, { __index = _ENV or _G })
end

local function macroGlobals(env, globals)
    local allowed = {}
    for k in pairs(env) do
        local g = globalUnmangling(k)
        table.insert(allowed, g)
    end
    if globals then
        for _, k in pairs(globals) do
            table.insert(allowed, k)
        end
    end
    return allowed
end

local function addMacros(macros, ast, scope)
    assertCompile(isTable(macros), 'expected macros to be table', ast)
    for k, v in pairs(macros) do
        scope.specials[k] = macroToSpecial(v)
    end
end

local function loadMacros(modname, ast, scope, parent)
    local filename = assertCompile(searchModule(modname),
                                   modname .. " not found.", ast)
    local env = makeCompilerEnv(ast, scope, parent)
    local globals = macroGlobals(env, currentGlobalNames())
    return dofileFennel(filename, { env = env, allowedGlobals = globals,
                                    scope = COMPILER_SCOPE })
end

SPECIALS['require-macros'] = function(ast, scope, parent)
    assertCompile(#ast == 2, "Expected one module name argument", ast)
    local modname = ast[2]
    if not macroLoaded[modname] then
        macroLoaded[modname] = loadMacros(modname, ast, scope, parent)
    end
    addMacros(macroLoaded[modname], ast, scope, parent)
end

local function evalCompiler(ast, scope, parent)
    local luaSource = compile(ast, { scope = makeScope(COMPILER_SCOPE) })
    local loader = loadCode(luaSource, wrapEnv(makeCompilerEnv(ast, scope, parent)))
    return loader()
end

SPECIALS['macros'] = function(ast, scope, parent)
    assertCompile(#ast == 2, "Expected one table argument", ast)
    local macros = evalCompiler(ast[2], scope, parent)
    addMacros(macros, ast, scope, parent)
end

SPECIALS['eval-compiler'] = function(ast, scope, parent)
    local oldFirst = ast[1]
    ast[1] = sym('do')
    local val = evalCompiler(ast, scope, parent)
    ast[1] = oldFirst
    return val
end

-- Load standard macros
local stdmacros = [===[
{"->" (fn [val ...]
        (var x val)
        (each [_ elt (ipairs [...])]
          (table.insert elt 2 x)
          (set x elt))
        x)
 "->>" (fn [val ...]
         (var x val)
         (each [_ elt (pairs [...])]
           (table.insert elt x)
           (set x elt))
         x)
 "-?>" (fn [val ...]
         (if (= 0 (# [...]))
             val
             (let [els [...]
                   el (table.remove els 1)
                   tmp (gensym)]
               (table.insert el 2 tmp)
               `(let [@tmp @val]
                  (if @tmp
                      (-?> @el @(unpack els))
                      @tmp)))))
 "-?>>" (fn [val ...]
          (if (= 0 (# [...]))
              val
              (let [els [...]
                    el (table.remove els 1)
                    tmp (gensym)]
                (table.insert el tmp)
                `(let [@tmp @val]
                   (if @tmp
                       (-?>> @el @(unpack els))
                       @tmp)))))
 :doto (fn [val ...]
         (let [name (gensym)
               form `(let [@name @val])]
           (each [_ elt (pairs [...])]
             (table.insert elt 2 name)
             (table.insert form elt))
           (table.insert form name)
           form))
 :when (fn [condition body1 ...]
         (assert body1 "expected body")
         `(if @condition
              (do @body1 @...)))
 :partial (fn [f ...]
            (let [body (list f ...)]
              (table.insert body _VARARG)
              `(fn [@_VARARG] @body)))
 :lambda (fn [...]
           (let [args [...]
                 has-internal-name? (sym? (. args 1))
                 arglist (if has-internal-name? (. args 2) (. args 1))
                 arity-check-position (if has-internal-name? 3 2)]
             (assert (> (# args) 1) "missing body expression")
             (each [i a (ipairs arglist)]
               (if (and (not (: (tostring a) :match "^?"))
                        (~= (tostring a) "..."))
                   (table.insert args arity-check-position
                                 `(assert (~= nil @a)
                                          (: "Missing argument %s on %s:%s"
                                             :format @(tostring a)
                                             @(or a.filename "unknown")
                                             @(or a.line "?"))))))
             `(fn @(unpack args))))
 :match
(fn match [val ...]
  ;; this function takes the AST of values and a single pattern and returns a
  ;; condition to determine if it matches as well as a list of bindings to
  ;; introduce for the duration of the body if it does match.
  (fn match-pattern [vals pattern unifications]
    ;; we have to assume we're matching against multiple values here until we
    ;; know we're either in a multi-valued clause (in which case we know the #
    ;; of vals) or we're not, in which case we only care about the first one.
    (let [[val] vals]
      (if (and (sym? pattern) ; unification with outer locals (or nil)
               (or (in-scope? pattern)
                   (= :nil (tostring pattern))))
          (values `(= @val @pattern) [])

          ;; unify a local we've seen already
          (and (sym? pattern)
               (. unifications (tostring pattern)))
          (values `(= @(. unifications (tostring pattern)) @val) [])

          ;; bind a fresh local
          (sym? pattern)
          (do (if (~= (tostring pattern) "_")
                  (tset unifications (tostring pattern) val))
              (values (if (: (tostring pattern) :find "^?")
                          true `(~= @(sym :nil) @val))
                      [pattern val]))

          ;; multi-valued patterns (represented as lists)
          (list? pattern)
          (let [condition `(and)
                bindings []]
            (each [i pat (ipairs pattern)]
              (let [(subcondition subbindings) (match-pattern [(. vals i)] pat
                                                              unifications)]
                (table.insert condition subcondition)
                (each [_ b (ipairs subbindings)]
                  (table.insert bindings b))))
            (values condition bindings))

          ;; table patterns)
          (= (type pattern) :table)
          (let [condition `(and (= (type @val) :table))
                bindings []]
            (each [k pat (pairs pattern)]
              (assert (not (varg? pat)) "TODO: match against varg not implemented")
              (let [subval `(. @val @k)
                    (subcondition subbindings) (match-pattern [subval] pat
                                                              unifications)]
                (table.insert condition subcondition)
                (each [_ b (ipairs subbindings)]
                  (table.insert bindings b))))
            (values condition bindings))

          ;; literal value
          (values `(= @val @pattern) []))))

  (fn match-condition [vals clauses]
    (let [out `(if)]
      (for [i 1 (# clauses) 2]
        (let [pattern (. clauses i)
              body (. clauses (+ i 1))
              (condition bindings) (match-pattern vals pattern {})]
          (table.insert out condition)
          (table.insert out `(let @bindings @body))))
      out))

  ;; how many multi-valued clauses are there? return a list of that many gensyms
  (fn val-syms [clauses]
    (let [syms (list (gensym))]
      (for [i 1 (# clauses) 2]
        (if (list? (. clauses i))
            (each [valnum (ipairs (. clauses i))]
              (if (not (. syms valnum))
                  (tset syms valnum (gensym))))))
      syms))

  ;; wrap it in a way that prevents double-evaluation of the matched value
  (let [clauses [...]
        vals (val-syms clauses)]
    (if (~= 0 (% (# clauses) 2)) ; treat odd final clause as default
        (table.insert clauses (# clauses) (sym :_)))
    ;; protect against multiple evaluation of the value, bind against as
    ;; many values as we ever match against in the clauses.
    (list (sym :let) [vals val]
          (match-condition vals clauses))))
 }
]===]
do
    local env = makeCompilerEnv(nil, COMPILER_SCOPE, {})
    for name, fn in pairs(eval(stdmacros, {
        env = env,
        scope = makeScope(COMPILER_SCOPE),
        allowedGlobals = macroGlobals(env, currentGlobalNames()),
    })) do
        SPECIALS[name] = macroToSpecial(fn)
    end
end
SPECIALS['λ'] = SPECIALS['lambda']

return module

A  => readme.md +17 -0
@@ 1,17 @@
# Shevek

> All you have is what you are, and what you give.

A simple nREPL client.

## Usage

    $ shevek PORT

## License

Copyright © 2015-2018 Phil Hagelberg

Released under the terms of the GNU Lesser General Public License
version 3 or later; see the file LICENSE.


A  => shevek.fnl +84 -0
@@ 1,84 @@
(local socket (require :socket))
(local bencode (require :bencode))

(local active-requests {})
(var counter 0)
(var session nil)
(var ns nil)
(var prompt "=> ")

(λ count [tbl]
  (var i 0)
  (each [_ (pairs tbl)] (set i (+ 1 i)))
  i)

(λ contains? [tbl item ?n]
  (or (= item (. tbl (or ?n 1)))
      (if (<= (or ?n 1) (# tbl))
          (contains? tbl item (+ 1 (or ?n 1))))))

(λ send [msg conn]
  (set (msg.id counter) (values counter (+ counter 1)))
  (tset active-requests msg.id true)
  (when (not msg.session)
    (set msg.session session))
  (assert (: conn :send (bencode.encode msg))))

(λ send-input [?session]
  (let [input (io.read)]
    (send {:op :stdin
           :session ?session
           :stdin (if (= nil input) "" input)})))

(λ handler [response]
  (when response.new-session
    (print "Connected.")
    (set session response.new-session))

  (when response.err (print response.err))
  (when response.out (print response.out))
  (when response.value (print response.value))

  (when response.ns
    (set ns response.ns)
    (set prompt (.. response.ns "=> ")))

  (when response.status
    (when (contains? response.status :interrupted)
      (print "Evaluation interrupted.")
      (tset active-requests response.id nil))
    (when (contains? response.status :done)
      (tset active-requests response.id nil))
    (when (contains? response.status :needs-input)
      (send-input response.session))))

(λ receive [conn]
  (let [(data err part) (: conn :receive "*a")]
    (when (or data (and part (~= part "")))
      (let [(decodeds d-err) (bencode.decode_all (or data part))]
        (if decodeds
            (each [_ decoded (ipairs decodeds)]
              (handler decoded))
            (print (.. "Decoding error: " d-err (or data part) "\n"))))
      true)))

(local conn (let [port (tonumber (. arg 1))
                  conn (assert (socket.connect "localhost" port))]
              (: conn :settimeout 0.01)
              (send {:op :clone} conn)
              conn))

(while (not session)
  (receive conn))

(io.write prompt)

((fn repl []
   ;; this is not good; we should use non-blocking read here, but that's Hard
   (let [input (io.read)]
     (when (not input) (os.exit 0))
     (send {:op :eval :code input} conn)
     (while (< 0 (count active-requests))
       (receive conn))
     (io.write prompt)
     (repl))))