Json.Decode.Completion.elm

module Json.Decode.Completion exposing (..)

import Json.Decode as Decode exposing (Value)
import Json.Encode as Encode
import List.Nonempty as Nonempty exposing (Nonempty(Nonempty))


type alias Errors =
    Nonempty Error


type Error
    = BadField String Errors
    | BadIndex Int Errors
    | BadOneOf (List Errors)
    | Failure String Value


type Warning
    = InField String (Nonempty Warning)
    | AtIndex Int (Nonempty Warning)
    | UnusedValue Value


type DecodeResult a
    = BadJson
    | Errors Errors
    | Success { warnings : List Warning, value : a }


type Decoder a
    = Decoder (AnnotatedValue -> Result Errors ( AnnotatedValue, a ))


decodeValue : Decoder a -> Value -> DecodeResult a
decodeValue (Decoder decoderFn) value =
    case decode value of
        Err _ ->
            BadJson

        Ok json ->
            case decoderFn json of
                Err errors ->
                    Errors errors

                Ok ( processedJson, val ) ->
                    Success
                        { warnings = gatherWarnings processedJson
                        , value = val
                        }


decodeString : Decoder a -> String -> DecodeResult a
decodeString decoder jsonString =
    case Decode.decodeString Decode.value jsonString of
        Err _ ->
            BadJson

        Ok json ->
            decodeValue decoder json


succeed : a -> Decoder a
succeed val =
    Decoder <| \json -> Ok ( json, val )


fail : String -> Decoder a
fail message =
    Decoder <|
        \json ->
            encode json
                |> Failure message
                |> Nonempty.fromElement
                |> Err


expected : String -> AnnotatedValue -> Result Errors a
expected expectedType json =
    encode json
        |> Failure ("Expected " ++ expectedType)
        |> Nonempty.fromElement
        |> Err


string : Decoder String
string =
    Decoder <|
        \json ->
            case json of
                String _ value ->
                    Ok ( markUsed json, value )

                _ ->
                    expected "a string" json


value : Decoder Value
value =
    Decoder <|
        \json ->
            Ok ( markUsed json, encode json )


float : Decoder Float
float =
    Decoder <|
        \json ->
            case json of
                Number _ value ->
                    Ok ( markUsed json, value )

                _ ->
                    expected "a number" json


int : Decoder Int
int =
    Decoder <|
        \json ->
            case json of
                Number _ value ->
                    if toFloat (round value) == value then
                        Ok ( markUsed json, round value )
                    else
                        expected "an integer number" json

                _ ->
                    expected "an integer number" json


bool : Decoder Bool
bool =
    Decoder <|
        \json ->
            case json of
                Bool _ value ->
                    Ok ( markUsed json, value )

                _ ->
                    expected "a boolean" json


null : a -> Decoder a
null val =
    Decoder <|
        \json ->
            case json of
                Null _ ->
                    Ok ( Null True, val )

                _ ->
                    expected "null" json


list : Decoder a -> Decoder (List a)
list (Decoder decoderFn) =
    let
        accumulate :
            AnnotatedValue
            -> ( Int, Result Errors ( List AnnotatedValue, List a ) )
            -> ( Int, Result Errors ( List AnnotatedValue, List a ) )
        accumulate value ( idx, acc ) =
            case ( acc, decoderFn value ) of
                ( Err errors, Err newErrors ) ->
                    ( idx + 1
                    , Err <| Nonempty.cons (BadIndex idx newErrors) errors
                    )

                ( Err errors, _ ) ->
                    ( idx + 1, Err errors )

                ( _, Err errors ) ->
                    ( idx + 1
                    , Err <| Nonempty.fromElement (BadIndex idx errors)
                    )

                ( Ok ( jsonAcc, valAcc ), Ok ( json, val ) ) ->
                    ( idx + 1, Ok ( json :: jsonAcc, val :: valAcc ) )
    in
    Decoder <|
        \json ->
            case json of
                Array _ values ->
                    List.foldr accumulate ( 0, Ok ( [], [] ) ) values
                        |> Tuple.second
                        |> Result.map (Tuple.mapFirst (Array True))

                _ ->
                    expected "an array" json


