use v6;
use JSON::Name:ver<0.0.6+>;
use JSON::OptIn;
use JSON::Fast;

unit module JSON::Unmarshal;

=begin pod
=NAME JSON::Unmarshal

Make JSON from an Object (the opposite of JSON::Marshal)

=SYNOPSIS

    use JSON::Unmarshal;

    class SomeClass {
        has Str $.string;
        has Int $.int;
    }

    my $json = '{ "string" : "string", "int" : 42 }';

    my SomeClass $object = unmarshal($json, SomeClass);

    say $object.string; # -> "string"
    say $object.int;    # -> 42


=DESCRIPTION

This provides a single exported subroutine to create an object from a
JSON representation of an object.

It only initialises the "public" attributes (that is those with accessors
created by declaring them with the '.' twigil. Attributes without acccessors
are ignored.

=head2 C<unmarshal> Routine

C<unmarshal> has the following signatures:

=item C<unmarshal(Str:D $json, Positional $obj, *%)>
=item C<unmarshal(Str:D $json, Associative $obj, *%)>
=item C<unmarshal(Str:D $json, Mu $obj, *%)>
=item C<unmarshal(%json, $obj, *%)>
=item C<unmarshal(@json, $obj, *%)>

The signatures with associative and positional JSON objects are to be used for pre-parsed JSON data obtained from a
different source. For example, this may happen when a framework deserializes it for you.

The following named arguments are supported:

=begin item
B<C<Bool :$opt-in>>

When falsy then all attributes of a class are deserialized. When I<True> then only those marked with C<is json> trait
provided by C<JSON::OptIn> module are taken into account.
=end item

=begin item
B<C<Bool :$warn>>

If set to I<True> then the module will warn about some non-critical problems like unsupported named arguments or keys in
JSON structure for which there no match attributes were found.
=end item

=begin item
B<C<Bool :$die>> or B<C<Bool :$throw>>

This is two aliases of the same attribute with meaning, similar to C<:warn>, but where otherwise a waning would be
issued the module will throw an exception.
=end item

=head2 Manual Unmarshalling

It is also possible to use C<is unmarshalled-by> trait to control how the value is unmarshalled:

    use JSON::Unmarshal

    class SomeClass {
        has Version $.version is unmarshalled-by(-> $v { Version.new($v) });
    }

    my $json = '{ "version" : "0.0.1" }';

    my SomeClass $object = unmarshal($json, SomeClass);

    say $object.version; # -> "v0.0.1"


The trait has two variants, one which takes a Routine as above, the other
a Str representing the name of a method that will be called on the type
object of the attribute type (such as "new",) both are expected to take
the value from the JSON as a single argument.

=INSTALLATION

Assuming you have a working Raku installation you should be able to
install this with *zef* :

=begin code
# From the source directory

zef install .

# Remote installation

zef install JSON::Unmarshal
=end code

=SUPPORT

Suggestions/patches are welcomed via github at

L<https://github.com/raku-community-modules/JSON-Unmarshal>

=head1 COPYRIGHT AND LICENSE

Copyright 2015-2017 Tadeusz Sośnierz
Copyright 2022 Raku Community

This library is free software; you can redistribute it and/or modify it under the Artistic License 2.0.

Please see the LICENCE file in the distribution

=end pod

our class X::CannotUnmarshal is Exception {
    has Attribute:D $.attribute is required;
    has Any:D $.json is required;
    has Mu:U $.type is required;
    has Mu:U $.target is required;
    has Str $.why;
    method message {
        "Cannot unmarshal {$.json.raku} into type '{$.type.^name}' for attribute {$.attribute.name} of '{$.target.^name}'"
        ~ ($.why andthen ": $_" orelse "")
    }
}

our class X::UnusedKeys is Exception {
    has Set:D $.unused-keys is required;
    has Mu:U $.type is required;
    method message {
        my $sfx = $!unused-keys.elems > 1 ?? "s" !! "";
        "No attribute$sfx found in '" ~ $!type.^name ~ "' for JSON key$sfx " ~ $!unused-keys.keys.sort.map("'" ~ * ~ "'").join(", ")
    }
}

enum ErrorMode <EM_IGNORE EM_WARN EM_THROW>;
my class UnmarshallParams {
    has Bool $.opt-in;
    has ErrorMode $.error-mode;
}

role CustomUnmarshaller does JSON::OptIn::OptedInAttribute {
    method unmarshal($value, Mu:U $type) {
        ...
    }
}

role CustomUnmarshallerCode does CustomUnmarshaller {
    has &.unmarshaller is rw;

    method unmarshal($value, Mu:U $) {
        # the dot below is important otherwise it refers
        # to the accessor method
        self.unmarshaller.($value);
    }
}

role CustomUnmarshallerMethod does CustomUnmarshaller {
    has Str $.unmarshaller is rw;
    method unmarshal($value, Mu:U $type) {
        my $meth = self.unmarshaller;
        $type."$meth"($value);
    }
}

multi sub trait_mod:<is> (Attribute $attr, :&unmarshalled-by!) is export {
    $attr does CustomUnmarshallerCode;
    $attr.unmarshaller = &unmarshalled-by;
}

multi sub trait_mod:<is> (Attribute $attr, Str:D :$unmarshalled-by!) is export {
    $attr does CustomUnmarshallerMethod;
    $attr.unmarshaller = $unmarshalled-by;
}

proto sub panic(Any, Mu, |) {*}
multi sub panic($json, Mu \type, X::CannotUnmarshal:D $ex) {
    $ex.rethrow
}
multi sub panic($json, Mu \type, Exception:D $ex) {
    samewith($json, type, $ex.message)
}
multi sub panic($json, Mu \type, Str $why?) {
    X::CannotUnmarshal.new(
        :$json,
        :type(type.WHAT),
        :attribute($*JSON-UNMARSHAL-ATTR),
        :$why,
        :target($*JSON-UNMARSHAL-TYPE) ).throw
}

my sub maybe-nominalize(Mu \obj) is pure is raw {
    obj.HOW.archetypes.nominalizable ?? obj.^nominalize !! obj
}

multi _unmarshal(Any:U, Mu $type) {
    $type;
}

multi _unmarshal(Any:D $json, Int) {
    if $json ~~ Int {
        return Int($json)
    }
    panic($json, Int)
}

multi _unmarshal(Any:D $json, Rat) {
   CATCH {
      default {
         panic($json, Rat, $_);
      }
   }
   return Rat($json);
}

multi _unmarshal(Any:D $json, Numeric) {
    if $json ~~ Numeric {
        return Num($json)
    }
    panic($json, Numeric)
}

multi _unmarshal($json, Str) {
    if $json ~~ Stringy {
        return Str($json)
    }
    else {
        Str;
    }
}

multi _unmarshal(Any:D $json, Bool) {
   CATCH {
      default {
         panic($json, Bool, $_);
      }
   }
   return Bool($json);
}

subset PosNoAccessor of Positional where { ! maybe-nominalize($_).^attributes.first({ .has_accessor || .is_built }) };

multi _unmarshal(%json, PosNoAccessor $obj ) {
    panic(%json, Positional, "type mismatch");
}

# A class-like type is the one we can instantiate and it has at least one public or `is build`-marked attribute.
subset ClassLike of Mu
    where -> Mu \type {
        .HOW.archetypes.nominal
        && .HOW.^can('attributes')
        && .^attributes.first({ $_ ~~ Attribute && (.has_accessor || .is_built) })
            given maybe-nominalize(type)
    };

multi _unmarshal(%json, ClassLike $obj is raw) {
    my %args;
    my $params = $*JSON-UNMARSHALL-PARAMS;
    my SetHash $used-json-keys .= new;
    my \type = $obj.HOW.archetypes.nominalizable ?? $obj.^nominalize !! $obj.WHAT;
    my %local-attrs =  type.^attributes(:local).map({ $_.name => $_.package });
    for type.^attributes -> $attr {
        my $*JSON-UNMARSHAL-ATTR = $attr;
        if %local-attrs{$attr.name}:exists && !(%local-attrs{$attr.name} === $attr.package ) {
            next;
        }
        if $params.opt-in && $attr !~~ JSON::OptIn::OptedInAttribute {
            next;
        }
        my $attr-name = $attr.name.substr(2);
        my $json-name = do if  $attr ~~ JSON::Name::NamedAttribute {
            $attr.json-name;
        }
        else {
            $attr-name;
        }
        if %json{$json-name}:exists {
            my Mu $attr-type := $attr.type;
            my $is-nominalizable = $attr-type.HOW.archetypes.nominalizable;
            $used-json-keys.set($json-name);

            %args{$attr-name} := do if $attr ~~ CustomUnmarshaller {
                $attr.unmarshal(%json{$json-name}, $attr-type)
            }
            elsif $is-nominalizable && $attr-type.HOW.archetypes.coercive && %json{$json-name} ~~ $attr-type
            {
                # No need to unmarshal, coercion will take care of it
                %json{$json-name}
            }
            else {
                _unmarshal(%json{$json-name}, $is-nominalizable ?? $attr-type.^nominalize !! $attr-type)
            }
        }
    }
    if ((my $err-mode = $params.error-mode) != EM_IGNORE)
        && (my $unused-keys = (%json.keys.Set (-) $used-json-keys))
    {
        my $ex = X::UnusedKeys.new: :$unused-keys, :type(type);
        if $err-mode == EM_WARN {
           warn($ex.message)
        }
        else {
           $ex.throw
        }
    }
    type.new(|%args)
}

multi _unmarshal($json, @x) {
    my @ret := Array[@x.of].new;
    for $json.list -> $value {
       my $type = @x.of =:= Any ?? $value.WHAT !! @x.of;
       @ret.append(_unmarshal($value, $type));
    }
    return @ret;
}

multi _unmarshal(%json, %x) {
   my %ret := Hash[%x.of].new;
   for %json.kv -> $key, $value {
      my $type = %x.of =:= Any ?? $value.WHAT !! %x.of;
      %ret{$key} = _unmarshal($value, $type);
   }
   return %ret;
}

multi _unmarshal(Any:D $json, Mu) {
    return $json
}

my sub _unmarshall-context(\obj, % (Bool :$opt-in, Bool :$warn, Bool :die(:$throw), *%extra), &code) is raw {
    if %extra {
        with "Unsupported arguments: " ~ %extra.keys.sort.map("'" ~ * ~ "'").join(", ") {
            $throw ?? die $_ !! warn $_
        }
    }
    my $*JSON-UNMARSHAL-TYPE := obj.WHAT;
    my $*JSON-UNMARSHALL-PARAMS :=
        UnmarshallParams.new: :$opt-in, error-mode => ($throw ?? EM_THROW !! ($warn ?? EM_WARN !! EM_IGNORE));
    code()
}

proto unmarshal(Any:D, |) is export {*}

multi unmarshal(Str:D $json, PosNoAccessor $obj, *%c) {
    _unmarshall-context $obj, %c, {
        my Any \data = from-json($json);
        if data ~~ Positional {
            return @(_unmarshal($_, $obj.of) for @(data));
        } else {
            fail "Unmarshaling to type $obj.^name() requires the json data to be a list of objects.";
        }
    }
}

multi unmarshal(Str:D $json, Associative $obj, *%c) {
    _unmarshall-context $obj, %c, {
        my \data = from-json($json);
        if data ~~ Associative {
            return %(for data.kv -> $key, $value {
                $key => _unmarshal($value, $obj.of)
            })
        } else {
            fail "Unmarshaling to type $obj.^name() requires the json data to be an object.";
        };
    }
}

multi unmarshal(Str:D $json, Mu $obj, *%c) {
    _unmarshall-context $obj, %c, {
        _unmarshal(from-json($json), $obj.WHAT)
    }
}

multi unmarshal(%json, $obj, *%c) {
    _unmarshall-context $obj, %c, {
        _unmarshal(%json, $obj.WHAT)
    }
}

multi unmarshal(@json, $obj, *%c) {
    _unmarshall-context $obj, %c, {
        _unmarshal(@json, $obj.WHAT)
    }
}
# vim: expandtab shiftwidth=4 ft=raku