%%%-------------------------------------------------------------------
%%% @author Ulf Norell
%%% @copyright (C) 2025, QPQ AG
%%% @copyright (C) 2019, Aeternity Anstalt
%%% @doc
%%%     Compiler from Sophia language to Fate intermediate code.
%%% @end
%%%-------------------------------------------------------------------
-module(so_ast_to_fcode).
-vsn("9.0.0").

-export([ast_to_fcode/2, format_fexpr/1]).
-export_type([fcode/0, fexpr/0, fun_def/0]).

-include("so_utils.hrl").

%% -- Type definitions -------------------------------------------------------

-type option() :: term().

-type attribute() :: stateful | payable | pure | private.

-type fun_name() :: {entrypoint, binary()}
                  | {local_fun, [string()]}
                  | event.
-type var_name() :: string().
-type sophia_name() :: [string()].

-type state_reg() :: pos_integer().

-type builtin() :: atom().

-type op() :: '+' | '-' | '*' | '/' | mod | '^' | '++' | '::' |
              '<' | '>' | '=<' | '>=' | '==' | '!=' | '!' |
              'band' | 'bor' | 'bxor' | 'bnot' | '<<' | '>>' |
              map_get | map_get_d | map_set | map_from_list | map_to_list |
              map_delete | map_member | map_size | string_length |
              string_concat | bits_set | bits_clear | bits_test | bits_sum |
              bits_intersection | bits_union | bits_difference |
              contract_to_address | address_to_contract | crypto_verify_sig | crypto_verify_sig_secp256k1 |
              crypto_sha3 | crypto_sha256 | crypto_blake2b | crypto_poseidon |
              crypto_ecverify_secp256k1 | crypto_ecrecover_secp256k1 |
              mcl_bls12_381_g1_neg | mcl_bls12_381_g1_norm | mcl_bls12_381_g1_valid |
              mcl_bls12_381_g1_is_zero | mcl_bls12_381_g1_add | mcl_bls12_381_g1_mul |
              mcl_bls12_381_g2_neg | mcl_bls12_381_g2_norm | mcl_bls12_381_g2_valid |
              mcl_bls12_381_g2_is_zero | mcl_bls12_381_g2_add | mcl_bls12_381_g2_mul |
              mcl_bls12_381_gt_inv | mcl_bls12_381_gt_add | mcl_bls12_381_gt_mul | mcl_bls12_381_gt_pow |
              mcl_bls12_381_gt_is_one | mcl_bls12_381_pairing | mcl_bls12_381_miller_loop | mcl_bls12_381_final_exp |
              mcl_bls12_381_int_to_fr | mcl_bls12_381_int_to_fp | mcl_bls12_381_fr_to_int | mcl_bls12_381_fp_to_int.

-type flit() :: {int, integer()}
              | {string, binary()}
              | {bytes, binary()}
              | {account_pubkey, binary()}
              | {contract_pubkey, binary()}
              | {signature, binary()}
              | {bool, false | true}
              | {contract_code, string()} %% for CREATE, by name
              | {typerep, ftype()}.

-type fann() :: [ {file, so_syntax:ann_file()} |
                  {line, so_syntax:ann_line()} |
                  {col, so_syntax:ann_col()}
                ].

-type fexpr() :: {lit, fann(), flit()}
               | {nil, fann()}
               | {var, fann(), var_name()}
               | {def, fann(), fun_name(), [fexpr()]}
               | {remote, fann(), [ftype()], ftype(), fexpr(), fun_name(), [fexpr()]}
               | {builtin, fann(), builtin(), [fexpr()]}
               | {con, fann(), arities(), tag(), [fexpr()]}
               | {tuple, fann(), [fexpr()]}
               | {proj, fann(), fexpr(), integer()}
               | {set_proj, fann(), fexpr(), integer(), fexpr()}    %% tuple, field, new_value
               | {op, fann(), op(), [fexpr()]}
               | {'let', fann(), var_name(), fexpr(), fexpr()}
               | {funcall, fann(), fexpr(), [fexpr()]}  %% Call to unknown function
               | {closure, fann(), fun_name(), fexpr()}
               | {switch, fann(), fsplit()}
               | {set_state, fann(), state_reg(), fexpr()}
               | {get_state, fann(), state_reg()}
               %% The following (unapplied top-level functions/builtins and
               %% lambdas) are generated by the fcode compiler, but translated
               %% to closures by the lambda lifter.
               | {def_u, fann(), fun_name(), arity()}
               | {remote_u, fann(), [ftype()], ftype(), fexpr(), fun_name()}
               | {builtin_u, fann(), builtin(), arity()}
               | {builtin_u, fann(), builtin(), arity(), [fexpr()]} %% Typerep arguments to be added after normal args.
               | {lam, fann(), [var_name()], fexpr()}.

-type fsplit() :: {split, ftype(), var_name(), [fcase()]}
                | {nosplit, [rename()], fexpr()}.  %% Renames are needed to add DBG_DEF for switch pattern vars

-type fcase() :: {'case', fsplit_pat(), fsplit()}.

-type fsplit_pat()  :: {var, var_name()}
                     | {bool, false | true}
                     | {int, integer()}
                     | {string, binary()}
                     | nil
                     | {'::', var_name(), var_name()}
                     | {con, arities(), tag(), [var_name()]}
                     | {tuple, [var_name()]}
                     | {assign, var_name(), var_name()}.

-type ftype() :: integer
               | boolean
               | string
               | {list, ftype()}
               | {map, ftype(), ftype()}
               | {tuple, [ftype()]}
               | address
               | {bytes, non_neg_integer()}
               | contract
               | name
               | channel
               | bits
               | {variant, [[ftype()]]}
               | {function, [ftype()], ftype()}
               | any
               | {tvar, var_name()}.

-type fun_def() :: #{ attrs  := [attribute() | fann()],
                      args   := [{var_name(), ftype()}],
                      return := ftype(),
                      body   := fexpr() }.

-type functions() :: #{ fun_name() => fun_def() }.

-type fcode() :: #{ contract_name := string(),
                    state_type    := ftype(),
                    state_layout  := state_layout(),
                    event_type    := ftype() | none,
                    functions     := functions(),
                    payable       := boolean() }.

-type type_def() :: fun(([ftype()]) -> ftype()).

-type tag()     :: non_neg_integer().
-type arities() :: [arity()].

-record(con_tag, { tag :: tag(), arities :: arities() }).
-type con_tag() :: #con_tag{}.

-type expr_env()      :: #{ var_name() => fexpr() }.
-type type_env()      :: #{ sophia_name() => type_def() }.
-type fun_env()       :: #{ sophia_name() => {fun_name(), non_neg_integer()} }.
-type con_env()       :: #{ sophia_name() => con_tag() }.
-type child_con_env() :: #{ sophia_name() => fcode() }.
-type builtins()      :: #{ sophia_name() => {builtin(), non_neg_integer() | none | variable} }.

-type rename() :: [{var_name(), var_name()}].

-type context() :: {contract_def, string()}
                 | {namespace, string()}
                 | {abstract_contract, string()}.

-type state_layout() :: {tuple, [state_layout()]} | {reg, state_reg()}.

-type env() :: #{ type_env          := type_env(),
                  fun_env           := fun_env(),
                  con_env           := con_env(),
                  child_con_env     := child_con_env(),
                  event_type        => so_syntax:typedef(),
                  builtins          := builtins(),
                  options           := [option()],
                  state_layout      => state_layout(),
                  context           => context(),
                  vars              => [var_name()],
                  functions         := #{ fun_name() => fun_def() },
                  consts            := #{ var_name() => fexpr() },
                  saved_fresh_names => #{ var_name() => var_name() }
               }.

-define(HASH_BYTES, 32).

%% -- Entrypoint -------------------------------------------------------------

%% Main entrypoint. Takes typed syntax produced by so_ast_infer_types:infer/1,2
%% and produces Fate intermediate code.
-spec ast_to_fcode(so_syntax:ast(), [option()]) -> {env(), fcode()}.
ast_to_fcode(Code, Options) ->
    init_fresh_names(Options),
    {Env1, FCode1} = to_fcode(init_env(Options), Code),
    FCode2 = optimize(FCode1, Options),
    Env2 = Env1#{ child_con_env :=
                      maps:map(
                        fun (_, FC) -> optimize(FC, Options) end,
                        maps:get(child_con_env, Env1)
                       )},
    Env3 =
        case proplists:get_value(debug_info, Options, false) of
            true  -> Env2#{ saved_fresh_names => get(saved_fresh_names) };
            false -> Env2
        end,
    clear_fresh_names(Options),
    {Env3, FCode2}.

-spec optimize(fcode(), [option()]) -> fcode().
optimize(FCode1, Options) ->
    Verbose = lists:member(pp_fcode, Options),
    [io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose],
    FCode2 = optimize_fcode(FCode1, Options),
    [ io:format("-- After optimization --\n~s\n\n", [format_fcode(FCode2)]) || Verbose, FCode2 /= FCode1 ],
    FCode3 = lambda_lift(FCode2),
    [ io:format("-- After lambda lifting --\n~s\n\n", [format_fcode(FCode3)]) || Verbose, FCode3 /= FCode2 ],
    FCode3.

%% -- Environment ------------------------------------------------------------

-spec init_env([option()]) -> env().
init_env(Options) ->
    ChainTxArities = [3, 0, 0, 0, 0, 0, 1, 1, 1, 2, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 2, 0],
    #{ type_env  => init_type_env(),
       fun_env   => #{},
       builtins  => builtins(),
       child_con_env => #{},
       con_env   => #{["None"]        => #con_tag{ tag = 0, arities = [0, 1] },
                      ["Some"]        => #con_tag{ tag = 1, arities = [0, 1] },
                      ["RelativeTTL"] => #con_tag{ tag = 0, arities = [1, 1] },
                      ["FixedTTL"]    => #con_tag{ tag = 1, arities = [1, 1] },
                      ["AENS", "AccountPt"]  => #con_tag{ tag = 0, arities = [1, 1, 1, 1] },
                      ["AENS", "OraclePt"]   => #con_tag{ tag = 1, arities = [1, 1, 1, 1] },
                      ["AENS", "ContractPt"] => #con_tag{ tag = 2, arities = [1, 1, 1, 1] },
                      ["AENS", "ChannelPt"]  => #con_tag{ tag = 3, arities = [1, 1, 1, 1] },
                      ["AENS", "Name"]       => #con_tag{ tag = 0, arities = [3] },
                      ["AENSv2", "AccountPt"]  => #con_tag{ tag = 0, arities = [1, 1, 1, 1, 1] },
                      ["AENSv2", "OraclePt"]   => #con_tag{ tag = 1, arities = [1, 1, 1, 1, 1] },
                      ["AENSv2", "ContractPt"] => #con_tag{ tag = 2, arities = [1, 1, 1, 1, 1] },
                      ["AENSv2", "ChannelPt"]  => #con_tag{ tag = 3, arities = [1, 1, 1, 1, 1] },
                      ["AENSv2", "DataPt"]     => #con_tag{ tag = 4, arities = [1, 1, 1, 1, 1] },
                      ["AENSv2", "Name"]       => #con_tag{ tag = 0, arities = [3] },
                      ["Chain", "GAMetaTx"]               => #con_tag{ tag = 0, arities = [2] },
                      ["Chain", "PayingForTx"]            => #con_tag{ tag = 0, arities = [2] },
                      ["Chain", "SpendTx"]                => #con_tag{ tag = 0, arities = ChainTxArities },
                      ["Chain", "OracleRegisterTx"]       => #con_tag{ tag = 1, arities = ChainTxArities },
                      ["Chain", "OracleQueryTx"]          => #con_tag{ tag = 2, arities = ChainTxArities },
                      ["Chain", "OracleResponseTx"]       => #con_tag{ tag = 3, arities = ChainTxArities },
                      ["Chain", "OracleExtendTx"]         => #con_tag{ tag = 4, arities = ChainTxArities },
                      ["Chain", "NamePreclaimTx"]         => #con_tag{ tag = 5, arities = ChainTxArities },
                      ["Chain", "NameClaimTx"]            => #con_tag{ tag = 6, arities = ChainTxArities },
                      ["Chain", "NameUpdateTx"]           => #con_tag{ tag = 7, arities = ChainTxArities },
                      ["Chain", "NameRevokeTx"]           => #con_tag{ tag = 8, arities = ChainTxArities },
                      ["Chain", "NameTransferTx"]         => #con_tag{ tag = 9, arities = ChainTxArities },
                      ["Chain", "ChannelCreateTx"]        => #con_tag{ tag = 10, arities = ChainTxArities },
                      ["Chain", "ChannelDepositTx"]       => #con_tag{ tag = 11, arities = ChainTxArities },
                      ["Chain", "ChannelWithdrawTx"]      => #con_tag{ tag = 12, arities = ChainTxArities },
                      ["Chain", "ChannelForceProgressTx"] => #con_tag{ tag = 13, arities = ChainTxArities },
                      ["Chain", "ChannelCloseMutualTx"]   => #con_tag{ tag = 14, arities = ChainTxArities },
                      ["Chain", "ChannelCloseSoloTx"]     => #con_tag{ tag = 15, arities = ChainTxArities },
                      ["Chain", "ChannelSlashTx"]         => #con_tag{ tag = 16, arities = ChainTxArities },
                      ["Chain", "ChannelSettleTx"]        => #con_tag{ tag = 17, arities = ChainTxArities },
                      ["Chain", "ChannelSnapshotSoloTx"]  => #con_tag{ tag = 18, arities = ChainTxArities },
                      ["Chain", "ContractCreateTx"]       => #con_tag{ tag = 19, arities = ChainTxArities },
                      ["Chain", "ContractCallTx"]         => #con_tag{ tag = 20, arities = ChainTxArities },
                      ["Chain", "GAAttachTx"]             => #con_tag{ tag = 21, arities = ChainTxArities }
                     },
       options   => Options,
       functions => #{},
       consts    => #{}
    }.

-spec builtins() -> builtins().
builtins() ->
    MkName = fun
               (["AENSv2"], Fun) ->
                 list_to_atom(string:to_lower("AENS_" ++ Fun));
               (NS, Fun) ->
                 list_to_atom(string:to_lower(string:join(NS ++ [Fun], "_")))
             end,
    Scopes = [{[],           [{"abort", 1}, {"require", 2}, {"exit", 1}]},
              {["Chain"],    [{"spend", 2}, {"balance", 1}, {"block_hash", 1}, {"coinbase", none},
                              {"timestamp", none}, {"block_height", none}, {"difficulty", none}, {"gas_limit", none},
                              {"network_id", none}, {"bytecode_hash", 1}, {"create", variable}, {"clone", variable}]},
              {["Contract"], [{"address", none}, {"balance", none}, {"creator", none}]},
              {["Call"],     [{"origin", none}, {"caller", none}, {"value", none}, {"gas_price", none}, {"fee", none},
                              {"gas_left", 0}]},
              {["Oracle"],   [{"register", 4}, {"expiry", 1}, {"query_fee", 1}, {"query", 5}, {"get_question", 2},
                              {"respond", 4}, {"extend", 3}, {"get_answer", 2},
                              {"check", 1}, {"check_query", 2}]},
              {["AENSv2"],   [{"resolve", 2}, {"preclaim", 3}, {"claim", 5}, {"transfer", 4},
                              {"revoke", 3}, {"update", 6}, {"lookup", 1}]},
              {["Map"],      [{"from_list", 1}, {"to_list", 1}, {"lookup", 2},
                              {"lookup_default", 3}, {"delete", 2}, {"member", 2}, {"size", 1}]},
              {["Crypto"],   [{"verify_sig", 3}, {"verify_sig_secp256k1", 3},
                              {"ecverify_secp256k1", 3}, {"ecrecover_secp256k1", 2},
                              {"sha3", 1}, {"sha256", 1}, {"blake2b", 1}, {"poseidon", 2}]},
              {["MCL_BLS12_381"], [{"g1_neg", 1}, {"g1_norm", 1}, {"g1_valid", 1}, {"g1_is_zero", 1}, {"g1_add", 2}, {"g1_mul", 2},
                                   {"g2_neg", 1}, {"g2_norm", 1}, {"g2_valid", 1}, {"g2_is_zero", 1}, {"g2_add", 2}, {"g2_mul", 2},
                                   {"gt_inv", 1}, {"gt_add", 2}, {"gt_mul", 2}, {"gt_pow", 2}, {"gt_is_one", 1},
                                   {"pairing", 2}, {"miller_loop", 2}, {"final_exp", 1},
                                   {"int_to_fr", 1}, {"int_to_fp", 1}, {"fr_to_int", 1}, {"fp_to_int", 1}]},
              {["StringInternal"], [{"length", 1}, {"concat", 2}, {"to_list", 1}, {"from_list", 1}, {"to_bytes", 1},
                                    {"sha3", 1}, {"sha256", 1}, {"blake2b", 1}, {"to_lower", 1}, {"to_upper", 1}]},
              {["Char"],     [{"to_int", 1}, {"from_int", 1}]},
              {["Auth"],     [{"tx_hash", none}, {"tx", none}]},
              {["Bits"],     [{"set", 2}, {"clear", 2}, {"test", 2}, {"sum", 1}, {"intersection", 2},
                              {"union", 2}, {"difference", 2}, {"none", none}, {"all", none}]},
              {["Bytes"],    [{"to_int", 1}, {"to_str", 1}, {"concat", 2}, {"split", 1}, {"to_fixed_size", 1},
                              {"to_any_size", 1}, {"size", 1}, {"split_any", 2}]},
              {["Int"],      [{"to_str", 1}, {"to_bytes", 2}, {"mulmod", 2}]},
              {["Address"],  [{"to_str", 1}, {"to_bytes", 1}, {"to_contract", 1},
                              {"is_contract", 1}, {"is_payable", 1}]}
             ],
    maps:from_list([ {NS ++ [Fun], {MkName(NS, Fun), Arity}}
                     || {NS, Funs} <- Scopes,
                        {Fun, Arity} <- Funs ]).