index : Int -> Decoder a -> Decoder a
index idx (Decoder decoderFn) =
    let
        finalize :
            AnnotatedValue
            -> ( b, List AnnotatedValue, Maybe (Result Errors a) )
            -> Result Errors ( AnnotatedValue, a )
        finalize json ( _, values, res ) =
            case res of
                Nothing ->
                    expected ("an array with index " ++ toString idx) json

                Just (Err e) ->
                    Err e

                Just (Ok v) ->
                    Ok ( Array True values, v )

        accumulate :
            AnnotatedValue
            -> ( Int, List AnnotatedValue, Maybe (Result Errors a) )
            -> ( Int, List AnnotatedValue, Maybe (Result Errors a) )
        accumulate value ( i, acc, result ) =
            if i == idx then
                case decoderFn value of
                    Err e ->
                        ( i + 1
                        , value :: acc
                        , Just <| Err <| Nonempty.fromElement <| BadIndex i e
                        )

                    Ok ( updatedJson, res ) ->
                        ( i + 1
                        , updatedJson :: acc
                        , Just <| Ok res
                        )
            else
                ( i + 1
                , value :: acc
                , result
                )
    in
    Decoder <|
        \json ->
            case json of
                Array _ values ->
                    List.foldr
                        accumulate
                        ( 0, [], Nothing )
                        values
                        |> finalize json

                _ ->
                    expected "an array" json


keyValuePairs : Decoder a -> Decoder (List ( String, a ))
keyValuePairs (Decoder decoderFn) =
    let
        accumulate :
            ( String, AnnotatedValue )
            -> Result Errors ( List ( String, AnnotatedValue ), List ( String, a ) )
            -> Result Errors ( List ( String, AnnotatedValue ), List ( String, a ) )
        accumulate ( key, value ) acc =
            case ( acc, decoderFn value ) of
                ( Err e, Err new ) ->
                    Err <| Nonempty.append new e

                ( Err e, _ ) ->
                    Err e

                ( _, Err e ) ->
                    Err e

                ( Ok ( jsonAcc, resAcc ), Ok ( newJson, newRes ) ) ->
                    Ok
                        ( ( key, newJson ) :: jsonAcc
                        , ( key, newRes ) :: resAcc
                        )
    in
    Decoder <|
        \json ->
            case json of
                Object _ kvPairs ->
                    List.foldr accumulate (Ok ( [], [] )) kvPairs
                        |> Result.map (Tuple.mapFirst (Object True))

                _ ->
                    expected "an object" json


field : String -> Decoder a -> Decoder a
field fieldName (Decoder decoderFn) =
    let
        accumulate :
            ( String, AnnotatedValue )
            -> ( List ( String, AnnotatedValue ), Maybe (Result Errors a) )
            -> ( List ( String, AnnotatedValue ), Maybe (Result Errors a) )
        accumulate ( key, value ) ( acc, result ) =
            if key == fieldName then
                case decoderFn value of
                    Err e ->
                        ( ( key, value ) :: acc, Just <| Err e )

                    Ok ( newValue, v ) ->
                        ( ( key, newValue ) :: acc
                        , Just <| Ok v
                        )
            else
                ( ( key, value ) :: acc, result )

        finalize :
            AnnotatedValue
            -> ( List ( String, AnnotatedValue ), Maybe (Result Errors a) )
            -> Result Errors ( AnnotatedValue, a )
        finalize json ( values, res ) =
            case res of
                Nothing ->
                    expected ("an object with a field '" ++ fieldName ++ "'") json

                Just (Err e) ->
                    Err e

                Just (Ok v) ->
                    Ok ( Object True values, v )
    in
    Decoder <|
        \json ->
            case json of
                Object _ kvPairs ->
                    List.foldr accumulate ( [], Nothing ) kvPairs
                        |> finalize json

                _ ->
                    expected "an object" json


at : List String -> Decoder a -> Decoder a
at fields decoder =
    List.foldl field decoder fields



-- Choosing


oneOf : List (Decoder a) -> Decoder a
oneOf decoders =
    Decoder <|
        \json ->
            oneOfHelp decoders json []


