Is it possible to capture type information about records?

Learn
7

I should probably publish this as a library. The API is not perfect but it’s reasonable, and it’s quite a compact way to define encoding and decoding.

I would really love some feedback.

Ellie: https://ellie-app.com/8hS7BwxpJa1/0

module Main exposing (main)

import Dict exposing (Dict)
import Html exposing (Html)
import Json.Decode as JD exposing (Decoder)
import Json.Encode as JE exposing (Value)
import Set exposing (Set)


type alias ObjectSimpleFields =
    { a : String
    , b : Int
    , c : List Float
    , d : MyList Bool
    }


type MyList a
    = Empty
    | Cons a (MyList a)


objectSimpleFieldsMeta : Meta ObjectSimpleFields
objectSimpleFieldsMeta =
    object ObjectSimpleFields
        |> field "a" .a string
        |> field "b" .b int
        |> field "c" .c (list float)
        |> field "d" .d (mylist bool)
        |> build


mylist : Meta a -> Meta (MyList a)
mylist e =
    let
        matchEmpty e =
            case e of
                Empty ->
                    Just ()

                _ ->
                    Nothing

        matchCons e =
            case e of
                Cons x xs ->
                    Just ( x, xs )

                _ ->
                    Nothing
    in
    adt
        [ alternative0 matchEmpty Empty
        , alternative2 matchCons Cons e (lazy (\_ -> mylist e))
        ]


exampleObject : ObjectSimpleFields
exampleObject =
    { a = "a"
    , b = 0
    , c = [ -1.3 ]
    , d = Cons False Empty
    }


main : Html msg
main =
    let
        (Meta { encode, decode }) =
            objectSimpleFieldsMeta

        encoded =
            encode exampleObject

        decoded =
            JD.decodeValue decode encoded
    in
    Html.span []
        [ Html.text "Encoded: "
        , Html.text <| toString encoded
        , Html.text " decoded: "
        , case decoded of
            Ok v ->
                Html.text <| toString v

            Err e ->
                String.split "\n" e
                    |> List.map Html.text
                    |> List.intersperse (Html.br [] [])
                    |> Html.span []
        ]


type Meta a
    = Meta
        { encode : a -> Value
        , decode : Decoder a
        }


string : Meta String
string =
    Meta
        { encode = JE.string
        , decode = JD.string
        }


int : Meta Int
int =
    Meta
        { encode = JE.int
        , decode = JD.int
        }


float : Meta Float
float =
    Meta
        { encode = JE.float
        , decode = JD.float
        }


bool : Meta Bool
bool =
    Meta
        { encode = JE.bool
        , decode = JD.bool
        }


list : Meta a -> Meta (List a)
list =
    bimap
        (\e -> JE.list << List.map e)
        JD.list


dict : Meta a -> Meta (Dict String a)
dict =
    bimap
        (\e -> JE.object << Dict.toList << Dict.map (always e))
        JD.dict


set : Meta comparable -> Meta (Set comparable)
set =
    bimap
        (\e -> JE.list << List.map e << Set.toList)
        (JD.map Set.fromList << JD.list)


bimap : ((a -> Value) -> b -> Value) -> (Decoder a -> Decoder b) -> Meta a -> Meta b
bimap menc mdec (Meta meta) =
    Meta
        { encode = menc meta.encode
        , decode = mdec meta.decode
        }


type ObjectMeta a b
    = ObjectMeta
        { encode : a -> List ( String, Value )
        , decode : Decoder b
        }


object : b -> ObjectMeta a b
object ctor =
    ObjectMeta
        { encode = always []
        , decode = JD.succeed ctor
        }


field : String -> (a -> f) -> Meta f -> ObjectMeta a (f -> b) -> ObjectMeta a b
field name getter (Meta meta) (ObjectMeta ometa) =
    ObjectMeta
        { encode = \v -> ( name, meta.encode <| getter v ) :: ometa.encode v
        , decode = JD.map2 (\f x -> f x) ometa.decode (JD.field name meta.decode)
        }


build : ObjectMeta a a -> Meta a
build (ObjectMeta ometa) =
    Meta
        { encode = JE.object << ometa.encode
        , decode = ometa.decode
        }


type AlternativeMeta a
    = AlternativeMeta
        { encode : a -> Maybe (List Value)
        , decode : Decoder a
        }


apply : Decoder a -> Decoder (a -> b) -> Decoder b
apply =
    JD.map2 (|>)


alternative : (a -> Maybe b) -> (b -> List Value) -> Decoder a -> AlternativeMeta a
alternative match toList ctor =
    AlternativeMeta
        { encode = match >> Maybe.map toList
        , decode = ctor
        }


alternative0 : (a -> Maybe ()) -> a -> AlternativeMeta a
alternative0 match ctor =
    alternative match (always []) (JD.succeed ctor)


alternative1 : (a -> Maybe b) -> (b -> a) -> Meta b -> AlternativeMeta a
alternative1 match ctor (Meta p1) =
    alternative
        match
        (\v1 -> [ p1.encode v1 ])
        (JD.succeed ctor
            |> apply (JD.field "0" p1.decode)
        )


alternative2 : (a -> Maybe ( b, c )) -> (b -> c -> a) -> Meta b -> Meta c -> AlternativeMeta a
alternative2 match ctor (Meta p1) (Meta p2) =
    alternative
        match
        (\( v1, v2 ) -> [ p1.encode v1, p2.encode v2 ])
        (JD.succeed ctor
            |> apply (JD.field "0" p1.decode)
            |> apply (JD.field "1" p2.decode)
        )


adt : List (AlternativeMeta a) -> Meta a
adt alternatives =
    let
        maybeEncode : a -> Int -> AlternativeMeta a -> Maybe ( Int, List Value )
        maybeEncode e i (AlternativeMeta { encode }) =
            encode e |> Maybe.map (\v -> ( i, v ))

        aencode e =
            alternatives
                |> List.indexedMap (maybeEncode e)
                |> List.filterMap identity
                |> List.head
                |> Maybe.map
                    (\( i, v ) ->
                        JE.object
                            [ ( "tag", JE.int i )
                            , ( "values", JE.list v )
                            ]
                    )
                |> Maybe.withDefault JE.null

        adecode =
            JD.field "tag" JD.int
                |> JD.andThen
                    (\tag ->
                        case List.drop tag alternatives of
                            [] ->
                                JD.fail <| "Wrong tag, got " ++ toString tag

                            (AlternativeMeta { decode }) :: _ ->
                                JD.field "values" decode
                    )
    in
    Meta
        { encode = aencode
        , decode = adecode
        }


lazy : (() -> Meta a) -> Meta a
lazy f =
    Meta
        { encode =
            \v ->
                let
                    (Meta { encode }) =
                        f ()
                in
                encode v
        , decode =
            JD.lazy
                (\l ->
                    let
                        (Meta { decode }) =
                            f l
                    in
                    decode
                )
        }
2 Likes