-spec state_layout(env()) -> state_layout().
state_layout(Env) -> maps:get(state_layout, Env, {reg, 1}).

-define(type(T),       fun([])     -> T end).
-define(type(X, T),    fun([X])    -> T end).
-define(type(X, Y, T), fun([X, Y]) -> T end).

-spec init_type_env() -> type_env().
init_type_env() ->
    BaseTx = {variant, [[address, integer, string], [], [], [], [], [], [string],
                        [{bytes, 32}], [{bytes, 32}], [address, {bytes, 32}], [address],
                        [address, integer], [address, integer], [address],
                        [address], [address], [address], [address], [address],
                        [integer], [address, integer], []]},
    #{ ["int"]             => ?type(integer),
       ["bool"]            => ?type(boolean),
       ["bits"]            => ?type(bits),
       ["char"]            => ?type(integer),
       ["string"]          => ?type(string),
       ["address"]         => ?type(address),
       ["hash"]            => ?type(hash),
       ["signature"]       => ?type(signature),
       ["list"]            => ?type(T, {list, T}),
       ["map"]             => ?type(K, V, {map, K, V}),
       ["option"]          => ?type(T, {variant, [[], [T]]}),
       ["Chain", "ttl"]    => ?type({variant, [[integer], [integer]]}),
       ["AENS", "pointee"] => ?type({variant, [[address], [address], [address], [address]]}),
       ["AENS", "name"]    => ?type({variant, [[address, {variant, [[integer], [integer]]}, {map, string, {variant, [[address], [address], [address], [address]]}}]]}),
       ["AENSv2", "pointee"] => ?type({variant, [[address], [address], [address], [address], [{bytes, any}]]}),
       ["AENSv2", "name"]    => ?type({variant, [[address, {variant, [[integer], [integer]]}, {map, string, {variant, [[address], [address], [address], [address], [{bytes, any}]]}}]]}),
       ["Chain", "ga_meta_tx"]    => ?type({variant, [[address, integer]]}),
       ["Chain", "paying_for_tx"] => ?type({variant, [[address, integer]]}),
       ["Chain", "base_tx"]       => ?type(BaseTx),
       ["MCL_BLS12_381", "fr"] => ?type({bytes, 32}),
       ["MCL_BLS12_381", "fp"] => ?type({bytes, 48})
     }.

-spec is_no_code(env()) -> boolean().
is_no_code(Env) ->
    get_option(no_code, Env).

-spec get_option(atom(), env()) -> option().
get_option(Opt, Env) ->
    get_option(Opt, Env, false).

-spec get_option(atom(), env(), option()) -> option().
get_option(Opt, Env, Default) ->
    proplists:get_value(Opt, maps:get(options, Env, []), Default).

%% -- Compilation ------------------------------------------------------------

-spec to_fcode(env(), so_syntax:ast()) -> {env(), fcode()}.
to_fcode(Env, [{Contract, Attrs, {con, _, Name}, _Impls, Decls}|Rest])
  when ?IS_CONTRACT_HEAD(Contract) ->
    case Contract =:= contract_interface of
        false ->
            #{ builtins := Builtins } = Env,
            ConEnv = maps:remove(state_layout,
                     Env#{ context  => {contract_def, Name},
                           builtins => Builtins#{[Name, "state"]          => {get_state, none},
                                                 [Name, "put"]            => {set_state, 1},
                                                 [Name, "Chain", "event"] => {chain_event, 1}} }),
            #{ functions := PrevFuns } = ConEnv,
            #{ functions := Funs } = Env1 =
                decls_to_fcode(ConEnv, Decls),
            StateType   = lookup_type(Env1, [Name, "state"], [], {tuple, []}),
            EventType   = lookup_type(Env1, [Name, "event"], [], none),
            StateLayout = state_layout(Env1),
            Payable     = proplists:get_value(payable, Attrs, false),
            ConFcode = #{ contract_name => Name,
                          state_type    => StateType,
                          state_layout  => StateLayout,
                          event_type    => EventType,
                          payable       => Payable,
                          functions     => add_init_function(
                                             Env1,
                                             add_event_function(Env1, EventType, Funs)) },
            case Contract of
                contract_main -> [] = Rest, {Env1, ConFcode};
                contract_child ->
                    Env2 = add_child_con(Env1, Name, ConFcode),
                    Env3 = Env2#{ functions := PrevFuns },
                    to_fcode(Env3, Rest)
            end;
        true ->
            Env1 = decls_to_fcode(Env#{ context => {abstract_contract, Name} }, Decls),
            to_fcode(Env1, Rest)
    end;
to_fcode(Env, [{namespace, _, {con, _, Con}, Decls} | Code]) ->
    Env1 = decls_to_fcode(Env#{ context => {namespace, Con} }, Decls),
    to_fcode(Env1, Code).

-spec ann_loc(so_syntax:ann() | fann()) -> {File, Line, Column} when
      File   :: string() | none,
      Line   :: non_neg_integer() | none,
      Column :: non_neg_integer() | none.
ann_loc(Ann) ->
    File = proplists:get_value(file, Ann, none),
    Line = proplists:get_value(line, Ann, none),
    Col  = proplists:get_value(col, Ann, none),
    {File, Line, Col}.

-spec to_fann(so_syntax:ann()) -> fann().
to_fann(Ann) ->
    {File, Line, Col} = ann_loc(Ann),
    [ {Tag, X} ||
        {Tag, X} <- [{file, File}, {line, Line}, {col, Col}],
        X =/= none, X =/= no_file
    ].

-spec get_fann(fexpr()) -> fann().
get_fann(FExpr) -> element(2, FExpr).

-spec decls_to_fcode(env(), [so_syntax:decl()]) -> env().
decls_to_fcode(Env, Decls) ->
    %% First compute mapping from Sophia names to fun_names and add it to the
    %% environment.
    Env1 = add_fun_env(Env, Decls),
    lists:foldl(fun(D, E) -> decl_to_fcode(E, D)
                end, Env1, Decls).

-spec decl_to_fcode(env(), so_syntax:decl()) -> env().
decl_to_fcode(Env, {fun_decl, _, _, _})  -> Env;
decl_to_fcode(Env, {type_def, _Ann, Name, Args, Def}) ->
    typedef_to_fcode(Env, Name, Args, Def);
decl_to_fcode(Env = #{ functions := Funs, options := Options }, {letfun, Ann, {id, _, Name}, Args, Ret, [{guarded, _, [], Body}]}) ->
    Attrs = case proplists:get_value(debug_info, Options, false) of
                true  -> get_attributes_debug(Ann);
                false -> get_attributes(Ann)
            end,
    FName = lookup_fun(Env, qname(Env, Name)),
    FArgs = args_to_fcode(Env, Args),
    FRet  = type_to_fcode(Env, Ret),
    FBody = expr_to_fcode(Env#{ vars => [X || {X, _} <- FArgs] }, Body),
    Def   = #{ attrs  => Attrs,
               args   => FArgs,
               return => FRet,
               body   => FBody },
    NewFuns = Funs#{ FName => Def },
    Env#{ functions := NewFuns };
decl_to_fcode(Env = #{ consts := Consts }, {letval, _, {typed, _, {id, _, X}, _}, Val}) ->
    FVal = expr_to_fcode(Env, Val),
    NewConsts = Consts#{ qname(Env, X) => FVal },
    Env#{ consts := NewConsts }.

-spec typedef_to_fcode(env(), so_syntax:id(), [so_syntax:tvar()], so_syntax:typedef()) -> env().
typedef_to_fcode(Env, {id, _, Name}, Xs, Def) ->
    Q = qname(Env, Name),
    FDef = fun(Args) when length(Args) == length(Xs) ->
                Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)),
                case Def of
                    {record_t, Fields} ->
                        {tuple, [type_to_fcode(Env, Sub, T) || {field_t, _, _, T} <- Fields]};
                    {variant_t, Cons}  ->
                        FCons = [ begin
                                      {constr_t, _, _, Ts} = Con,
                                      [type_to_fcode(Env, Sub, T) || T <- Ts]
                                  end || Con <- Cons ],
                        {variant, FCons};
                    {alias_t, Type}    -> type_to_fcode(Env, Sub, Type)
                end;
              (Args) -> internal_error({type_arity_mismatch, Name, length(Args), length(Xs)})
           end,
    Constructors =
        case Def of
            {variant_t, Cons} ->
                Arities = [ begin
                                {constr_t, _, _, Args} = Con,
                                length(Args)
                            end || Con <- Cons ],
                Tags    = [ #con_tag{ tag = I, arities = Arities } || I <- lists:seq(0, length(Cons) - 1) ],
                GetName = fun({constr_t, _, {con, _, C}, _}) -> C end,
                QName   = fun(Con) -> qname(Env, GetName(Con)) end,
                maps:from_list([ {QName(Con), Tag} || {Tag, Con} <- lists:zip(Tags, Cons) ]);
            _ -> #{}
        end,
    Env1 = bind_constructors(Env, Constructors),
    Env2 = case Name of
             "event" -> Env1#{ event_type => Def };
             _       -> Env1
           end,
    Env3 = compute_state_layout(Env2, Name, FDef),
    bind_type(Env3, Q, FDef).

-spec compute_state_layout(env(), string(), type_def()) -> env().
compute_state_layout(Env = #{ context := {contract_def, _} }, "state", Type) ->
    NoLayout = get_option(no_flatten_state, Env),
    Layout =
        case Type([]) of
            _ when NoLayout -> {reg, 1};
            T ->
                {_, L} = compute_state_layout(1, T),
                L
        end,
    Env#{ state_layout => Layout };
compute_state_layout(Env, _, _) -> Env.

-spec compute_state_layout(state_reg(), ftype() | [ftype()]) -> {state_reg(), state_layout() | [state_layout()]}.
compute_state_layout(R, {tuple, [T]}) ->
    compute_state_layout(R, T);
compute_state_layout(R, {tuple, Ts}) ->
    {R1, Ls} = compute_state_layout(R, Ts),
    {R1, {tuple, Ls}};
compute_state_layout(R, []) ->
    {R, []};
compute_state_layout(R, [H | T]) ->
    {R1, H1} = compute_state_layout(R, H),
    {R2, T1} = compute_state_layout(R1, T),
    {R2, [H1 | T1]};
compute_state_layout(R, _) ->
    {R + 1, {reg, R}}.

-spec type_to_fcode(env(), so_syntax:type()) -> ftype().
type_to_fcode(Env, Type) ->
    type_to_fcode(Env, #{}, Type).

-spec type_to_fcode(env(), #{var_name() => ftype()}, so_syntax:type()) -> ftype().
type_to_fcode(_Env, _Sub, {con, _, _}) -> contract;
type_to_fcode(Env, Sub, {app_t, _, T = {Id, _, _}, Types}) when Id == id; Id == qid ->
    lookup_type(Env, T, [type_to_fcode(Env, Sub, Type) || Type <- Types]);
type_to_fcode(Env, _Sub, T = {Id, _, _}) when Id == id; Id == qid ->
    lookup_type(Env, T, []);
type_to_fcode(Env, Sub, {tuple_t, _, Types}) ->
    {tuple, [type_to_fcode(Env, Sub, T) || T <- Types]};
type_to_fcode(Env, Sub, {record_t, Fields}) ->
    FieldType = fun({field_t, _, _, Ty}) -> Ty end,
    type_to_fcode(Env, Sub, {tuple_t, [], lists:map(FieldType, Fields)});
type_to_fcode(_Env, _Sub, {bytes_t, _, N}) ->
    {bytes, N};
type_to_fcode(_Env, Sub, {tvar, _, X}) ->
    maps:get(X, Sub, {tvar, X});
type_to_fcode(_Env, _Sub, {fun_t, Ann, _, var_args, _}) ->
    fcode_error({var_args_not_set, {id, Ann, "a very suspicious function"}});
type_to_fcode(Env, Sub, {fun_t, _, Named, Args, Res}) ->
    FNamed = [type_to_fcode(Env, Sub, Arg) || {named_arg_t, _, _, Arg, _} <- Named],
    FArgs  = [type_to_fcode(Env, Sub, Arg) || Arg <- Args],
    {function, FNamed ++ FArgs, type_to_fcode(Env, Sub, Res)};
type_to_fcode(Env, Sub, {if_t, _, _, _, Else}) ->
    type_to_fcode(Env, Sub, Else);  %% Hacky: this is only for remote calls, in which case we want the unprotected type
type_to_fcode(_Env, _Sub, Type) ->
    error({todo, Type}).

-spec args_to_fcode(env(), [so_syntax:pat()]) -> [{var_name(), ftype()}].
args_to_fcode(Env, Args) ->
    [ case Arg of
          {id, _, Name} -> {Name, type_to_fcode(Env, Type)};
          _ -> internal_error({bad_arg, Arg})   %% Pattern matching has been moved to the rhs at this point
      end || {typed, _, Arg, Type} <- Args ].

-define(make_let(X, Expr, Body),
        make_let(Expr, fun(X) -> Body end)).

-spec make_let(fexpr(), fun((fexpr()) -> fexpr())) -> fexpr().
make_let(Expr, Body) ->
    case Expr of
        {var, _, _}         -> Body(Expr);
        {lit, _, {int, _}}  -> Body(Expr);
        {lit, _, {bool, _}} -> Body(Expr);
        _                ->
            X = fresh_name(),
            FAnn = get_fann(Expr),
            {'let', FAnn, X, Expr, Body({var, FAnn, X})}
    end.

-spec let_bind(var_name(), fexpr(), fexpr()) -> fexpr().
let_bind(X, {var, _, Y}, Body) -> rename([{X, Y}], Body);
let_bind(X, Expr, Body)        -> {'let', get_fann(Expr), X, Expr, Body}.

-spec let_bind([{var_name(), fexpr()}], fexpr()) -> fexpr().
let_bind(Binds, Body) ->
    lists:foldr(fun({X, E}, Rest) -> let_bind(X, E, Rest) end,
                Body, Binds).

-spec expr_to_fcode(env(), so_syntax:expr()) -> fexpr().
expr_to_fcode(Env, {typed, _, Expr, Type}) ->
    expr_to_fcode(Env, Type, Expr);
expr_to_fcode(Env, Expr) ->
    expr_to_fcode(Env, no_type, Expr).

-spec expr_to_fcode(env(), so_syntax:type() | no_type, so_syntax:expr()) -> fexpr().

%% Literals
expr_to_fcode(_Env, _Type, {int,             Ann, N}) -> {lit, to_fann(Ann), {int, N}};
expr_to_fcode(_Env, _Type, {char,            Ann, N}) -> {lit, to_fann(Ann), {int, N}};
expr_to_fcode(_Env, _Type, {bool,            Ann, B}) -> {lit, to_fann(Ann), {bool, B}};
expr_to_fcode(_Env, _Type, {string,          Ann, S}) -> {lit, to_fann(Ann), {string, S}};
expr_to_fcode(_Env, _Type, {account_pubkey,  Ann, K}) -> {lit, to_fann(Ann), {account_pubkey, K}};
expr_to_fcode(_Env, _Type, {signature,       Ann, K}) -> {lit, to_fann(Ann), {signature, K}};
expr_to_fcode(_Env, _Type, {contract_pubkey, Ann, K}) -> {lit, to_fann(Ann), {contract_pubkey, K}};
expr_to_fcode(_Env, _Type, {bytes,           Ann, B}) -> {lit, to_fann(Ann), {bytes, B}};

%% Variables
expr_to_fcode(Env, _Type, {id, Ann, X})  -> resolve_var(Env, Ann, [X]);
expr_to_fcode(Env, Type, {qid, Ann, X}) ->
    case resolve_var(Env, Ann, X) of
        {builtin_u, FAnn, B = aens_resolve, Ar} ->
            {fun_t, _, _, _, ResType} = Type,
            AensType = type_to_fcode(Env, ResType),
            TypeArgs = [{lit, FAnn, {typerep, AensType}}],
            {builtin_u, FAnn, B, Ar, TypeArgs};
        {builtin_u, FAnn, B = bytes_split, Ar} ->
            {fun_t, _, _, _, {tuple_t, _, [{bytes_t, _, N}, _]}} = Type,
            {builtin_u, FAnn, B, Ar, [{lit, FAnn, {int, N}}]};
        {builtin_u, FAnn, B = bytes_to_fixed_size, Ar} ->
            {fun_t, _, _, _, {app_t, _, {id, _, "option"}, [{bytes_t, _, N}]}} = Type,
            {builtin_u, FAnn, B, Ar, [{lit, FAnn, {int, N}}]};
        Other -> Other
    end;

%% Constructors
expr_to_fcode(Env, Type, {C, _, _} = Con) when C == con; C == qcon ->
    expr_to_fcode(Env, Type, {app, [], {typed, [], Con, Type}, []});
expr_to_fcode(Env, _Type, {app, _, {typed, _, {C, Ann, _} = Con, _}, Args}) when C == con; C == qcon ->
    #con_tag{ tag = I, arities = Arities } = lookup_con(Env, Con),
    Arity = lists:nth(I + 1, Arities),
    case length(Args) == Arity of
        true  -> {con, to_fann(Ann), Arities, I, [expr_to_fcode(Env, Arg) || Arg <- Args]};
        false -> internal_error({constructor_arity_mismatch, Con, length(Args), Arity})
    end;

%% Tuples
expr_to_fcode(Env, _Type, {tuple, _, Es}) ->
    make_tuple([expr_to_fcode(Env, E) || E <- Es]);

%% Records
expr_to_fcode(Env, Type, {proj, Ann, Rec = {typed, _, _, RecType}, {id, _, X}}) ->
    case RecType of
        {con, _, _} when X == "address" ->
            {op, to_fann(Ann), contract_to_address, [expr_to_fcode(Env, Rec)]};
        {con, _, _} ->
            {fun_t, _, _, Args, Ret} = Type,
            FArgs = [type_to_fcode(Env, Arg) || Arg <- Args],
            {remote_u, to_fann(Ann), FArgs, type_to_fcode(Env, Ret), expr_to_fcode(Env, Rec),
                       {entrypoint, list_to_binary(X)}};
        {record_t, [_]} -> expr_to_fcode(Env, Rec); %% Singleton record
        {record_t, _} ->
            {proj, to_fann(Ann), expr_to_fcode(Env, Rec), field_index(RecType, X)}
    end;

expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, [_] = Fields}) ->
    {set, E} = field_value(FieldT, Fields),
    expr_to_fcode(Env, E);
expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Fields}) ->
    FVal = fun(F) ->
             %% All fields are present and no updates
             {set, E} = field_value(F, Fields),
             expr_to_fcode(Env, E)
           end,
    make_tuple(lists:map(FVal, FieldTypes));

expr_to_fcode(Env, {record_t, [FieldT]}, {record, Ann, Rec, Fields}) ->
    case field_value(FieldT, Fields) of
        false       -> expr_to_fcode(Env, Rec);
        {set, E}    -> expr_to_fcode(Env, E);
        {upd, Z, E} -> {'let', to_fann(Ann), Z, expr_to_fcode(Env, Rec), expr_to_fcode(bind_var(Env, Z), E)}
    end;
expr_to_fcode(Env, {record_t, FieldTypes}, {record, Ann, Rec, Fields}) ->
    X    = fresh_name(),
    FAnn = to_fann(Ann),
    Proj = fun(I) -> {proj, FAnn, {var, FAnn, X}, I - 1} end,
    Comp = fun({I, false})       -> Proj(I);
              ({_, {set, E}})    -> expr_to_fcode(Env, E);
              ({I, {upd, Z, E}}) -> {'let', FAnn, Z, Proj(I), expr_to_fcode(bind_var(Env, Z), E)}
           end,
    Set  = fun({_, false}, R)       -> R;
              ({I, {set, E}}, R)    -> {set_proj, FAnn, R, I - 1, expr_to_fcode(Env, E)};
              ({I, {upd, Z, E}}, R) -> {set_proj, FAnn, R, I - 1,
                                        {'let', FAnn, Z, Proj(I), expr_to_fcode(bind_var(Env, Z), E)}}
           end,
    Expand  = length(Fields) == length(FieldTypes),
    Updates = [ {I, field_value(FT, Fields)} || {I, FT} <- indexed(FieldTypes) ],
    Body = case Expand of
             true  -> {tuple, FAnn, lists:map(Comp, Updates)};
             false -> lists:foldr(Set, {var, FAnn, X}, Updates)
           end,
    {'let', FAnn, X, expr_to_fcode(Env, Rec), Body};

%% Lists
expr_to_fcode(Env, _Type, {list, Ann, Es}) ->
    lists:foldr(fun(E, L) -> {op, to_fann(so_syntax:get_ann(E)), '::', [expr_to_fcode(Env, E), L]} end,
                {nil, to_fann(Ann)}, Es);

expr_to_fcode(Env, _Type, {app, As, {'..', _}, [A, B]}) ->
    {def_u, FAnn, FromTo, _} = resolve_fun(Env, As, ["ListInternal", "from_to"]),
    {def, FAnn, FromTo, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]};

expr_to_fcode(Env, _Type, {list_comp, As, Yield, []}) ->
    {op, to_fann(As), '::', [expr_to_fcode(Env, Yield), {nil, to_fann(As)}]};
expr_to_fcode(Env, _Type, {list_comp, As, Yield, [{comprehension_bind, Pat = {typed, _, _, PatType}, BindExpr}|Rest]}) ->
    Arg  = fresh_name(),
    Env1 = bind_var(Env, Arg),
    Bind = {lam, to_fann(As), [Arg], expr_to_fcode(Env1, {switch, As, {typed, As, {id, As, Arg}, PatType},
                                                             [{'case', As, Pat, [{guarded, As, [], {list_comp, As, Yield, Rest}}]},
                                                              {'case', As, {id, As, "_"}, [{guarded, As, [], {list, As, []}}]}]})},
    {def_u, FAnn, FlatMap, _} = resolve_fun(Env, As, ["ListInternal", "flat_map"]),
    {def, FAnn, FlatMap, [Bind, expr_to_fcode(Env, BindExpr)]};
expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Rest]}) ->
    make_if(expr_to_fcode(Env, Cond),
            expr_to_fcode(Env, Type, {list_comp, As, Yield, Rest}),
            {nil, to_fann(As)}
           );