oneOfHelp :
    List (Decoder a)
    -> AnnotatedValue
    -> List Errors
    -> Result Errors ( AnnotatedValue, a )
oneOfHelp decoders value errorAcc =
    case decoders of
        [] ->
            Err <| Nonempty.fromElement <| BadOneOf (List.reverse errorAcc)

        (Decoder decoderFn) :: rest ->
            case decoderFn value of
                Ok ( newJson, res ) ->
                    Ok ( newJson, res )

                Err e ->
                    oneOfHelp rest value (e :: errorAcc)


maybe : Decoder a -> Decoder (Maybe a)
maybe decoder =
    oneOf [ map Just decoder, succeed Nothing ]



-- Mapping and chaining


map : (a -> b) -> Decoder a -> Decoder b
map f (Decoder decoderFn) =
    Decoder <|
        \json ->
            Result.map (Tuple.mapSecond f) (decoderFn json)


andThen : (a -> Decoder b) -> Decoder a -> Decoder b
andThen toDecoderB (Decoder decoderFnA) =
    Decoder <|
        \json ->
            case decoderFnA json of
                Ok ( newJson, valA ) ->
                    let
                        (Decoder decoderFnB) =
                            toDecoderB valA
                    in
                    decoderFnB newJson

                Err e ->
                    Err e