expr_to_fcode(Env, Type, {list_comp, As, Yield, [LV = {letval, _, _, _}|Rest]}) ->
    expr_to_fcode(Env, Type, {block, As, [LV, {list_comp, As, Yield, Rest}]});
expr_to_fcode(Env, Type, {list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}) ->
    expr_to_fcode(Env, Type, {block, As, [LF, {list_comp, As, Yield, Rest}]});

%% Conditionals
expr_to_fcode(Env, _Type, {'if', _, Cond, Then, Else}) ->
    make_if(expr_to_fcode(Env, Cond),
            expr_to_fcode(Env, Then),
            expr_to_fcode(Env, Else));

%% Switch
expr_to_fcode(Env, _, S = {switch, Ann, Expr = {typed, _, E, Type}, Alts}) ->
    Switch = fun(X) ->
                {switch, to_fann(Ann), alts_to_fcode(Env, type_to_fcode(Env, Type), X, Alts, S)}
             end,
    case E of
        {id, _, X} -> Switch(X);
        _ ->
            X = fresh_name(),
            {'let', to_fann(Ann), X, expr_to_fcode(Env, Expr),
             Switch(X)}
    end;

%% Blocks
expr_to_fcode(Env, _Type, {block, _, Stmts}) ->
    stmts_to_fcode(Env, Stmts);

%% Binary operator
expr_to_fcode(Env, _Type, Expr = {app, _, {Op, _}, [_, _]}) when Op == '&&'; Op == '||' ->
    Tree = expr_to_decision_tree(Env, Expr),
    decision_tree_to_fcode(Tree);
expr_to_fcode(Env, Type, {app, Ann, {Op, _}, [A, B]}) when is_atom(Op) ->
    case Op of
        '|>' -> expr_to_fcode(Env, Type, {app, Ann, B, [A]});
        _    -> {op, to_fann(Ann), Op, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]}
    end;
expr_to_fcode(Env, _Type, {app, Ann, {Op, _}, [A]}) when is_atom(Op) ->
    FAnn = to_fann(Ann),
    case Op of
        '-'    -> {op, FAnn, '-', [{lit, FAnn, {int, 0}}, expr_to_fcode(Env, A)]};
        'bnot' -> {op, FAnn, 'bnot', [expr_to_fcode(Env, A)]};
        '!'    -> {op, FAnn, '!', [expr_to_fcode(Env, A)]}
    end;

%% Function calls
expr_to_fcode(Env, _, {app, _, Fun = {typed, Ann, FunE, {fun_t, _, NamedArgsT, ArgsT, Type}}, Args}) ->
    Args1 = get_named_args(NamedArgsT, Args),
    FArgs = [expr_to_fcode(Env, Arg) || Arg <- Args1],
    case expr_to_fcode(Env, Fun) of
        {builtin_u, FAnn, B, _Ar, TypeArgs} -> builtin_to_fcode(state_layout(Env), FAnn, B, FArgs ++ TypeArgs);
        {builtin_u, FAnn, chain_clone, _Ar} ->
            case ArgsT of
                var_args -> fcode_error({var_args_not_set, FunE});
                _ ->
                    %% Here we little cheat on the typechecker, but this inconsistency
                    %% is to be solved in `so_fcode_to_fate:type_to_scode/1`
                    FInitArgsT = gmb_fate_data:make_typerep([type_to_fcode(Env, T) || T <- ArgsT]),
                    builtin_to_fcode(state_layout(Env), FAnn, chain_clone, [{lit, FAnn, FInitArgsT}|FArgs])
            end;
        {builtin_u, FAnn, chain_create, _Ar} ->
            case {ArgsT, Type} of
                {var_args, _} -> fcode_error({var_args_not_set, FunE});
                {_, {con, _, Contract}} ->
                    FInitArgsT = gmb_fate_data:make_typerep([type_to_fcode(Env, T) || T <- ArgsT]),
                    builtin_to_fcode(state_layout(Env), FAnn, chain_create, [{lit, FAnn, {contract_code, Contract}}, {lit, FAnn, FInitArgsT}|FArgs]);
                {_, _} -> fcode_error({not_a_contract_type, Type})
            end;
        {builtin_u, FAnn, B, _Ar}                 -> builtin_to_fcode(state_layout(Env), FAnn, B, FArgs);
        {def_u, FAnn, F, _Ar}                     -> {def, FAnn, F, FArgs};
        {remote_u, FAnn, RArgsT, RRetT, Ct, RFun} -> {remote, FAnn, RArgsT, RRetT, Ct, RFun, FArgs};
        FFun ->
            %% FFun is a closure, with first component the function name and
            %% second component the environment
            FAnn = to_fann(Ann),
            Call = fun(X) -> {funcall, FAnn, {proj, FAnn, {var, FAnn, X}, 0}, [{proj, FAnn, {var, FAnn, X}, 1} | FArgs]} end,
            case FFun of
                {var, _, X} -> Call(X);
                _           -> X = fresh_name(),
                               {'let', FAnn, X, FFun, Call(X)}
            end
    end;

%% Maps
expr_to_fcode(_Env, _Type, {map, Ann, []}) ->
    {builtin, to_fann(Ann), map_empty, []};
expr_to_fcode(Env, Type, {map, Ann, KVs}) ->
    %% Cheaper to do incremental map_update than building the list and doing
    %% map_from_list (I think).
    Fields = [{field, Ann, [{map_get, Ann, K}], V} || {K, V} <- KVs],
    expr_to_fcode(Env, Type, {map, Ann, {map, Ann, []}, Fields});
expr_to_fcode(Env, _Type, {map, _, Map, KVs}) ->
    ?make_let(Map1, expr_to_fcode(Env, Map),
        lists:foldr(fun(Fld, M) ->
                        case Fld of
                            {field, Ann, [{map_get, _, K}], V} ->
                                {op, to_fann(Ann), map_set, [M, expr_to_fcode(Env, K), expr_to_fcode(Env, V)]};
                            {field_upd, Ann, [MapGet], {typed, _, {lam, _, [{arg, _, {id, _, Z}, _}], V}, _}} when element(1, MapGet) == map_get ->
                                [map_get, _, K | Default] = tuple_to_list(MapGet),
                                ?make_let(Key, expr_to_fcode(Env, K),
                                begin
                                    %% Z might shadow Map1 or Key
                                    Z1 = fresh_name(),
                                    FAnn = to_fann(Ann),
                                    GetExpr =
                                        case Default of
                                            []  -> {op, FAnn, map_get, [Map1, Key]};
                                            [D] -> {op, FAnn, map_get_d, [Map1, Key, expr_to_fcode(Env, D)]}
                                        end,
                                    {'let', FAnn, Z1, GetExpr,
                                    {op, FAnn, map_set, [M, Key, rename([{Z, Z1}], expr_to_fcode(bind_var(Env, Z), V))]}}
                                end)
                        end end, Map1, KVs));
expr_to_fcode(Env, _Type, {map_get, Ann, Map, Key}) ->
    {op, to_fann(Ann), map_get, [expr_to_fcode(Env, Map), expr_to_fcode(Env, Key)]};
expr_to_fcode(Env, _Type, {map_get, Ann, Map, Key, Def}) ->
    {op, to_fann(Ann), map_get_d, [expr_to_fcode(Env, Map), expr_to_fcode(Env, Key), expr_to_fcode(Env, Def)]};

expr_to_fcode(Env, _Type, {lam, Ann, Args, Body}) ->
    GetArg = fun({arg, _, {id, _, X}, _}) -> X end,
    Xs = lists:map(GetArg, Args),
    {lam, to_fann(Ann), Xs, expr_to_fcode(bind_vars(Env, Xs), Body)};

expr_to_fcode(_Env, Type, Expr) ->
    error({todo, {Expr, ':', Type}}).

-spec make_if(fexpr(), fexpr(), fexpr()) -> fexpr().
make_if({var, FAnn, X}, Then, Else) ->
    {switch, FAnn, {split, boolean, X,
        [{'case', {bool, false}, {nosplit, [], Else}},
         {'case', {bool, true},  {nosplit, [], Then}}]}};
make_if(Cond, Then, Else) ->
    X = fresh_name(),
    FAnn = get_fann(Cond),
    {'let', FAnn, X, Cond, make_if({var, FAnn, X}, Then, Else)}.

-spec make_if_no_else(fexpr(), fexpr()) -> fexpr().
make_if_no_else({var, FAnn, X}, Then) ->
    {switch, FAnn, {split, boolean, X,
        [{'case', {bool, true},  {nosplit, [], Then}}]}};
make_if_no_else(Cond, Then) ->
    X = fresh_name(),
    FAnn = get_fann(Cond),
    {'let', FAnn, X, Cond, make_if_no_else({var, FAnn, X}, Then)}.

-spec make_tuple([fexpr()]) -> fexpr().
make_tuple([E]) -> E;
make_tuple(Es) -> {tuple, [], Es}.

-spec make_tuple_fpat([fpat()]) -> fpat().
make_tuple_fpat([P]) -> P;
make_tuple_fpat(Ps) -> {tuple, Ps}.

-spec strip_singleton_tuples(ftype()) -> ftype().
strip_singleton_tuples({tuple, _, [T]}) -> strip_singleton_tuples(T);
strip_singleton_tuples(T) -> T.


%% -- Pattern matching --

-spec alts_to_fcode(env(), ftype(), var_name(), [so_syntax:alt()], so_syntax:expr()) -> fsplit().
alts_to_fcode(Env, Type, X, Alts, Switch) ->
    FAlts = remove_guards(Env, Alts, Switch),
    split_tree(Env, [{X, Type}], FAlts).

%% Intermediate format before case trees (fcase() and fsplit()).
-type falt() :: {'case', [fpat()], fexpr()}.
-type fpat() :: {var, var_name()}
              | {bool, false | true}
              | {int, integer()}
              | {string, binary()}
              | nil
              | {'::', fpat(), fpat()}
              | {tuple, [fpat()]}
              | {con, arities(), tag(), [fpat()]}
              | {assign, fpat(), fpat()}.

-spec remove_guards(env(), [so_syntax:alt()], so_syntax:expr()) -> [falt()].
remove_guards(_Env, [], _Switch) ->
    [];
remove_guards(Env, [Alt = {'case', _, _, [{guarded, _, [], _Expr}]} | Rest], Switch) ->
    [alt_to_fcode(Env, Alt) | remove_guards(Env, Rest, Switch)];
remove_guards(Env, [{'case', AnnC, Pat, [{guarded, AnnG, [Guard | Guards], Body} | GuardedBodies]} | Rest], Switch = {switch, Ann, Expr, _}) ->
    FPat = pat_to_fcode(Env, Pat),
    FGuard = expr_to_fcode(bind_vars(Env, pat_vars(FPat)), Guard),
    FBody = expr_to_fcode(bind_vars(Env, pat_vars(FPat)), Body),
    case Guards of
        [] ->
            R = case GuardedBodies of
                    [] -> Rest;
                    _  -> [{'case', AnnC, Pat, GuardedBodies} | Rest]
                end,
            case R of
                [] ->
                    [{'case', [FPat], make_if_no_else(FGuard, FBody)} | remove_guards(Env, Rest, Switch)];
                _ ->
                    FSwitch = expr_to_fcode(Env, {switch, Ann, Expr, R}),
                    [{'case', [FPat], make_if(FGuard, FBody, FSwitch)} | remove_guards(Env, Rest, Switch)]
            end;
        _ ->
            R1 = case GuardedBodies of
                     [] -> [{'case', AnnC, Pat, [{guarded, AnnG, Guards, Body}]} | Rest];
                     _  -> [{'case', AnnC, Pat, [{guarded, AnnG, Guards, Body} | GuardedBodies]} | Rest]
                 end,
            R2 = case GuardedBodies of
                     [] -> Rest;
                     _  -> [{'case', AnnC, Pat, GuardedBodies} | Rest]
                 end,
            FSwitch1 = expr_to_fcode(Env, {switch, Ann, Expr, R1}),
            FSwitch2 = expr_to_fcode(Env, {switch, Ann, Expr, R2}),
            [{'case', [FPat], make_if(FGuard, FSwitch1, FSwitch2)} | remove_guards(Env, Rest, Switch)]
    end.

%% %% Invariant: the number of variables matches the number of patterns in each falt.
-spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fsplit().
split_tree(_Env, _Vars, []) ->
    error(non_exhaustive_patterns); %% TODO: nice error
split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) ->
    case next_split(Pats) of
        false ->
            Xs  = [ X || {X, _} <- Vars ],
            Ys  = [ Y || {var, Y} <- Pats ],
            Ren = [ {Y, X} || {Y, X} <- lists:zip(Ys, Xs), X /= Y, Y /= "_" ],
            %% TODO: Unreachable clauses error
            {nosplit, Ren, rename(Ren, Body)};
        I when is_integer(I) ->
            {Vars0, [{X, Type} | Vars1]} = lists:split(I - 1, Vars),
            Type1 = strip_singleton_tuples(Type),
            SAlts = merge_alts(I, X, [ split_alt(I, A) || A <- Alts ]),
            MakeCase = fun({var, Z}, Split) -> {'case', {var, "_"}, rename_split([{Z, X}], Split)};
                          (SPat, Split)     -> {'case', SPat, Split} end,
            Cases = [ MakeCase(SPat, split_tree(Env, Vars0 ++ split_vars(SPat, Type1) ++ Vars1, FAlts))
                      || {SPat, FAlts} <- SAlts ],
            {split, Type1, X, Cases}
    end.

-spec merge_alts(integer(), var_name(), Alts) -> [{fsplit_pat(), [falt()]}] when
      Alts :: [{fsplit_pat(), falt()}].
merge_alts(I, X, Alts) ->
    merge_alts(I, X, Alts, []).

-spec merge_alts(integer(), var_name(), Alts, Alts) -> [{fsplit_pat(), [falt()]}] when
      Alts :: [{fsplit_pat(), falt()}].
merge_alts(I, X, Alts, Alts1) ->
    lists:foldr(fun(A, As) -> merge_alt(I, X, A, As) end,
                Alts1, Alts).

-spec merge_alt(integer(), var_name(), {fsplit_pat(), falt()}, Alts) -> Alts
        when Alts :: [{fsplit_pat(), [falt()]}].
merge_alt(_, _, {P, A}, []) -> [{P, [A]}];
merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
    Match = fun({var, _}, {var, _})             -> match;
               ({tuple, _}, {tuple, _})         -> match;
               ({bool, B}, {bool, B})           -> match;
               ({int, N},  {int, N})            -> match;
               ({string, S}, {string, S})       -> match;
               (nil, nil)                       -> match;
               ({'::', _, _}, {'::', _, _})     -> match;
               ({con, _, C, _}, {con, _, C, _}) -> match;
               ({con, _, _, _}, {con, _, _, _}) -> mismatch;
               ({var, _}, _)                    -> expand;
               (_, {var, _})                    -> insert;
               (_, _)                           -> mismatch
            end,
    case Match(P, Q) of
        match    -> [{Q, [A | As]} | Rest];
        mismatch -> [{Q, As} | merge_alt(I, X, {P, A}, Rest)];
        expand   ->
            {Before, After} = expand(I, X, P, Q, A),
            merge_alts(I, X, Before, [{Q, As} | merge_alts(I, X, After, Rest)]);
        insert   -> [{P, [A]}, {Q, As} | Rest]
    end.

-spec expand(integer(), var_name(), fsplit_pat(), fsplit_pat(), falt()) -> term().
expand(I, X, P, Q, Case = {'case', Ps, E}) ->
    {Ps0, [{var, Y} | Ps1]} = lists:split(I - 1, Ps),
    {Ps0r, Ren1} = rename_fpats([{Y, X} || Y /= X], Ps0),
    {Ps1r, Ren2} = rename_fpats(Ren1, Ps1),
    E1 = rename(Ren2, E),
    Splice = fun(N) -> Ps0r ++ lists:duplicate(N, {var, "_"}) ++ Ps1r end,
    Type = fun({tuple, Xs})     -> {tuple, length(Xs)};
              ({bool, _})       -> bool;
              ({int, _})        -> int;
              ({string, _})     -> string;
              (nil)             -> list;
              ({'::', _, _})    -> list;
              ({con, As, _, _}) -> {variant, As}
           end,
    MkCase = fun(Pat, Vars) -> {Pat, {'case', Splice(Vars), E1}} end,
    case Type(Q) of
        {tuple, N}    -> {[MkCase(Q, N)], []};
        bool          -> {[MkCase({bool, B}, 0) || B <- [false, true]], []};
        int           -> {[MkCase(Q, 0)], [{P, Case}]};
        string        -> {[MkCase(Q, 0)], [{P, Case}]};
        list          -> {[MkCase(nil, 0), MkCase({'::', fresh_name(), fresh_name()}, 2)], []};
        {variant, As} -> {[MkCase({con, As, C - 1, [fresh_name() || _ <- lists:seq(1, Ar)]}, Ar)
                           || {C, Ar} <- indexed(As)], []}
    end.

-spec split_alt(integer(), falt()) -> {fsplit_pat(), falt()}.
split_alt(I, {'case', Pats, Body}) ->
    {Pats0, [Pat | Pats1]} = lists:split(I - 1, Pats),
    {SPat, InnerPats} = split_pat(Pat),
    {SPat, {'case', Pats0 ++ InnerPats ++ Pats1, Body}}.

-spec split_pat(fpat()) -> {fsplit_pat(), [fpat()]}.
split_pat(P = {var, _}) -> {{var, fresh_name()}, [P]};
split_pat({bool, B})    -> {{bool, B}, []};
split_pat({int, N})     -> {{int, N}, []};
split_pat({string, N})  -> {{string, N}, []};
split_pat(nil)          -> {nil, []};
split_pat({'::', P, Q}) -> {{'::', fresh_name(), fresh_name()}, [P, Q]};
split_pat({con, As, I, Pats}) ->
    Xs = [fresh_name() || _ <- Pats],
    {{con, As, I, Xs}, Pats};
split_pat({assign, X = {var, _}, P}) ->
    {{assign, fresh_name(), fresh_name()}, [X, P]};
split_pat({tuple, Pats}) ->
    Xs = [fresh_name() || _ <- Pats],
    {{tuple, Xs}, Pats}.

-spec split_vars(fsplit_pat(), ftype()) -> [{var_name(), ftype()}].
split_vars({bool, _},   boolean)     -> [];
split_vars({int, _},    integer)     -> [];
split_vars({string, _}, string)      -> [];
split_vars(nil,    {list, _})        -> [];
split_vars({'::', X, Xs}, {list, T}) -> [{X, T}, {Xs, {list, T}}];
split_vars({assign, X, P}, T)        -> [{X, T}, {P, T}];
split_vars({con, _, I, Xs}, {variant, Cons}) ->
    lists:zip(Xs, lists:nth(I + 1, Cons));
split_vars({tuple, Xs}, {tuple, Ts}) ->
    lists:zip(Xs, Ts);
split_vars({var, X}, T) -> [{X, T}].

-spec next_split([fpat()]) -> integer() | false.
next_split(Pats) ->
    IsVar = fun({var, _}) -> true; (_) -> false end,
    case [ I || {I, P} <- indexed(Pats), not IsVar(P) ] of
        []      -> false;
        [I | _] -> I
    end.

-spec alt_to_fcode(env(), so_syntax:alt()) -> falt().
alt_to_fcode(Env, {'case', _, Pat, [{guarded, _, [], Expr}]}) ->
    FPat  = pat_to_fcode(Env, Pat),
    FExpr = expr_to_fcode(bind_vars(Env, pat_vars(FPat)), Expr),
    {'case', [FPat], FExpr}.

-spec pat_to_fcode(env(), so_syntax:pat()) -> fpat().
pat_to_fcode(Env, {typed, _, Pat, Type}) ->
    pat_to_fcode(Env, Type, Pat);
pat_to_fcode(Env, Pat) ->
    pat_to_fcode(Env, no_type, Pat).

-spec pat_to_fcode(env(), so_syntax:type() | no_type, so_syntax:pat()) -> fpat().
pat_to_fcode(_Env, _Type, {id, _, X}) -> {var, X};
pat_to_fcode(Env, _Type, {C, _, _} = Con) when C == con; C == qcon ->
    #con_tag{tag = I, arities = As} = lookup_con(Env, Con),
    {con, As, I, []};
pat_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Pats}) when C == con; C == qcon ->
    #con_tag{tag = I, arities = As} = lookup_con(Env, Con),
    {con, As, I, [pat_to_fcode(Env, Pat) || Pat <- Pats]};
pat_to_fcode(Env, _Type, {tuple, _, Pats}) ->
    make_tuple_fpat([ pat_to_fcode(Env, Pat) || Pat <- Pats ]);
pat_to_fcode(_Env, _Type, {bool, _, B})   -> {bool, B};
pat_to_fcode(_Env, _Type, {int, _, N})    -> {int, N};
pat_to_fcode(_Env, _Type, {char, _, N})   -> {int, N};
pat_to_fcode(_Env, _Type, {string, _, N}) -> {string, N};
pat_to_fcode(Env, _Type, {list, _, Ps}) ->
    lists:foldr(fun(P, Qs) ->
                    {'::', pat_to_fcode(Env, P), Qs}
                end, nil, Ps);
pat_to_fcode(Env, _Type, {app, _, {'::', _}, [P, Q]}) ->
    {'::', pat_to_fcode(Env, P), pat_to_fcode(Env, Q)};
pat_to_fcode(Env, {record_t, Fields}, {record, _, FieldPats}) ->
    FieldPat = fun(F) ->
                    case field_value(F, FieldPats) of
                        false      -> {id, [], "_"};
                        {set, Pat} -> Pat
                        %% {upd, _, _} is impossible in patterns
                    end end,
    make_tuple_fpat([pat_to_fcode(Env, FieldPat(Field))
                || Field <- Fields]);
pat_to_fcode(Env, _Type, {letpat, _, Id = {typed, _, {id, _, _}, _}, Pattern}) ->
    {assign, pat_to_fcode(Env, Id), pat_to_fcode(Env, Pattern)};

pat_to_fcode(_Env, Type, Pat) ->
    error({todo, Pat, ':', Type}).

%% -- Decision trees for boolean operators --

-type decision_tree() :: false
                       | true
                       | {atom, fexpr()}
                       | {'if', fexpr(), decision_tree(), decision_tree()}.

-spec decision_op(so_syntax:op(), decision_tree(), decision_tree()) -> decision_tree().
decision_op('&&', {atom, A}, B) -> {'if', A, B, false};
decision_op('&&', false, _)     -> false;
decision_op('&&', true,  B)     -> B;
decision_op('||', {atom, A}, B) -> {'if', A, true, B};
decision_op('||', false, B)     -> B;
decision_op('||', true,  _)     -> true;
decision_op(Op, {'if', A, Then, Else}, B) ->
    {'if', A, decision_op(Op, Then, B), decision_op(Op, Else, B)}.

-spec expr_to_decision_tree(env(), so_syntax:expr()) -> decision_tree().
expr_to_decision_tree(Env, {app, _Ann, {Op, _}, [A, B]}) when Op == '&&'; Op == '||' ->
    decision_op(Op, expr_to_decision_tree(Env, A), expr_to_decision_tree(Env, B));
expr_to_decision_tree(Env, {typed, _, Expr, _}) -> expr_to_decision_tree(Env, Expr);
expr_to_decision_tree(Env, Expr) ->
    {atom, expr_to_fcode(Env, Expr)}.

-spec decision_tree_to_fcode(decision_tree()) -> fexpr().
decision_tree_to_fcode(false)     -> {lit, [], {bool, false}};
decision_tree_to_fcode(true)      -> {lit, [], {bool, true}};
decision_tree_to_fcode({atom, B}) -> B;
decision_tree_to_fcode({'if', A, Then, Else}) ->
    X = fresh_name(),
    {'let', get_fann(A), X, A,
        {switch, get_fann(A), {split, boolean, X, [{'case', {bool, false}, {nosplit, [], decision_tree_to_fcode(Else)}},
                                                  {'case', {bool, true},  {nosplit, [], decision_tree_to_fcode(Then)}}]}}}.

%% -- Statements --

-spec stmts_to_fcode(env(), [so_syntax:stmt()]) -> fexpr().
stmts_to_fcode(Env, [{letval, Ann, {typed, _, {id, _, X}, _}, Expr} | Stmts]) ->
    {'let', to_fann(Ann), X, expr_to_fcode(Env, Expr), stmts_to_fcode(bind_var(Env, X), Stmts)};
stmts_to_fcode(Env, [{letval, Ann, Pat, Expr} | Stmts]) ->
    expr_to_fcode(Env, {switch, Ann, Expr, [{'case', Ann, Pat, [{guarded, Ann, [], {block, Ann, Stmts}}]}]});
stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, [{guarded, _, [], Expr}]} | Stmts]) ->
    LamArgs = [ case Arg of
                    {typed, Ann1, Id, T} -> {arg, Ann1, Id, T};
                    _ -> internal_error({bad_arg, Arg})   %% pattern matching has been desugared
                end || Arg <- Args ],
    {'let', to_fann(Ann), X, expr_to_fcode(Env, {lam, Ann, LamArgs, Expr}),
               stmts_to_fcode(bind_var(Env, X), Stmts)};
stmts_to_fcode(Env, [Expr]) ->
    expr_to_fcode(Env, Expr);
stmts_to_fcode(Env, [Expr | Stmts]) ->
    {'let', to_fann(so_syntax:get_ann(Expr)), "_", expr_to_fcode(Env, Expr), stmts_to_fcode(Env, Stmts)}.

%% -- Builtins --

-spec op_builtins() -> [BuiltinFun] when
      BuiltinFun :: atom().
op_builtins() ->
    [map_from_list, map_to_list, map_delete, map_member, map_size,
     stringinternal_length, stringinternal_concat, stringinternal_to_list, stringinternal_from_list,
     stringinternal_to_bytes, stringinternal_sha3, stringinternal_sha256, stringinternal_blake2b,
     char_to_int, char_from_int, stringinternal_to_lower, stringinternal_to_upper,
     bits_set, bits_clear, bits_test, bits_sum, bits_intersection, bits_union, bits_difference,
     int_to_str, int_to_bytes, int_mulmod,
     address_to_str, address_to_bytes, address_to_contract,
     crypto_verify_sig, crypto_verify_sig_secp256k1, crypto_sha3, crypto_sha256, crypto_blake2b,
     crypto_poseidon, crypto_ecverify_secp256k1, crypto_ecrecover_secp256k1,
     mcl_bls12_381_g1_neg, mcl_bls12_381_g1_norm, mcl_bls12_381_g1_valid,
     mcl_bls12_381_g1_is_zero, mcl_bls12_381_g1_add, mcl_bls12_381_g1_mul,
     mcl_bls12_381_g2_neg, mcl_bls12_381_g2_norm, mcl_bls12_381_g2_valid,
     mcl_bls12_381_g2_is_zero, mcl_bls12_381_g2_add, mcl_bls12_381_g2_mul,
     mcl_bls12_381_gt_inv, mcl_bls12_381_gt_add, mcl_bls12_381_gt_mul, mcl_bls12_381_gt_pow,
     mcl_bls12_381_gt_is_one, mcl_bls12_381_pairing, mcl_bls12_381_miller_loop, mcl_bls12_381_final_exp,
     mcl_bls12_381_int_to_fr, mcl_bls12_381_int_to_fp, mcl_bls12_381_fr_to_int, mcl_bls12_381_fp_to_int
    ].

-spec set_state(state_layout(), fann(), fexpr()) -> fexpr().
set_state({reg, R}, FAnn, Val) ->
    {set_state, FAnn, R, Val};
set_state({tuple, Ls}, FAnn, Val) ->
    ?make_let(X, Val,
    lists:foldr(fun({I, L}, Code) ->
                    {'let', FAnn, "_", set_state(L, FAnn, {proj, FAnn, X, I - 1}), Code}
                end, {tuple, FAnn, []}, indexed(Ls))).