map2 : (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
map2 f (Decoder decoderFnA) (Decoder decoderFnB) =
    Decoder <|
        \json ->
            case decoderFnA json of
                Ok ( newJson, valA ) ->
                    case decoderFnB newJson of
                        Ok ( finalJson, valB ) ->
                            Ok ( finalJson, f valA valB )

                        Err e ->
                            Err e

                Err e ->
                    case decoderFnB json of
                        Ok _ ->
                            Err e

                        Err e2 ->
                            Err <| Nonempty.append e e2


andMap : Decoder a -> Decoder (a -> b) -> Decoder b
andMap =
    map2 (|>)


map3 :
    (a -> b -> c -> d)
    -> Decoder a
    -> Decoder b
    -> Decoder c
    -> Decoder d
map3 f decoderA decoderB decoderC =
    map f decoderA
        |> andMap decoderB
        |> andMap decoderC


map4 :
    (a -> b -> c -> d -> e)
    -> Decoder a
    -> Decoder b
    -> Decoder c
    -> Decoder d
    -> Decoder e
map4 f decoderA decoderB decoderC decoderD =
    map f decoderA
        |> andMap decoderB
        |> andMap decoderC
        |> andMap decoderD


map5 :
    (a -> b -> c -> d -> e -> f)
    -> Decoder a
    -> Decoder b
    -> Decoder c
    -> Decoder d
    -> Decoder e
    -> Decoder f
map5 f decoderA decoderB decoderC decoderD decoderE =
    map f decoderA
        |> andMap decoderB
        |> andMap decoderC
        |> andMap decoderD
        |> andMap decoderE


map6 :
    (a -> b -> c -> d -> e -> f -> g)
    -> Decoder a
    -> Decoder b
    -> Decoder c
    -> Decoder d
    -> Decoder e
    -> Decoder f
    -> Decoder g
map6 f decoderA decoderB decoderC decoderD decoderE decoderF =
    map f decoderA
        |> andMap decoderB
        |> andMap decoderC
        |> andMap decoderD
        |> andMap decoderE
        |> andMap decoderF


map7 :
    (a -> b -> c -> d -> e -> f -> g -> h)
    -> Decoder a
    -> Decoder b
    -> Decoder c
    -> Decoder d
    -> Decoder e
    -> Decoder f
    -> Decoder g
    -> Decoder h
map7 f decoderA decoderB decoderC decoderD decoderE decoderF decoderG =
    map f decoderA
        |> andMap decoderB
        |> andMap decoderC
        |> andMap decoderD
        |> andMap decoderE
        |> andMap decoderF
        |> andMap decoderG


map8 :
    (a -> b -> c -> d -> e -> f -> g -> h -> i)
    -> Decoder a
    -> Decoder b
    -> Decoder c
    -> Decoder d
    -> Decoder e
    -> Decoder f
    -> Decoder g
    -> Decoder h
    -> Decoder i
map8 f decoderA decoderB decoderC decoderD decoderE decoderF decoderG decoderH =
    map f decoderA
        |> andMap decoderB
        |> andMap decoderC
        |> andMap decoderD
        |> andMap decoderE
        |> andMap decoderF
        |> andMap decoderG
        |> andMap decoderH



-- Internal stuff


type AnnotatedValue
    = String Bool String
    | Number Bool Float
    | Bool Bool Bool
    | Null Bool
    | Array Bool (List AnnotatedValue)
    | Object Bool (List ( String, AnnotatedValue ))


decode : Value -> Result String AnnotatedValue
decode =
    Decode.decodeValue decoder


decoder : Decode.Decoder AnnotatedValue
decoder =
    Decode.oneOf
        [ Decode.map (String False) Decode.string
        , Decode.map (Number False) Decode.float
        , Decode.map (Bool False) Decode.bool
        , Decode.null (Null False)
        , Decode.map (Array False) (Decode.list <| Decode.lazy <| \_ -> decoder)
        , Decode.map
            (List.reverse >> Object False)
            (Decode.keyValuePairs <| Decode.lazy <| \_ -> decoder)
        ]


encode : AnnotatedValue -> Value
encode v =
    case v of
        String _ value ->
            Encode.string value

        Number _ value ->
            Encode.float value

        Bool _ value ->
            Encode.bool value

        Null _ ->
            Encode.null

        Array _ values ->
            List.map encode values
                |> Encode.list

        Object _ kvPairs ->
            List.map (Tuple.mapSecond encode) kvPairs
                |> Encode.object


gatherWarnings : AnnotatedValue -> List Warning
gatherWarnings json =
    case json of
        String False _ ->
            [ UnusedValue <| encode json ]

        Number False _ ->
            [ UnusedValue <| encode json ]

        Bool False _ ->
            [ UnusedValue <| encode json ]

        Null False ->
            [ UnusedValue <| encode json ]

        Array False _ ->
            [ UnusedValue <| encode json ]

        Object False _ ->
            [ UnusedValue <| encode json ]

        Array _ values ->
            values
                |> List.indexedMap
                    (\idx value ->
                        case gatherWarnings value of
                            [] ->
                                []

                            x :: xs ->
                                [ AtIndex idx <| Nonempty x xs ]
                    )
                |> List.concat

        Object _ kvPairs ->
            kvPairs
                |> List.concatMap
                    (\( key, value ) ->
                        case gatherWarnings value of
                            [] ->
                                []

                            x :: xs ->
                                [ InField key <| Nonempty x xs ]
                    )

        _ ->
            []


markUsed : AnnotatedValue -> AnnotatedValue
markUsed annotatedValue =
    case annotatedValue of
        String _ value ->
            String True value

        Number _ value ->
            Number True value

        Bool _ value ->
            Bool True value

        Null _ ->
            Null True

        Array _ values ->
            Array True values

        Object _ values ->
            Object True values

repl.txt

> import Json.Decode.Completion exposing (..)

> decodeString (succeed "hi") "null"
Success { warnings = [UnusedValue null], value = "hi" }
    : Json.Decode.Completion.DecodeResult String

> decodeString string "null"
Errors (Nonempty (Failure "Expected a string" null) [])
    : Json.Decode.Completion.DecodeResult String

> decodeString (null "hi") "null"
Success { warnings = [], value = "hi" }
    : Json.Decode.Completion.DecodeResult String

> decodeString (index 1 string) """[ "foo", "bar", "baz" ] """
Success { warnings = [AtIndex 0 (Nonempty (UnusedValue "foo") []),AtIndex 2 (Nonempty (UnusedValue "baz") [])], value = "bar" }
    : Json.Decode.Completion.DecodeResult String

> decodeString (maybe string) "null"
Success { warnings = [UnusedValue null], value = Nothing }
    : Json.Decode.Completion.DecodeResult (Maybe.Maybe String)

> decodeString (maybe string) """ "foo" """
Success { warnings = [], value = Just "foo" }
    : Json.Decode.Completion.DecodeResult (Maybe.Maybe String)