-spec get_state(state_layout(), fann()) -> fexpr().
get_state({reg, R}, FAnn) ->
    {get_state, FAnn, R};
get_state({tuple, Ls}, FAnn) ->
    {tuple, FAnn, [get_state(L, FAnn) || L <- Ls]}.

-spec builtin_to_fcode(state_layout(), fann(), BuiltinFun, [fexpr()]) -> fexpr() when
      BuiltinFun :: atom().  %% No need to mention all of them
builtin_to_fcode(Layout, FAnn, set_state, [Val]) ->
    set_state(Layout, FAnn, Val);
builtin_to_fcode(Layout, FAnn, get_state, []) ->
    get_state(Layout, FAnn);
builtin_to_fcode(_Layout, FAnn, require, [Cond, Msg]) ->
    make_if(Cond, {tuple, FAnn, []}, {builtin, FAnn, abort, [Msg]});
builtin_to_fcode(_Layout, FAnn, chain_event, [Event]) ->
    {def, FAnn, event, [Event]};
builtin_to_fcode(_Layout, FAnn, map_delete, [Key, Map]) ->
    {op, FAnn, map_delete, [Map, Key]};
builtin_to_fcode(_Layout, FAnn, map_member, [Key, Map]) ->
    {op, FAnn, map_member, [Map, Key]};
builtin_to_fcode(_Layout, FAnn, map_lookup, [Key0, Map0]) ->
    ?make_let(Key, Key0,
    ?make_let(Map, Map0,
     make_if({op, FAnn, map_member, [Map, Key]},
             {con, FAnn, [0, 1], 1, [{op, FAnn, map_get, [Map, Key]}]},
             {con, FAnn, [0, 1], 0, []})));
builtin_to_fcode(_Layout, FAnn, map_lookup_default, [Key, Map, Def]) ->
    {op, FAnn, map_get_d, [Map, Key, Def]};
builtin_to_fcode(_Layout, FAnn, Builtin, Args) ->
    case lists:member(Builtin, op_builtins()) of
        true  -> {op, FAnn, Builtin, Args};
        false -> {builtin, FAnn, Builtin, Args}
    end.

%% -- Init function --

-spec add_init_function(env(), functions()) -> functions().
add_init_function(Env, Funs0) ->
    case is_no_code(Env) of
        true  -> Funs0;
        false ->
            Funs     = add_default_init_function(Env, Funs0),
            InitName = {entrypoint, <<"init">>},
            InitFun  = #{ body := InitBody} = maps:get(InitName, Funs),
            Funs1 = Funs#{ InitName => InitFun#{ return => {tuple, []},
                                                 body   => builtin_to_fcode(state_layout(Env), [], set_state, [InitBody]) } },
            Funs1
    end.

-spec add_default_init_function(env(), functions()) -> functions().
add_default_init_function(_Env, Funs) ->
    InitName = {entrypoint, <<"init">>},
    case maps:get(InitName, Funs, none) of
        none ->
            Funs#{ InitName => #{attrs  => [],
                                 args   => [],
                                 return => {tuple, []},
                                 body   => {tuple, [], []}} };
        _    -> Funs
    end.

%% -- Event function --

-spec add_event_function(env(), ftype() | none, functions()) -> functions().
add_event_function(_Env, none, Funs) -> Funs;
add_event_function(Env, EventFType, Funs) ->
    Funs#{ event => event_function(Env, EventFType) }.

-spec event_function(env(), ftype()) -> fun_def().
event_function(_Env = #{event_type := {variant_t, EventCons}}, EventType = {variant, FCons}) ->
    Cons = [ {Name, I - 1, proplists:get_value(indices, Ann)}
             || {I, {constr_t, Ann, {con, _, Name}, _}} <- indexed(EventCons) ],
    Arities = [length(Ts) || Ts <- FCons],
    Case = fun({Name, Tag, Ixs}) ->
                {ok, HashValue} = eblake2:blake2b(?HASH_BYTES, list_to_binary(Name)),
                Hash = {lit, [], {bytes, HashValue}},
                Vars = [ "arg" ++ integer_to_list(I) || I <- lists:seq(1, length(Ixs)) ],
                IVars = lists:zip(Ixs, Vars),
                Payload =
                    case [ V || {notindexed, V} <- IVars ] of
                        []  -> {lit, [], {string, <<>>}};
                        [V] -> {var, [], V}
                    end,
                Indices = [ {var, [], V} || {indexed, V} <- IVars ],
                Body = {builtin, [], chain_event, [Payload, Hash | Indices]},
                {'case', {con, Arities, Tag, Vars}, {nosplit, [], Body}}
           end,
    #{ attrs  => [private],
       args   => [{"e", EventType}],
       return => {tuple, []},
       body   => {switch, [], {split, EventType, "e", lists:map(Case, Cons)}} }.

%% -- Lambda lifting ---------------------------------------------------------
%% The expr_to_fcode compiler lambda expressions to {lam, Xs, Body}, but in
%% FATE we can only call top-level functions, so we need to lift the lambda to
%% the top-level and replace it with a closure.

-spec lambda_lift(fcode()) -> fcode().
lambda_lift(FCode = #{ functions := Funs, state_layout := StateLayout }) ->
    NewFuns =
        [ {FunName, FunDef}
          || {ParentName, ParentDef} <- maps:to_list(Funs),
             {NewParentDef, Lambdas} <- [lambda_lift_fun(StateLayout, ParentName, ParentDef)],
             {FunName, FunDef} <- [{ParentName, NewParentDef} | maps:to_list(Lambdas)]
        ],
    FCode#{ functions := maps:from_list(NewFuns) }.

-define(lambda_key, '%lambdalifted').

-spec init_lambda_funs() -> term().
init_lambda_funs() -> put(?lambda_key, #{}).

-spec get_lambda_funs() -> term().
get_lambda_funs()  ->
    Lambdas = erase(?lambda_key),
    %% Remove name feed entries and leave only actual functions
    maps:filter(fun({fresh, _}, _) -> false;
                   (_, _) -> true
                end, Lambdas).

-spec add_lambda_fun(fun_name(), fann(), fun_def()) -> fun_name().
add_lambda_fun(Parent, FAnn, Def) ->
    Funs = get(?lambda_key),
    LambdaId = maps:get({fresh, Parent}, Funs, 0),
    Name = lambda_name(FAnn, LambdaId, Parent),
    put(?lambda_key, Funs#{ Name => Def, {fresh, Parent} => LambdaId + 1}),
    Name.

-spec lambda_name(fann(), non_neg_integer(), fun_name()) -> fun_name().
lambda_name(FAnn, Id, PName) ->
    PSName = case PName of
                 {entrypoint, N} -> [binary_to_list(N)];
                 {local_fun, Ns} -> Ns
             end,
    {_File, Line, Col} = ann_loc(FAnn),
    Name = PSName ++
           [ "%lambda"
           , if is_integer(Line) -> integer_to_list(Line); true -> "" end
           , if is_integer(Col) -> integer_to_list(Col); true -> "" end
           , integer_to_list(Id)],
    {local_fun, Name}.

-spec lambda_lift_fun(state_layout(), fun_name(), fun_def()) -> {fun_def(), #{var_name() => term()}}.
lambda_lift_fun(Layout, Name, Def = #{ body := Body }) ->
    %% Not thread safe! We initialize state per functions not to depend on the order in which
    %% functions are processed.
    init_lambda_funs(),
    NewDef = Def#{ body := lambda_lift_expr(Layout, Name, Body) },
    {NewDef, get_lambda_funs()}.

-spec lifted_fun([var_name()], [var_name()], fexpr()) -> fun_def().
lifted_fun([Z], Xs, Body) ->
    #{ attrs  => [private],
       args   => [{Z, any} | [{X, any} || X <- Xs]],
       return => any,
       body   => Body };
lifted_fun(FVs, Xs, Body) ->
    Z    = "%env",
    FAnn = get_fann(Body),
    Proj = fun({I, Y}, E) -> {'let', FAnn, Y, {proj, FAnn, {var, FAnn, Z}, I - 1}, E} end,
    #{ attrs  => [private],
       args   => [{Z, any} | [{X, any} || X <- Xs]],
       return => any,
       body   => lists:foldr(Proj, Body, indexed(FVs))
     }.

-spec make_closure(fun_name(), fann(), [var_name()], [var_name()], fexpr()) -> Closure when
      Closure :: fexpr().
make_closure(ParentName, FAnn, FVs, Xs, Body) ->
    Name  = add_lambda_fun(ParentName, FAnn, lifted_fun(FVs, Xs, Body)),
    Tup = fun([Y]) -> Y; (Ys) -> {tuple, FAnn, Ys} end,
    {closure, FAnn, Name, Tup([{var, FAnn, Y} || Y <- FVs])}.

-spec lambda_lift_expr(state_layout(), fun_name(), fexpr()) -> Closure when
      Closure :: fexpr().
lambda_lift_expr(Layout, Name, L = {lam, FAnn, Xs, Body}) ->
    FVs   = free_vars(L),
    make_closure(Name, FAnn, FVs, Xs, lambda_lift_expr(Layout, Name, Body));
lambda_lift_expr(Layout, Name, UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == builtin_u ->
    [Tag, FAnn, F, Ar | _] = tuple_to_list(UExpr),
    ExtraArgs = case UExpr of
                    {builtin_u, _, _, _, TypeArgs} -> TypeArgs;
                    _                              -> []
                end,
    Xs   = [ lists:concat(["arg", I]) || I <- lists:seq(1, Ar) ],
    Args = [{var, get_fann(UExpr), X} || X <- Xs] ++ ExtraArgs,
    Body = case Tag of
               builtin_u -> builtin_to_fcode(Layout, get_fann(UExpr), F, Args);
               def_u     -> {def, get_fann(UExpr), F, Args}
           end,
    make_closure(Name, FAnn, [], Xs, Body);
lambda_lift_expr(Layout, Name, {remote_u, FAnn, ArgsT, RetT, Ct, F}) ->
    FVs  = free_vars(Ct),
    Ct1  = lambda_lift_expr(Layout, Name, Ct),
    NamedArgCount = 3,
    Xs   = [ lists:concat(["arg", I]) || I <- lists:seq(1, length(ArgsT) + NamedArgCount) ],
    Args = [{var, [], X} || X <- Xs],
    make_closure(Name, FAnn, FVs, Xs, {remote, FAnn, ArgsT, RetT, Ct1, F, Args});
lambda_lift_expr(Layout, Name, Expr) ->
    case Expr of
        {lit, _, _}               -> Expr;
        {nil, _}                  -> Expr;
        {var, _, _}               -> Expr;
        {closure, _, _, _}        -> Expr;
        {def, FAnn, D, As}        -> {def, FAnn, D, lambda_lift_exprs(Layout, Name, As)};
        {builtin, FAnn, B, As}    -> {builtin, FAnn, B, lambda_lift_exprs(Layout, Name, As)};
        {remote, FAnn, ArgsT, RetT, Ct, F, As} -> {remote, FAnn, ArgsT, RetT, lambda_lift_expr(Layout, Name, Ct), F, lambda_lift_exprs(Layout, Name, As)};
        {con, FAnn, Ar, C, As}    -> {con, FAnn, Ar, C, lambda_lift_exprs(Layout, Name, As)};
        {tuple, FAnn, As}         -> {tuple, FAnn, lambda_lift_exprs(Layout, Name, As)};
        {proj, FAnn, A, I}        -> {proj, FAnn, lambda_lift_expr(Layout, Name, A), I};
        {set_proj, FAnn, A, I, B} -> {set_proj, FAnn, lambda_lift_expr(Layout, Name, A), I, lambda_lift_expr(Layout, Name, B)};
        {op, FAnn, Op, As}        -> {op, FAnn, Op, lambda_lift_exprs(Layout, Name, As)};
        {'let', FAnn, X, A, B}    -> {'let', FAnn, X, lambda_lift_expr(Layout, Name, A), lambda_lift_expr(Layout, Name, B)};
        {funcall, FAnn, A, Bs}    -> {funcall, FAnn, lambda_lift_expr(Layout, Name, A), lambda_lift_exprs(Layout, Name, Bs)};
        {set_state, FAnn, R, A}   -> {set_state, FAnn, R, lambda_lift_expr(Layout, Name, A)};
        {get_state, _, _}         -> Expr;
        {switch, FAnn, S}         -> {switch, FAnn, lambda_lift_expr(Layout, Name, S)};
        {split, Type, X, Alts}    -> {split, Type, X, lambda_lift_exprs(Layout, Name, Alts)};
        {nosplit, Rens, A}        -> {nosplit, Rens, lambda_lift_expr(Layout, Name, A)};
        {'case', P, S}            -> {'case', P, lambda_lift_expr(Layout, Name, S)}
    end.

-spec lambda_lift_exprs(state_layout(), fun_name(), [fexpr()]) -> [Closure] when
      Closure :: fexpr().
lambda_lift_exprs(Layout, Name, As) -> [lambda_lift_expr(Layout, Name, A) || A <- As].

%% -- Optimisations ----------------------------------------------------------

%% - Deadcode elimination
%% - Unused variable analysis (replace by _)
%% - Case specialization
%% - Constant propagation
%% - Inlining

-spec optimize_fcode(fcode(), [option()]) -> fcode().
optimize_fcode(Code = #{ functions := Funs }, Options) ->
    Code1 = Code#{ functions := maps:map(fun(Name, Def) -> optimize_fun(Code, Name, Def, Options) end, Funs) },
    eliminate_dead_code(Code1).

-spec optimize_fun(fcode(), fun_name(), fun_def(), [option()]) -> fun_def().
optimize_fun(Fcode, Fun, Def = #{ body := Body0 }, Options) ->
    Inliner              = proplists:get_value(optimize_inliner,                Options, true),
    InlineLocalFunctions = proplists:get_value(optimize_inline_local_functions, Options, true),
    BindSubexpressions   = proplists:get_value(optimize_bind_subexpressions,    Options, true),
    LetFloating          = proplists:get_value(optimize_let_floating,           Options, true),
    Simplifier           = proplists:get_value(optimize_simplifier,             Options, true),
    DropUnusedLets       = proplists:get_value(optimize_drop_unused_lets,       Options, true),

    Body1 = if Inliner              -> inliner   (Fcode, Fun, Body0); true -> Body0 end,
    Body2 = if InlineLocalFunctions -> inline_local_functions(Body1); true -> Body1 end,
    Body3 = if BindSubexpressions   -> bind_subexpressions   (Body2); true -> Body2 end,
    Body4 = if LetFloating          -> let_floating          (Body3); true -> Body3 end,
    Body5 = if Simplifier           -> simplifier            (Body4); true -> Body4 end,
    Body6 = if DropUnusedLets       -> drop_unused_lets      (Body5); true -> Body5 end,

    Def#{ body := Body6 }.

%% --- Inlining ---

-spec inliner(fcode(), fun_name(), fexpr()) -> fexpr().
inliner(Fcode, Fun, {def, _, Fun1, Args} = E) when Fun1 /= Fun ->
    case should_inline(Fcode, Fun1) of
        false -> E;
        true  -> inline(Fcode, Fun1, Args)
    end;
inliner(_Fcode, _Fun, E) -> E.

-spec should_inline(fcode(), fun_name()) -> boolean().
should_inline(_Fcode, _Fun1) -> false == list_to_atom("true").  %% Dialyzer

-spec inline(fcode(), fun_name(), Args) -> Def when
      Args :: [fexpr()],
      Def :: fexpr().
inline(_Fcode, Fun, Args) -> {def, [], Fun, Args}. %% TODO

%% --- Bind subexpressions ---

-define(make_lets(Xs, Es, Body), make_lets(Es, fun(Xs) -> Body end)).

-spec bind_subexpressions(fexpr()) -> fexpr().
bind_subexpressions(Expr) ->
    bottom_up(fun bind_subexpressions/2, Expr).

-spec bind_subexpressions(expr_env(), fexpr()) -> fexpr().
bind_subexpressions(_, {tuple, FAnn, Es}) ->
    ?make_lets(Xs, Es, {tuple, FAnn, Xs});
bind_subexpressions(_, {set_proj, FAnn, A, I, B}) ->
    ?make_lets([X, Y], [A, B], {set_proj, FAnn, X, I, Y});
bind_subexpressions(_, E) -> E.

-spec make_lets([fexpr()], fun(([fexpr()]) -> fexpr())) -> fexpr().
make_lets(Es, Body) -> make_lets(Es, [], Body).

-spec make_lets([fexpr()], [fexpr()], fun(([fexpr()]) -> fexpr())) -> fexpr().
make_lets([], Xs, Body)       -> Body(lists:reverse(Xs));
make_lets([{var, _, _} = E | Es], Xs, Body) ->
    make_lets(Es, [E | Xs], Body);
make_lets([{lit, _, _} = E | Es], Xs, Body) ->
    make_lets(Es, [E | Xs], Body);
make_lets([E | Es], Xs, Body) ->
    ?make_let(X, E, make_lets(Es, [X | Xs], Body)).

%% --- Inline local functions ---

-spec inline_local_functions(fexpr()) -> fexpr().
inline_local_functions(Expr) ->
    bottom_up(fun inline_local_functions/2, Expr).

-spec inline_local_functions(expr_env(), fexpr()) -> fexpr().
inline_local_functions(Env, {funcall, _, {proj, _, {var, _, Y}, 0}, [{proj, _, {var, _, Y}, 1} | Args]} = Expr) ->
    %% TODO: Don't always inline local funs?
    case maps:get(Y, Env, free) of
        {lam, _, Xs, Body} -> let_bind(lists:zip(Xs, Args), Body);
        _                  -> Expr
    end;
inline_local_functions(_, Expr) -> Expr.

%% --- Let-floating ---

-spec let_floating(fexpr()) -> fexpr().
let_floating(Expr) -> bottom_up(fun let_float/2, Expr).

-spec let_float(expr_env(), fexpr()) -> fexpr().
let_float(_, {'let', FAnn, X, E, Body}) ->
    pull_out_let({'let', FAnn, X, {here, E}, Body});
let_float(_, {proj, FAnn, E, I}) ->
    pull_out_let({proj, FAnn, {here, E}, I});
let_float(_, {set_proj, FAnn, E, I, V}) ->
    pull_out_let({set_proj, FAnn, {here, E}, I, {here, V}});
let_float(_, {op, FAnn, Op, Es}) ->
    {Lets, Es1} = pull_out_let([{here, E} || E <- Es]),
    let_bind(Lets, {op, FAnn, Op, Es1});
let_float(_, E) -> E.

-spec pull_out_let(fexpr() | [fexpr()]) -> fexpr() | {Lets, [fexpr()]} when
      Lets :: [{var_name(), fexpr()}].
pull_out_let(Expr) when is_tuple(Expr) ->
    {Lets, Es} = pull_out_let(tuple_to_list(Expr)),
    Inner = list_to_tuple(Es),
    let_bind(Lets, Inner);
pull_out_let(Es) when is_list(Es) ->
    case lists:splitwith(fun({here, _}) -> false; (_) -> true end, Es) of
        {Es0, [{here, E} | Es1]} ->
            case let_view(E) of
                {[], _}    ->
                    {Lets, Es2} = pull_out_let(Es1),
                    {Lets, Es0 ++ [E] ++ Es2};
                {Lets, E1} ->
                    {Lets1, Es2} = pull_out_let(Es1),
                    {Lets ++ Lets1, Es0 ++ [E1] ++ Es2}
            end;
        {_, []} -> {[], Es}
    end.

%% Also renames the variables to fresh names
-spec let_view(fexpr()) -> {Lets, fexpr()} when
      Lets :: [{var_name(), fexpr()}].
let_view(E) -> let_view(E, [], []).

-spec let_view(fexpr(), rename(), Lets) -> {Lets, fexpr()} when
      Lets :: [{var_name(), fexpr()}].
let_view({'let', _, X, E, Rest}, Ren, Lets) ->
    Z = fresh_name(),
    let_view(Rest, [{X, Z} | Ren], [{Z, rename(Ren, E)} | Lets]);
let_view(E, Ren, Lets) ->
    {lists:reverse(Lets), rename(Ren, E)}.

%% --- Simplification ---

-spec simplifier(fexpr()) -> fexpr().
simplifier(Expr) ->
    bottom_up(fun simplify/2, Expr).

-spec simplify(expr_env(), fexpr()) -> fexpr().

%% (e₀, .., en).i ->
%% let _ = e₀ in .. let x = ei in .. let _ = en in x
simplify(_Env, {proj, FAnn, {tuple, _, Es}, I}) ->
    It  = lists:nth(I + 1, Es),
    X   = fresh_name(),
    Dup = safe_to_duplicate(It),
    Val = if Dup -> It; true -> {var, FAnn, X} end,
    lists:foldr(
      fun({J, E}, Rest) when I == J ->
            case Dup of
                true  -> Rest;
                false -> {'let', FAnn, X, E, Rest}
            end;
         ({_, E}, Rest) ->
            case read_only(E) of
                true  -> Rest;
                false -> {'let', FAnn, "_", E, Rest}
            end
        end, Val, indexed(Es));

%% let x = e in .. x.i ..
simplify(Env, {proj, _, Var = {var, _, _}, I} = Expr) ->
    case simpl_proj(Env, I, Var) of
        false -> Expr;
        E     -> E
    end;

simplify(Env, {switch, FAnn, Split}) ->
    case simpl_switch(Env, FAnn, [], Split) of
        nomatch -> {builtin, FAnn, abort, [{lit, FAnn, {string, <<"Incomplete patterns">>}}]};
        Expr    -> Expr
    end;

simplify(_, E) ->
    E.

-spec simpl_proj(expr_env(), integer(), fexpr()) -> fexpr() | false.
simpl_proj(Env, I, Expr) ->
    IfSafe = fun(E) -> case safe_to_duplicate(E) of
                         true -> E;
                         false -> false
                       end end,
    case Expr of
        false                    -> false;
        {var, _, X}              -> simpl_proj(Env, I, maps:get(X, Env, false));
        {tuple, _, Es}           -> IfSafe(lists:nth(I + 1, Es));
        {set_proj, _, _, I, Val} -> IfSafe(Val);
        {set_proj, _, E, _, _}   -> simpl_proj(Env, I, E);
        {proj, _, E, J}          -> simpl_proj(Env, I, simpl_proj(Env, J, E));
        _                        -> false
    end.

-spec get_catchalls([fcase()]) -> [fcase()].
get_catchalls(Alts) ->
    [ C || C = {'case', {var, _}, _} <- Alts ].

%% The scode compiler can't handle multiple catch-alls, so we need to nest them
%% inside each other. Instead of
%%    _ => switch(x) ..
%%    _ => e
%% we do
%%    _ => switch(x)
%%           ..
%%           _ => e
-spec add_catchalls([fcase()], [fcase()]) -> [fcase()].
add_catchalls(Alts, []) -> Alts;
add_catchalls(Alts, Catchalls) ->
    case lists:splitwith(fun({'case', {var, _}, _}) -> false; (_) -> true end,
                         Alts) of
        {Alts1, [C]} -> Alts1 ++ [nest_catchalls([C | Catchalls])];
        {_, []}      -> Alts  ++ [nest_catchalls(Catchalls)]
        %% NOTE: relies on catchalls always being at the end
    end.

-spec nest_catchalls([fcase()]) -> fcase().
nest_catchalls([C = {'case', {var, _}, {nosplit, _, _}} | _]) -> C;
nest_catchalls([{'case', P = {var, _}, {split, Type, X, Alts}} | Catchalls]) ->
    {'case', P, {split, Type, X, add_catchalls(Alts, Catchalls)}}.

-spec simpl_switch(expr_env(), fann(), [fcase()], fsplit()) -> fexpr() | nomatch.
simpl_switch(_Env, _FAnn, _, {nosplit, _, E}) -> E;
simpl_switch(Env, FAnn, Catchalls, {split, Type, X, Alts}) ->
    Alts1 = add_catchalls(Alts, Catchalls),
    Stuck = {switch, FAnn, {split, Type, X, Alts1}},
    case constructor_form(Env, {var, [], X}) of
        false -> Stuck;
        E     -> simpl_case(Env, E, Alts1)
    end.

-spec simpl_case(expr_env(), fexpr(), [fcase()]) -> fexpr() | nomatch.
simpl_case(_, _, []) -> nomatch;
simpl_case(Env, E, [{'case', Pat, Body} | Alts]) ->
    case match_pat(Pat, E) of
        false -> simpl_case(Env, E, Alts);
        Binds ->
            Env1 = maps:merge(Env, maps:from_list(Binds)),
            case simpl_switch(Env1, get_fann(E), get_catchalls(Alts), Body) of
                nomatch -> simpl_case(Env, E, Alts);
                Body1   -> let_bind(Binds, Body1)
            end
    end.

-spec match_pat(fsplit_pat(), fexpr()) -> false | [{var_name(), fexpr()}].
match_pat({tuple, Xs}, {tuple, _, Es})         -> lists:zip(Xs, Es);
match_pat({con, _, C, Xs}, {con, _, _, C, Es}) -> lists:zip(Xs, Es);
match_pat(L, {lit, _, L})                      -> [];
match_pat(nil, {nil, _})                       -> [];
match_pat({'::', X, Y}, {op, _, '::', [A, B]}) -> [{X, A}, {Y, B}];
match_pat({var, X}, E)                         -> [{X, E}];
match_pat({assign, X, P}, E)                   -> [{X, E}, {P, E}];
match_pat(_, _)                                -> false.

-spec constructor_form(expr_env(), fexpr()) -> fexpr() | false.
constructor_form(Env, Expr) ->
    case Expr of
        {var, _, X} ->
            case maps:get(X, Env, free) of
                free -> false;
                E    -> constructor_form(Env, E)    %% TODO: shadowing?
            end;
        {set_proj, _, E, I, V} ->
            case constructor_form(Env, E) of
                {tuple, FAnn, Es} -> {tuple, FAnn, setnth(I + 1, V, Es)};
                _                 -> false
            end;
        {proj, _, E, I} ->
            case constructor_form(Env, E) of
                {tuple, _, Es} -> constructor_form(Env, lists:nth(I + 1, Es));
                _              -> false
            end;
        {con, _, _, _, _} -> Expr;
        {tuple, _, _}     -> Expr;
        {lit, _, _}       -> Expr;
        {nil, _}          -> Expr;
        {op, _, '::', _}  -> Expr;
        _                 -> false
    end.

%% --- Drop unused lets ---

-spec drop_unused_lets(fexpr()) -> fexpr().
drop_unused_lets(Expr) -> bottom_up(fun drop_unused_lets/2, Expr).

-spec drop_unused_lets(expr_env(), fexpr()) -> fexpr().
drop_unused_lets(_, {'let', FAnn, X, E, Body} = Expr) ->
    case {read_only(E), not lists:member(X, free_vars(Body))} of
        {true, true}  -> Body;
        {false, true} -> {'let', FAnn, "_", E, Body};
        _             -> Expr
    end;
drop_unused_lets(_, Expr) -> Expr.

%% -- Static analysis --------------------------------------------------------

-spec safe_to_duplicate(fexpr()) -> boolean().
safe_to_duplicate({lit, _, _})    -> true;
safe_to_duplicate({var, _, _})    -> true;
safe_to_duplicate({nil, _})       -> true;
safe_to_duplicate({tuple, _, []}) -> true;
safe_to_duplicate(_)              -> false.

-spec read_only(fexpr() | fsplit() | fcase() | [fexpr()] | [fcase()]) -> boolean().
read_only({lit, _, _})                -> true;
read_only({var, _, _})                -> true;
read_only({nil, _})                   -> true;
read_only({con, _, _, _, Es})         -> read_only(Es);
read_only({tuple, _, Es})             -> read_only(Es);
read_only({proj, _, E, _})            -> read_only(E);
read_only({set_proj, _, A, _, B})     -> read_only([A, B]);
read_only({op, _, _, Es})             -> read_only(Es);
read_only({get_state, _, _})          -> true;
read_only({set_state, _, _, _})       -> false;
read_only({def_u, _, _, _})           -> true;
read_only({remote_u, _, _, _, _, _})  -> true;
read_only({builtin_u, _, _, _})       -> true;
read_only({builtin_u, _, _, _, _})    -> true;
read_only({lam, _, _, _})             -> true;
read_only({def, _, _, _})             -> false; %% TODO: purity analysis
read_only({remote, _, _, _, _, _, _}) -> false;
read_only({builtin, _, _, _})         -> false; %% TODO: some builtins are
read_only({switch, _, Split})         -> read_only(Split);
read_only({split, _, _, Cases})       -> read_only(Cases);
read_only({nosplit, _, E})            -> read_only(E);
read_only({'case', _, Split})         -> read_only(Split);
read_only({'let', _, _, A, B})        -> read_only([A, B]);
read_only({funcall, _, _, _})         -> false;
read_only({closure, _, _, _})         -> internal_error(no_closures_here);
read_only(Es) when is_list(Es)        -> lists:all(fun read_only/1, Es).

%% --- Deadcode elimination ---

-spec eliminate_dead_code(fcode()) -> fcode().
eliminate_dead_code(Code = #{ functions := Funs }) ->
    UsedFuns = used_functions(Funs),
    Code#{ functions := maps:filter(fun(Name, _) -> maps:is_key(Name, UsedFuns) end,
                                    Funs) }.

-spec used_functions(functions()) -> Used when
      Used :: #{ fun_name() => true }.
used_functions(Funs) ->
    Exported = [ Fun || {Fun, #{ attrs := Attrs }} <- maps:to_list(Funs),
                        not lists:member(private, Attrs) ],
    used_functions(#{}, Exported, Funs).

-spec used_functions(Used, [fun_name()], functions()) -> Used when
      Used :: #{ fun_name() => true }.
used_functions(Used, [], _) -> Used;
used_functions(Used, [Name | Rest], Defs) ->
    case maps:is_key(Name, Used) of
        true  -> used_functions(Used, Rest, Defs);
        false ->
            New =
                case maps:get(Name, Defs, undef) of
                    undef             -> []; %% We might be compiling a stub
                    #{ body := Body } -> used_defs(Body)
                end,
            used_functions(Used#{ Name => true }, New ++ Rest, Defs)
    end.

%% -- Helper functions -------------------------------------------------------

%% -- Types --

-spec lookup_type(env(), so_syntax:id() | so_syntax:qid() | sophia_name(), [ftype()]) -> ftype().
lookup_type(Env, {id, _, Name}, Args) ->
    lookup_type(Env, [Name], Args);
lookup_type(Env, {qid, _, Name}, Args) ->
    lookup_type(Env, Name, Args);
lookup_type(Env, Name, Args) ->
    case lookup_type(Env, Name, Args, not_found) of
        not_found -> internal_error({unknown_type, Name});
        Type      -> Type
    end.

-spec lookup_type(env(), sophia_name(), [ftype()], ftype() | A) -> ftype() | A.
lookup_type(#{ type_env := TypeEnv }, Name, Args, Default) ->
    case maps:get(Name, TypeEnv, false) of
        false -> Default;
        Fun   -> Fun(Args)
    end.

-spec bind_type(env(), sophia_name(), type_def()) -> env().
bind_type(Env = #{type_env := TEnv}, Q, FDef) ->
    Env#{ type_env := TEnv#{ Q => FDef } }.

-spec bind_constructors(env(), con_env()) -> env().
bind_constructors(Env = #{ con_env := ConEnv }, NewCons) ->
    Env#{ con_env := maps:merge(ConEnv, NewCons) }.

%% -- Names --

-spec add_child_con(env(), sophia_name(), fcode()) -> env().
add_child_con(Env = #{child_con_env := CEnv}, Name, Fcode) ->
    Env#{ child_con_env := CEnv#{Name => Fcode} }.

-spec add_fun_env(env(), [so_syntax:decl()]) -> env().
add_fun_env(Env = #{ context := {abstract_contract, _} }, _) -> Env;  %% no functions from abstract contracts
add_fun_env(Env = #{ fun_env := FunEnv }, Decls) ->
    Entry = fun({letfun, Ann, {id, _, Name}, Args, _, _}) ->
                [{qname(Env, Name), {make_fun_name(Env, Ann, Name), length(Args)}}];
               ({fun_decl, Ann, {id, _, Name}, {fun_t, _, _, ArgTypes, _}}) ->
                [{qname(Env, Name), {make_fun_name(Env, Ann, Name), length(ArgTypes)}}];
               (_) -> [] end,
    FunEnv1 = maps:from_list(lists:flatmap(Entry, Decls)),
    Env#{ fun_env := maps:merge(FunEnv, FunEnv1) }.

-spec make_fun_name(env(), so_syntax:ann(), so_syntax:name()) -> fun_name().
make_fun_name(#{ context := Context }, Ann, Name) ->
    Entrypoint = proplists:get_value(entrypoint, Ann, false),
    case Context of
        {contract_def, Main} ->
            if Entrypoint     -> {entrypoint, list_to_binary(Name)};
               true           -> {local_fun, [Main, Name]}
            end;
        {namespace, Lib} ->
            {local_fun, [Lib, Name]}
    end.

-spec current_namespace(env()) -> string().
current_namespace(#{ context := Cxt }) ->
    case Cxt of
        {abstract_contract, Con} -> Con;
        {contract_def, Con}     -> Con;
        {namespace, NS}          -> NS
    end.

-spec qname(env(), string()) -> sophia_name().
qname(Env, Name) ->
    [current_namespace(Env), Name].

-spec lookup_fun(env(), sophia_name()) -> fun_name().
lookup_fun(#{ fun_env := FunEnv }, Name) ->
    case maps:get(Name, FunEnv, false) of
        false      -> error({unbound_name, Name});
        {FName, _} -> FName
    end.

-spec lookup_con(env(), so_syntax:con() | so_syntax:qcon() | sophia_name()) -> con_tag().
lookup_con(Env, {con, _, Con})  -> lookup_con(Env, [Con]);
lookup_con(Env, {qcon, _, Con}) -> lookup_con(Env, Con);
lookup_con(#{ con_env := ConEnv }, Con) ->
    case maps:get(Con, ConEnv, false) of
        false -> error({unbound_constructor, Con});
        Tag   -> Tag
    end.

-spec bind_vars(env(), [var_name()]) -> env().
bind_vars(Env, Xs) ->
    lists:foldl(fun(X, E) -> bind_var(E, X) end, Env, Xs).

-spec bind_var(env(), var_name()) -> env().
bind_var(Env = #{ vars := Vars }, X) -> Env#{ vars := [X | Vars] }.

-spec resolve_var(env(), so_syntax:ann(), [so_syntax:name()]) -> fexpr().
resolve_var(#{ vars := Vars } = Env, Ann, [X]) ->
    case lists:member(X, Vars) of
        true  -> {var, to_fann(Ann), X};
        false ->
            case resolve_const(Env, [X]) of
                false -> resolve_fun(Env, Ann, [X]);
                Const -> Const
            end
    end;
resolve_var(Env, Ann, Q) ->
    case resolve_const(Env, Q) of
        false -> resolve_fun(Env, Ann, Q);
        Const -> Const
    end.

resolve_const(#{ consts := Consts }, Q) ->
    case maps:get(Q, Consts, not_found) of
        not_found -> false;
        Val       -> Val
    end.

-spec resolve_fun(env(), so_syntax:ann(), [so_syntax:name()]) -> fexpr().
resolve_fun(#{ fun_env := Funs, builtins := Builtin } = Env, Ann, Q) ->
    case {maps:get(Q, Funs, not_found), maps:get(Q, Builtin, not_found)} of
        {not_found, not_found} -> internal_error({unbound_variable, Q});
        {_, {B, none}}         -> builtin_to_fcode(state_layout(Env), to_fann(Ann), B, []);
        {_, {B, Ar}}           -> {builtin_u, to_fann(Ann), B, Ar};
        {{Fun, Ar}, _}         -> {def_u, to_fann(Ann), Fun, Ar}
    end.

-spec init_fresh_names([option()]) -> term().
init_fresh_names(Options) ->
    proplists:get_value(debug_info, Options, false) andalso init_saved_fresh_names(),
    put('%fresh', 0).

-spec clear_fresh_names([option()]) -> term().
clear_fresh_names(Options) ->
    proplists:get_value(debug_info, Options, false) andalso clear_saved_fresh_names(),
    erase('%fresh').

-spec init_saved_fresh_names() -> term().
init_saved_fresh_names() ->
    put(saved_fresh_names, #{}).

-spec clear_saved_fresh_names() -> term().
clear_saved_fresh_names() ->
    erase(saved_fresh_names).

-spec fresh_name_save(string()) -> var_name().
fresh_name_save(Name) ->
    Fresh = fresh_name(),
    case get(saved_fresh_names) of
        undefined -> ok;
        Old       -> put(saved_fresh_names, Old#{Fresh => Name})
    end,
    Fresh.

-spec fresh_name() -> var_name().
fresh_name() -> fresh_name("%").

-spec fresh_name(string()) -> var_name().
fresh_name(Prefix) ->
    N = get('%fresh'),
    put('%fresh', N + 1),
    lists:concat([Prefix, N]).

-spec pat_vars(fpat()) -> [var_name()].
pat_vars({var, X})            -> [X || X /= "_"];
pat_vars({bool, _})           -> [];
pat_vars({int, _})            -> [];
pat_vars({string, _})         -> [];
pat_vars(nil)                 -> [];
pat_vars({'::', P, Q})        -> pat_vars(P) ++ pat_vars(Q);
pat_vars({tuple, Ps})         -> pat_vars(Ps);
pat_vars({con, _, _, Ps})     -> pat_vars(Ps);
pat_vars({assign, X, P})      -> pat_vars(X) ++ pat_vars(P);
pat_vars(Ps) when is_list(Ps) -> [X || P <- Ps, X <- pat_vars(P)].

-spec fsplit_pat_vars(fsplit_pat()) -> [var_name()].
fsplit_pat_vars({var, X})        -> [X || X /= "_"];
fsplit_pat_vars({bool, _})       -> [];
fsplit_pat_vars({int, _})        -> [];
fsplit_pat_vars({string, _})     -> [];
fsplit_pat_vars(nil)             -> [];
fsplit_pat_vars({'::', P, Q})    -> [P, Q];
fsplit_pat_vars({tuple, Ps})     -> Ps;
fsplit_pat_vars({con, _, _, Ps}) -> Ps;
fsplit_pat_vars({assign, X, P})  -> [X, P].

-spec free_vars(fexpr() | [fexpr()]) -> [var_name()].
free_vars(Xs) when is_list(Xs) ->
    lists:umerge([ free_vars(X) || X <- Xs ]);
free_vars(Expr) ->
    case Expr of
        {var, _, X}             -> [X];
        {lit, _, _}             -> [];
        {nil, _}                -> [];
        {def, _, _, As}         -> free_vars(As);
        {def_u, _, _, _}        -> [];
        {remote, _, _, _, Ct, _, As} -> free_vars([Ct | As]);
        {remote_u, _, _, _, Ct, _}   -> free_vars(Ct);
        {builtin, _, _, As}     -> free_vars(As);
        {builtin_u, _, _, _}    -> [];
        {builtin_u, _, _, _, _} -> [];     %% Typereps are always literals
        {con, _, _, _, As}      -> free_vars(As);
        {tuple, _, As}          -> free_vars(As);
        {proj, _, A, _}         -> free_vars(A);
        {set_proj, _, A, _, B}  -> free_vars([A, B]);
        {op, _, _, As}          -> free_vars(As);
        {'let', FAnn, X, A, B}  -> free_vars([A, {lam, FAnn, [X], B}]);
        {funcall, _, A, Bs}     -> free_vars([A | Bs]);
        {set_state, _, _, A}    -> free_vars(A);
        {get_state, _, _}       -> [];
        {lam, _, Xs, B}         -> free_vars(B) -- lists:sort(Xs);
        {closure, _, _, A}      -> free_vars(A);
        {switch, _, A}          -> free_vars(A);
        {split, _, X, As}       -> free_vars([{var, [], X} | As]);
        {nosplit, _, A}         -> free_vars(A);
        {'case', P, A}          -> free_vars(A) -- lists:sort(fsplit_pat_vars(P))
    end.

-spec used_defs(fexpr() | [fexpr()]) -> [fun_name()].
used_defs(Xs) when is_list(Xs) ->
    lists:umerge([ used_defs(X) || X <- Xs ]);
used_defs(Expr) ->
    case Expr of
        {var, _, _}              -> [];
        {lit, _, _}              -> [];
        {nil, _}                 -> [];
        {def, _, F, As}          -> lists:umerge([F], used_defs(As));
        {def_u, _, F, _}         -> [F];
        {remote, _, _, _, Ct, _, As} -> used_defs([Ct | As]);
        {remote_u, _, _, _, Ct, _}   -> used_defs(Ct);
        {builtin, _, _, As}     -> used_defs(As);
        {builtin_u, _, _, _}    -> [];
        {builtin_u, _, _, _, _} -> [];
        {con, _, _, _, As}      -> used_defs(As);
        {tuple, _, As}          -> used_defs(As);
        {proj, _, A, _}         -> used_defs(A);
        {set_proj, _, A, _, B}  -> used_defs([A, B]);
        {op, _, _, As}          -> used_defs(As);
        {'let', _, _, A, B}     -> used_defs([A, B]);
        {funcall, _, A, Bs}     -> used_defs([A | Bs]);
        {set_state, _, _, A}    -> used_defs(A);
        {get_state, _, _}       -> [];
        {lam, _, _, B}          -> used_defs(B);
        {closure, _, F, A}      -> lists:umerge([F], used_defs(A));
        {switch, _, A}          -> used_defs(A);
        {split, _, _, As}       -> used_defs(As);
        {nosplit, _, A}         -> used_defs(A);
        {'case', _, A}          -> used_defs(A)
    end.

-spec bottom_up(Fun, fexpr()) -> fexpr() when
      Fun :: fun((expr_env(), fexpr()) -> fexpr()).
bottom_up(F, Expr) -> bottom_up(F, #{}, Expr).

-spec bottom_up(Fun, expr_env(), fexpr()) -> fexpr() when
      Fun :: fun((expr_env(), fexpr()) -> fexpr()).
bottom_up(F, Env, Expr) ->
    F(Env, case Expr of
        {lit, _, _}                      -> Expr;
        {nil, _}                         -> Expr;
        {var, _, _}                      -> Expr;
        {def, FAnn, D, Es}                -> {def, FAnn, D, [bottom_up(F, Env, E) || E <- Es]};
        {def_u, _, _, _}                 -> Expr;
        {builtin, FAnn, B, Es}            -> {builtin, FAnn, B, [bottom_up(F, Env, E) || E <- Es]};
        {builtin_u, _, _, _}             -> Expr;
        {builtin_u, _, _, _, _}          -> Expr;
        {remote, FAnn, ArgsT, RetT, Ct, Fun, Es} -> {remote,   FAnn, ArgsT, RetT, bottom_up(F, Env, Ct), Fun, [bottom_up(F, Env, E) || E <- Es]};
        {remote_u, FAnn, ArgsT, RetT, Ct, Fun}   -> {remote_u, FAnn, ArgsT, RetT, bottom_up(F, Env, Ct), Fun};
        {con, FAnn, Ar, I, Es}            -> {con, FAnn, Ar, I, [bottom_up(F, Env, E) || E <- Es]};
        {tuple, FAnn, Es}                 -> {tuple, FAnn, [bottom_up(F, Env, E) || E <- Es]};
        {proj, FAnn, E, I}                -> {proj, FAnn, bottom_up(F, Env, E), I};
        {set_proj, FAnn, R, I, E}         -> {set_proj, FAnn, bottom_up(F, Env, R), I, bottom_up(F, Env, E)};
        {op, FAnn, Op, Es}                -> {op, FAnn, Op, [bottom_up(F, Env, E) || E <- Es]};
        {funcall, FAnn, Fun, Es}          -> {funcall, FAnn, bottom_up(F, Env, Fun), [bottom_up(F, Env, E) || E <- Es]};
        {set_state, FAnn, R, E}           -> {set_state, FAnn, R, bottom_up(F, Env, E)};
        {get_state, _, _}                -> Expr;
        {closure, FAnn, F, CEnv}          -> {closure, FAnn, F, bottom_up(F, Env, CEnv)};
        {switch, FAnn, Split}             -> {switch, FAnn, bottom_up(F, Env, Split)};
        {lam, FAnn, Xs, B}                -> {lam, FAnn, Xs, bottom_up(F, Env, B)};
        {'let', FAnn, X, E, Body}         ->
            E1 = bottom_up(F, Env, E),
            %% Always freshen user variables to avoid shadowing issues.
            ShouldFreshen = fun(Y = "%" ++ _) -> maps:is_key(Y, Env);
                               (_)            -> true end,
            case ShouldFreshen(X) of
                true ->
                    Z = fresh_name_save(X),
                    Env1 = Env#{ Z => E1 },
                    {'let', FAnn, Z, E1, bottom_up(F, Env1, rename([{X, Z}], Body))};
                false ->
                    Env1 = Env#{ X => E1 },
                    {'let', FAnn, X, E1, bottom_up(F, Env1, Body)}
            end;
        {split, Type, X, Cases}          -> {split, Type, X, [bottom_up(F, Env, Case) || Case <- Cases]};
        {nosplit, Rens, E}               -> {nosplit, Rens, bottom_up(F, Env, E)};
        {'case', Pat, Split}             -> {'case', Pat, bottom_up(F, Env, Split)}
    end).

-spec get_named_args([so_syntax:named_arg_t()], [so_syntax:arg_expr()]) -> [so_syntax:expr()].
get_named_args(NamedArgsT, Args) ->
    IsNamed = fun({named_arg, _, _, _}) -> true;
                 (_) -> false end,
    {Named, NotNamed} = lists:partition(IsNamed, Args),
    NamedArgs = [get_named_arg(NamedArg, Named) || NamedArg <- NamedArgsT],
    NamedArgs ++ NotNamed.

-spec get_named_arg(so_syntax:named_arg_t(), [so_syntax:arg_expr()]) -> so_syntax:expr().
get_named_arg({named_arg_t, _, {id, _, Name}, _, Default}, Args) ->
    case [ Val || {named_arg, _, {id, _, X}, Val} <- Args, X == Name ] of
        [Val] -> Val;
        []    -> Default
    end.

%% -- Renaming --

-spec rename(rename(), fexpr()) -> fexpr().
rename(Ren, Expr) ->
    case Expr of
        {lit, _, _}               -> Expr;
        {nil, FAnn}               -> {nil, FAnn};
        {var, FAnn, X}            -> {var, FAnn, rename_var(Ren, X)};
        {def, FAnn, D, Es}        -> {def, FAnn, D, [rename(Ren, E) || E <- Es]};
        {def_u, _, _, _}          -> Expr;
        {builtin, FAnn, B, Es}    -> {builtin, FAnn, B, [rename(Ren, E) || E <- Es]};
        {builtin_u, _, _, _}      -> Expr;
        {builtin_u, _, _, _, _}   -> Expr;
        {remote, FAnn, ArgsT, RetT, Ct, F, Es} -> {remote,   FAnn, ArgsT, RetT, rename(Ren, Ct), F, [rename(Ren, E) || E <- Es]};
        {remote_u, FAnn, ArgsT, RetT, Ct, F}   -> {remote_u, FAnn, ArgsT, RetT, rename(Ren, Ct), F};
        {con, FAnn, Ar, I, Es}    -> {con, FAnn, Ar, I, [rename(Ren, E) || E <- Es]};
        {tuple, FAnn, Es}         -> {tuple, FAnn, [rename(Ren, E) || E <- Es]};
        {proj, FAnn, E, I}        -> {proj, FAnn, rename(Ren, E), I};
        {set_proj, FAnn, R, I, E} -> {set_proj, FAnn, rename(Ren, R), I, rename(Ren, E)};
        {op, FAnn, Op, Es}        -> {op, FAnn, Op, [rename(Ren, E) || E <- Es]};
        {funcall, FAnn, Fun, Es}  -> {funcall, FAnn, rename(Ren, Fun), [rename(Ren, E) || E <- Es]};
        {set_state, FAnn, R, E}   -> {set_state, FAnn, R, rename(Ren, E)};
        {get_state, _, _}         -> Expr;
        {closure, FAnn, F, Env}   -> {closure, FAnn, F, rename(Ren, Env)};
        {switch, FAnn, Split}     -> {switch, FAnn, rename_split(Ren, Split)};
        {lam, FAnn, Xs, B} ->
            {Zs, Ren1} = rename_bindings(Ren, Xs),
            {lam, FAnn, Zs, rename(Ren1, B)};
        {'let', FAnn, X, E, Body} ->
            {Z, Ren1} = rename_binding(Ren, X),
            {'let', FAnn, Z, rename(Ren, E), rename(Ren1, Body)}
    end.

-spec rename_var(rename(), var_name()) -> var_name().
rename_var(Ren, X) -> proplists:get_value(X, Ren, X).

-spec rename_binding(rename(), var_name()) -> {var_name(), rename()}.
rename_binding(Ren, X) ->
    Ren1 = lists:keydelete(X, 1, Ren),
    case lists:keymember(X, 2, Ren) of
        false -> {X, Ren1};
        true  ->
            Z = fresh_name(),
            {Z, [{X, Z} | Ren1]}
    end.

-spec rename_bindings(rename(), [var_name()]) -> {[var_name()], rename()}.
rename_bindings(Ren, []) -> {[], Ren};
rename_bindings(Ren, [X | Xs]) ->
    {Z, Ren1}  = rename_binding(Ren, X),
    {Zs, Ren2} = rename_bindings(Ren1, Xs),
    {[Z | Zs], Ren2}.

-spec rename_fpats(rename(), [fpat()]) -> {[fpat()], rename()}.
rename_fpats(Ren, []) -> {[], Ren};
rename_fpats(Ren, [P | Ps]) ->
    {Q, Ren1}  = rename_fpat(Ren, P),
    {Qs, Ren2} = rename_fpats(Ren1, Ps),
    {[Q | Qs], Ren2}.

-spec rename_fpat(rename(), fpat()) -> {fpat(), rename()}.
rename_fpat(Ren, P = {bool, _})   -> {P, Ren};
rename_fpat(Ren, P = {int, _})    -> {P, Ren};
rename_fpat(Ren, P = {string, _}) -> {P, Ren};
rename_fpat(Ren, P = nil)         -> {P, Ren};
rename_fpat(Ren, {'::', P, Q})    ->
    {P1, Ren1} = rename_fpat(Ren, P),
    {Q1, Ren2} = rename_fpat(Ren1, Q),
    {{'::', P1, Q1}, Ren2};
rename_fpat(Ren, {var, X}) ->
    {Z, Ren1} = rename_binding(Ren, X),
    {{var, Z}, Ren1};
rename_fpat(Ren, {con, Ar, C, Ps}) ->
    {Ps1, Ren1} = rename_fpats(Ren, Ps),
    {{con, Ar, C, Ps1}, Ren1};
rename_fpat(Ren, {tuple, Ps}) ->
    {Ps1, Ren1} = rename_fpats(Ren, Ps),
    {{tuple, Ps1}, Ren1}.

-spec rename_spat(rename(), fsplit_pat()) -> {fsplit_pat(), rename()}.
rename_spat(Ren, P = {bool, _})   -> {P, Ren};
rename_spat(Ren, P = {int, _})    -> {P, Ren};
rename_spat(Ren, P = {string, _}) -> {P, Ren};
rename_spat(Ren, P = nil)         -> {P, Ren};
rename_spat(Ren, {'::', X, Y}) ->
    {X1, Ren1} = rename_binding(Ren, X),
    {Y1, Ren2} = rename_binding(Ren1, Y),
    {{'::', X1, Y1}, Ren2};
rename_spat(Ren, {var, X}) ->
    {Z, Ren1} = rename_binding(Ren, X),
    {{var, Z}, Ren1};
rename_spat(Ren, {con, Ar, C, Xs}) ->
    {Zs, Ren1} = rename_bindings(Ren, Xs),
    {{con, Ar, C, Zs}, Ren1};
rename_spat(Ren, {tuple, Xs}) ->
    {Zs, Ren1} = rename_bindings(Ren, Xs),
    {{tuple, Zs}, Ren1};
rename_spat(Ren, {assign, X, P}) ->
    {X1, Ren1} = rename_binding(Ren, X),
    {P1, Ren2} = rename_binding(Ren1, P),
    {{assign, X1, P1}, Ren2}.

-spec rename_split(rename(), fsplit()) -> fsplit().
rename_split(Ren, {split, Type, X, Cases}) ->
    {split, Type, rename_var(Ren, X), [rename_case(Ren, C) || C <- Cases]};
rename_split(Ren, {nosplit, Rens, E}) ->
    {nosplit, update_rename(Rens, Ren), rename(Ren, E)}.

-spec rename_case(rename(), fcase()) -> fcase().
rename_case(Ren, {'case', Pat, Split}) ->
    {Pat1, Ren1} = rename_spat(Ren, Pat),
    {'case', Pat1, rename_split(Ren1, Split)}.

-spec update_rename(rename(), rename()) -> rename().
update_rename(OldRen, NewRen) ->
    [{Name, proplists:get_value(Rename, NewRen, Rename)} || {Name, Rename} <- OldRen].

%% -- Records --

-spec field_index(so_syntax:typedef(), so_syntax:name()) -> integer().
field_index({record_t, Fields}, X) ->
    IsX = fun({field_t, _, {id, _, Y}, _}) -> X == Y end,
    [I] = [ I || {I, Field} <- indexed(Fields), IsX(Field) ],
    I - 1.  %% Tuples are 0-indexed

-spec field_value(so_syntax:field_t(), [so_syntax:field(so_syntax:pat())]) -> Res when
      Res :: {upd, so_syntax:name(), Expr} | {set, Expr} | false,
      Expr :: so_syntax:expr().
field_value({field_t, _, {id, _, X}, _}, Fields) ->
    View = fun({field, _, [{proj, _, {id, _, Y}}], E})    -> {Y, {set, E}};
              ({field_upd, _, [{proj, _, {id, _, Y}}],
                {typed, _, {lam, _, [{arg, _, {id, _, Z}, _}], E}, _}}) -> {Y, {upd, Z, E}} end,
    case [Upd || {Y, Upd} <- lists:map(View, Fields), X == Y] of
        [Upd] -> Upd;
        []    -> false
    end.

%% -- Attributes --

-spec get_attributes(so_syntax:ann()) -> [stateful | payable | private].
get_attributes(Ann) ->
    [stateful || proplists:get_value(stateful, Ann, false)] ++
    [payable  || proplists:get_value(payable, Ann, false)] ++
    [private  || not proplists:get_value(entrypoint, Ann, false)].

-spec get_attributes_debug(so_syntax:ann()) -> [stateful | payable | private | fann()].
get_attributes_debug(Ann) ->
    get_attributes(Ann) ++ to_fann(Ann).

%% -- Basic utilities --

-spec indexed([term()]) -> [{integer(), term()}].
indexed(Xs) ->
    lists:zip(lists:seq(1, length(Xs)), Xs).

-spec setnth(integer(), Val, Vals) -> Vals when
      Val :: term(),
      Vals :: [Val].
setnth(I, X, Xs) ->
    {Ys, [_ | Zs]} = lists:split(I - 1, Xs),
    Ys ++ [X] ++ Zs.

-dialyzer({nowarn_function, [fcode_error/1, internal_error/1]}).

-spec fcode_error(string()) -> no_return().
fcode_error(Error) ->
    Pos = so_errors:pos(0, 0),
    Msg = lists:flatten(io_lib:format("Unknown error: ~p\n", [Error])),
    so_errors:throw(so_errors:new(code_error, Pos, Msg)).

-spec internal_error(string()) -> no_return().
internal_error(Error) ->
    Msg = lists:flatten(io_lib:format("~p\n", [Error])),
    so_errors:throw(so_errors:new(internal_error, so_errors:pos(0, 0), Msg)).

%% -- Pretty printing --------------------------------------------------------

-spec format_fcode(fcode()) -> string().
format_fcode(#{ functions := Funs }) ->
    prettypr:format(format_funs(Funs)).

-spec format_funs(functions()) -> prettypr:document().
format_funs(Funs) ->
    pp_above(
      [ pp_fun(Name, Def) || {Name, Def} <- maps:to_list(Funs) ]).

-spec format_fexpr(fexpr()) -> string().
format_fexpr(E) ->
    prettypr:format(pp_fexpr(E)).

-spec pp_fun(fun_name(), fun_def()) -> prettypr:document().
pp_fun(Name, #{ args := Args, return := Return, body := Body }) ->
    PPArg = fun({X, T}) -> pp_beside([pp_text(X), pp_text(" : "), pp_ftype(T)]) end,
    pp_above(pp_beside([pp_text("function "), pp_fun_name(Name),
               pp_parens(pp_par(pp_punctuate(pp_text(","), [PPArg(Arg) || Arg <- Args]))),
               pp_text(" : "), pp_ftype(Return), pp_text(" =")]),
             prettypr:nest(2, pp_fexpr(Body))).

-spec pp_fun_name(fun_name()) -> prettypr:document().
pp_fun_name(event)           -> pp_text(event);
pp_fun_name({entrypoint, E}) -> pp_text(binary_to_list(E));
pp_fun_name({local_fun, Q})  -> pp_text(string:join(Q, ".")).

-spec pp_text(binary() | string() | atom() | integer()) -> prettypr:document().
pp_text(<<>>) -> prettypr:text("\"\"");
pp_text(Bin) when is_binary(Bin) -> prettypr:text(lists:flatten(io_lib:format("~p", [binary_to_list(Bin)])));
pp_text(S) when is_list(S) -> prettypr:text(lists:concat([S]));
pp_text(A) when is_atom(A) -> prettypr:text(atom_to_list(A));
pp_text(N) when is_integer(N) -> prettypr:text(integer_to_list(N)).

-spec pp_int(integer()) -> prettypr:document().
pp_int(I) -> prettypr:text(integer_to_list(I)).

-spec pp_beside([prettypr:document()]) -> prettypr:document().
pp_beside([])       -> prettypr:empty();
pp_beside([X])      -> X;
pp_beside([X | Xs]) -> pp_beside(X, pp_beside(Xs)).

-spec pp_beside(prettypr:document(), prettypr:document()) -> prettypr:document().
pp_beside(A, B) -> prettypr:beside(A, B).

-spec pp_above([prettypr:document()]) -> prettypr:document().
pp_above([])       -> prettypr:empty();
pp_above([X])      -> X;
pp_above([X | Xs]) -> pp_above(X, pp_above(Xs)).

-spec pp_above(prettypr:document(), prettypr:document()) -> prettypr:document().
pp_above(A, B) -> prettypr:above(A, B).

-spec pp_parens(prettypr:document()) -> prettypr:document().
pp_parens(Doc) -> pp_beside([pp_text("("), Doc, pp_text(")")]).

-spec pp_braces(prettypr:document()) -> prettypr:document().
pp_braces(Doc) -> pp_beside([pp_text("{"), Doc, pp_text("}")]).

-spec pp_punctuate(prettypr:document(), [prettypr:document()]) -> [prettypr:document()].
pp_punctuate(_Sep, [])      -> [];
pp_punctuate(_Sep, [X])     -> [X];
pp_punctuate(Sep, [X | Xs]) -> [pp_beside(X, Sep) | pp_punctuate(Sep, Xs)].

-spec pp_par([prettypr:document()]) -> prettypr:document().
pp_par([]) -> prettypr:empty();
pp_par(Xs) -> prettypr:par(Xs).

-spec pp_fexpr(fexpr()) -> prettypr:document().
pp_fexpr({lit, _, {typerep, T}}) ->
    pp_ftype(T);
pp_fexpr({lit, _, {contract_code, Contract}}) ->
    pp_beside(pp_text("contract "), pp_text(Contract));
pp_fexpr({lit, _, {Tag, Lit}}) ->
    so_pretty:expr({Tag, [], Lit});
pp_fexpr({nil, _}) ->
    pp_text("[]");
pp_fexpr({var, _, X}) -> pp_text(X);
pp_fexpr({def, Fun}) -> pp_fun_name(Fun);
pp_fexpr({def_u, _, Fun, Ar}) ->
    pp_beside([pp_fun_name(Fun), pp_text("/"), pp_int(Ar)]);
pp_fexpr({def, _, Fun, Args}) ->
    pp_call(pp_fun_name(Fun), Args);
pp_fexpr({con, _, _, I, []}) ->
    pp_beside(pp_text("C"), pp_int(I));
pp_fexpr({con, FAnn, _, I, Es}) ->
    pp_beside(pp_fexpr({con, FAnn, [], I, []}),
              pp_fexpr({tuple, FAnn, Es}));
pp_fexpr({tuple, _, Es}) ->
    pp_parens(pp_par(pp_punctuate(pp_text(","), [pp_fexpr(E) || E <- Es])));
pp_fexpr({proj, _, E, I}) ->
    pp_beside([pp_fexpr(E), pp_text("."), pp_int(I)]);
pp_fexpr({lam, FAnn, Xs, A}) ->
    pp_par([pp_fexpr({tuple, FAnn, [{var, FAnn, X} || X <- Xs]}), pp_text("=>"),
            prettypr:nest(2, pp_fexpr(A))]);
pp_fexpr({closure, _, Fun, ClEnv}) ->
    FVs = case ClEnv of
              {tuple, _, Xs} -> Xs;
              {var, _, _}    -> [ClEnv]
          end,
    pp_call(pp_text("__CLOSURE__"), [{def, Fun} | FVs]);
pp_fexpr({set_proj, _, E, I, A}) ->
    pp_beside(pp_fexpr(E), pp_braces(pp_beside([pp_int(I), pp_text(" = "), pp_fexpr(A)])));
pp_fexpr({op, _, Op, [A, B] = Args}) ->
    case is_infix(Op) of
        false -> pp_call(pp_text(Op), Args);
        true  -> pp_parens(pp_par([pp_fexpr(A), pp_text(Op), pp_fexpr(B)]))
    end;
pp_fexpr({op, _, Op, [A] = Args}) ->
    case is_infix(Op) of
        false -> pp_call(pp_text(Op), Args);
        true  -> pp_parens(pp_par([pp_text(Op), pp_fexpr(A)]))
    end;
pp_fexpr({op, FAnn, Op, As}) ->
    pp_beside(pp_text(Op), pp_fexpr({tuple, FAnn, As}));
pp_fexpr({'let', _, _, _, _} = Expr) ->
    Lets = fun Lets({'let', _, Y, C, D}) ->
                        {Ls, E} = Lets(D),
                        {[{Y, C} | Ls], E};
               Lets(E) -> {[], E} end,
    {Ls, Body} = Lets(Expr),
    pp_parens(
      pp_par(
        [ pp_beside([ pp_text("let "),
                      pp_above([ pp_par([pp_text(X), pp_text("="), prettypr:nest(2, pp_fexpr(A))]) || {X, A} <- Ls ]),
                      pp_text(" in ") ]),
          pp_fexpr(Body) ]));
pp_fexpr({builtin_u, _, B, N}) ->
    pp_beside([pp_text(B), pp_text("/"), pp_text(N)]);
pp_fexpr({builtin_u, FAnn, B, N, TypeArgs}) ->
    pp_beside([pp_text(B), pp_text("@"), pp_fexpr({tuple, FAnn, TypeArgs}), pp_text("/"), pp_text(N)]);
pp_fexpr({builtin, _, B, As}) ->
    pp_call(pp_text(B), As);
pp_fexpr({remote_u, _, ArgsT, RetT, Ct, Fun}) ->
    pp_beside([pp_fexpr(Ct), pp_text("."), pp_fun_name(Fun), pp_text(" : "), pp_ftype({function, ArgsT, RetT})]);
pp_fexpr({remote, _, ArgsT, RetT, Ct, Fun, As}) ->
    pp_call(pp_parens(pp_beside([pp_fexpr(Ct), pp_text("."), pp_fun_name(Fun), pp_text(" : "), pp_ftype({function, ArgsT, RetT})])), As);
pp_fexpr({funcall, _, Fun, As}) ->
    pp_call(pp_fexpr(Fun), As);
pp_fexpr({set_state, FAnn, R, A}) ->
    pp_call(pp_text("set_state"), [{lit, FAnn, {int, R}}, A]);
pp_fexpr({get_state, FAnn, R}) ->
    pp_call(pp_text("get_state"), [{lit, FAnn, {int, R}}]);
pp_fexpr({switch, _, Split}) -> pp_split(Split).

-spec pp_call(prettypr:document(), [fexpr()]) -> prettypr:document().
pp_call(Fun, Args) ->
    pp_beside(Fun, pp_fexpr({tuple, [], Args})).

-spec pp_call_t(string(), [ftype()]) -> prettypr:document().
pp_call_t(Fun, Args) ->
    pp_beside(pp_text(Fun), pp_ftype({tuple, Args})).

-spec pp_ftype(ftype()) -> any().
pp_ftype(T) when is_atom(T) -> pp_text(T);
pp_ftype(any) -> pp_text("_");
pp_ftype({tvar, X}) -> pp_text(X);
pp_ftype({bytes, N}) -> pp_call(pp_text("bytes"), [{lit, [], {int, N}}]);
pp_ftype({tuple, Ts}) ->
    pp_parens(pp_par(pp_punctuate(pp_text(" *"), [pp_ftype(T) || T <- Ts])));
pp_ftype({list, T}) ->
    pp_call_t("list", [T]);
pp_ftype({function, Args, Res}) ->
    pp_par([pp_ftype({tuple, Args}), pp_text("=>"), pp_ftype(Res)]);
pp_ftype({map, Key, Val}) ->
    pp_call_t("map", [Key, Val]);
pp_ftype({variant, Cons}) ->
    pp_par(
    pp_punctuate(pp_text(" |"),
                 [ case Args of
                     [] -> pp_fexpr({con, [], [], I - 1, []});
                     _  -> pp_beside(pp_fexpr({con, [], [], I - 1, []}), pp_ftype({tuple, Args}))
                   end || {I, Args} <- indexed(Cons)]));
pp_ftype([]) ->
    %% NOTE: This could happen with `{typerep, []}` since `[]` is not a ftype().
    %% TODO: It would be better to make sure that `{typerep, []}` does not arrive here.
    pp_text("[]").

-spec pp_split(fsplit()) -> prettypr:document().
pp_split({nosplit, _, E}) -> pp_fexpr(E);
pp_split({split, Type, X, Alts}) ->
    pp_above([pp_beside([pp_text("switch("), pp_text(X), pp_text(" : "), pp_ftype(Type), pp_text(")")])] ++
             [prettypr:nest(2, pp_case(Alt)) || Alt <- Alts]).

-spec pp_case(fcase()) -> prettypr:document().
pp_case({'case', Pat, Split}) ->
    prettypr:sep([pp_beside(pp_pat(Pat), pp_text(" =>")),
                  prettypr:nest(2, pp_split(Split))]).

-spec pp_pat(fsplit_pat()) -> prettypr:document().
pp_pat({tuple, Xs})            -> pp_fexpr({tuple, [], [{var, [], X} || X <- Xs]});
pp_pat({'::', X, Xs})          -> pp_fexpr({op, [], '::', [{var, [], X}, {var, [], Xs}]});
pp_pat({con, As, I, Xs})       -> pp_fexpr({con, [], As, I, [{var, [], X} || X <- Xs]});
pp_pat({var, X})               -> pp_fexpr({var, [], X});
pp_pat(P = {Tag, _}) when Tag == bool; Tag == int; Tag == string
                               -> pp_fexpr({lit, [], P});
pp_pat(nil)                    -> pp_fexpr({nil, []});
pp_pat({assign, X, Y})         -> pp_beside([pp_text(X), pp_text(" = "), pp_text(Y)]).

-spec is_infix(op()) -> boolean().
is_infix(Op) ->
    C = hd(atom_to_list(Op)),
    C < $a orelse C > $z.
