elm-codec

Codec.elm

module Codec exposing
    ( Codec
    , adt
    , alternative
    , alternative0
    , alternative1
    , alternative2
    , always
    , array
    , bimap
    , bool
    , buildAdt
    , buildObject
    , custom
    , decoder
    , default
    , dict
    , encoder
    , field
    , float
    , int
    , list
    , maybe
    , object
    , permissiveDecoder
    , recursive
    , set
    , string
    , tuple
    , withDefault
    )

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


type Codec a
    = Codec
        { encoder : a -> Value
        , decoder : Decoder a
        , permissiveDecoder : Decoder a
        , default : a
        }


custom : { encoder : a -> Value, decoder : Decoder a, permissiveDecoder : Decoder a, default : a } -> Codec a
custom =
    Codec


decoder : Codec a -> Decoder a
decoder (Codec m) =
    m.decoder


encoder : Codec a -> a -> Value
encoder (Codec m) =
    m.encoder


permissiveDecoder : Codec a -> Decoder a
permissiveDecoder (Codec m) =
    m.permissiveDecoder


default : Codec a -> a
default (Codec m) =
    m.default


withDefault : a -> Codec a -> Codec a
withDefault default_ (Codec m) =
    Codec { m | default = default_ }



--Base


decoderWithDefault : a -> Decoder a -> Decoder a
decoderWithDefault default_ decoder_ =
    decoder_
        |> JD.maybe
        |> JD.map
            (\v ->
                case v of
                    Nothing ->
                        default_

                    Just x ->
                        x
            )


base : (a -> Value) -> Decoder a -> a -> Codec a
base encoder_ decoder_ default_ =
    Codec
        { encoder = encoder_
        , decoder = decoder_
        , permissiveDecoder = decoderWithDefault default_ decoder_
        , default = default_
        }


string : Codec String
string =
    base JE.string JD.string ""


int : Codec Int
int =
    base JE.int JD.int 0


float : Codec Float
float =
    base JE.float JD.float 0.0


bool : Codec Bool
bool =
    base JE.bool JD.bool False



-- Composite


build : ((b -> Value) -> a -> Value) -> (Decoder b -> Decoder a) -> (b -> a) -> Codec b -> Codec a
build enc dec def (Codec codec) =
    Codec
        { encoder = enc codec.encoder
        , decoder = dec codec.decoder
        , permissiveDecoder = decoderWithDefault (def codec.default) <| dec codec.permissiveDecoder
        , default = def <| codec.default
        }


array : Codec a -> Codec (Array a)
array =
    build JE.array JD.array <| \_ -> Array.empty


list : Codec a -> Codec (List a)
list =
    build JE.list JD.list <| \_ -> []


dict : Codec a -> Codec (Dict String a)
dict =
    build (\e -> JE.object << Dict.toList << Dict.map (\_ -> e)) JD.dict <| \_ -> Dict.empty


set : Codec comparable -> Codec (Set comparable)
set =
    build (\e -> JE.list e << Set.toList) (JD.map Set.fromList << JD.list) <| \_ -> Set.empty


maybeField : String -> a -> Decoder a -> Decoder a
maybeField field_ default_ decoder_ =
    decoderWithDefault default_ <| JD.field field_ decoder_


maybeIndex : Int -> a -> Decoder a -> Decoder a
maybeIndex index default_ decoder_ =
    decoderWithDefault default_ <| JD.index index decoder_


tuple : Codec a -> Codec b -> Codec ( a, b )
tuple m1 m2 =
    Codec
        { encoder =
            \( v1, v2 ) ->
                JE.list identity
                    [ encoder m1 v1
                    , encoder m2 v2
                    ]
        , decoder =
            JD.map2
                (\a b -> ( a, b ))
                (JD.index 0 <| decoder m1)
                (JD.index 1 <| decoder m2)
        , permissiveDecoder =
            JD.map2
                (\a b -> ( a, b ))
                (decoderWithDefault (default m1) <| JD.index 0 <| permissiveDecoder m1)
                (decoderWithDefault (default m2) <| JD.index 1 <| permissiveDecoder m2)
        , default = ( default m1, default m2 )
        }



--RECORDS


type ObjectCodec a b
    = ObjectCodec
        { encoder : a -> List ( String, Value )
        , decoder : Decoder b
        , permissiveDecoder : Decoder b
        , default : b
        }


object : b -> ObjectCodec a b
object ctor =
    ObjectCodec
        { encoder = \_ -> []
        , decoder = JD.succeed ctor
        , permissiveDecoder = JD.succeed ctor
        , default = ctor
        }


field : String -> (a -> f) -> Codec f -> ObjectCodec a (f -> b) -> ObjectCodec a b
field name getter codec (ObjectCodec ocodec) =
    ObjectCodec
        { encoder = \v -> ( name, encoder codec <| getter v ) :: ocodec.encoder v
        , decoder = JD.map2 (\f x -> f x) ocodec.decoder (JD.field name (decoder codec))
        , permissiveDecoder = JD.map2 (\f x -> f x) ocodec.permissiveDecoder (maybeField name (default codec) (permissiveDecoder codec))
        , default = ocodec.default (default codec)
        }


buildObject : ObjectCodec a a -> Codec a
buildObject (ObjectCodec om) =
    Codec
        { encoder = \v -> JE.object <| om.encoder v
        , decoder = om.decoder
        , permissiveDecoder = om.permissiveDecoder
        , default = om.default
        }



--ADT


type AdtCodec match v
    = AdtCodec
        { match : match
        , decoder : String -> Decoder v -> Decoder v
        , permissiveDecoder : String -> Decoder v -> Decoder v
        }


adt : match -> AdtCodec match value
adt match =
    AdtCodec
        { match = match
        , decoder = \_ -> identity
        , permissiveDecoder = \_ -> identity
        }


alternative :
    String
    -> ((List Value -> Value) -> a)
    -> Decoder v
    -> Decoder v
    -> AdtCodec (a -> b) v
    -> AdtCodec b v
alternative name matchPiece decoderPiece permissiveDecoderPiece (AdtCodec am) =
    let
        enc v =
            JE.object
                [ ( "tag", JE.string name )
                , ( "args", JE.list identity v )
                ]

        decoder_ tag orElse =
            if tag == name then
                decoderPiece

            else
                am.decoder tag orElse

        permissiveDecoder_ tag orElse =
            if tag == name then
                permissiveDecoderPiece

            else
                am.permissiveDecoder tag orElse
    in
    AdtCodec
        { match = am.match <| matchPiece enc
        , decoder = decoder_
        , permissiveDecoder = permissiveDecoder_
        }


alternative0 :
    String
    -> v
    -> AdtCodec (Value -> a) v
    -> AdtCodec a v
alternative0 name ctor =
    alternative name
        (\c -> c [])
        (JD.succeed ctor)
        (JD.succeed ctor)


alternative1 :
    String
    -> (a -> v)
    -> Codec a
    -> AdtCodec ((a -> Value) -> b) v
    -> AdtCodec b v
alternative1 name ctor m1 =
    alternative name
        (\c v -> c [ encoder m1 v ])
        (JD.map ctor (JD.index 0 <| decoder m1))
        (JD.map ctor (maybeIndex 0 (default m1) <| decoder m1))


alternative2 :
    String
    -> (a -> b -> v)
    -> Codec a
    -> Codec b
    -> AdtCodec ((a -> b -> Value) -> c) v
    -> AdtCodec c v
alternative2 name ctor m1 m2 =
    alternative name
        (\c v1 v2 -> c [ encoder m1 v1, encoder m2 v2 ])
        (JD.map2 ctor
            (JD.index 0 <| decoder m1)
            (JD.index 1 <| decoder m2)
        )
        (JD.map2 ctor
            (maybeIndex 0 (default m1) <| decoder m1)
            (maybeIndex 1 (default m2) <| decoder m2)
        )


buildAdt : a -> AdtCodec (a -> Value) a -> Codec a
buildAdt default_ (AdtCodec am) =
    Codec
        { encoder = \v -> am.match v
        , decoder =
            JD.field "tag" JD.string
                |> JD.andThen
                    (\tag ->
                        let
                            error =
                                "tag " ++ tag ++ "did not match"
                        in
                        JD.field "args" <| am.decoder tag <| JD.fail error
                    )
        , permissiveDecoder =
            JD.field "tag" JD.string
                |> JD.andThen
                    (\tag ->
                        JD.field "args" <| am.decoder tag <| JD.fail "impossible"
                    )
                |> decoderWithDefault default_
        , default = default_
        }


bimap : (a -> b) -> (b -> a) -> Codec a -> Codec b
bimap map contramap codec =
    Codec
        { decoder = JD.map map <| decoder codec
        , permissiveDecoder = JD.map map <| permissiveDecoder codec
        , default = map <| default codec
        , encoder = \v -> contramap v |> encoder codec
        }


maybe : Codec a -> Codec (Maybe a)
maybe codec =
    let
        value =
            Just <| default codec
    in
    Codec
        { decoder = JD.maybe <| decoder codec
        , permissiveDecoder =
            permissiveDecoder codec
                |> JD.maybe
                |> decoderWithDefault value
        , default = value
        , encoder =
            \v ->
                case v of
                    Nothing ->
                        JE.null

                    Just x ->
                        encoder codec x
        }


always : a -> Codec a
always default_ =
    Codec
        { decoder = JD.succeed default_
        , permissiveDecoder = JD.succeed default_
        , encoder = \_ -> JE.null
        , default = default_
        }



-- RECURSIVE


recursive : (Codec a -> Codec a) -> a -> Codec a
recursive f default_ =
    let
        step =
            { decoder = JD.lazy (\_ -> decoder <| recursive f default_)
            , permissiveDecoder = JD.lazy (\_ -> permissiveDecoder <| recursive f default_)
            , default = default_
            , encoder = \value -> encoder (recursive f default_) value
            }
    in
    f <| Codec step

CodecExamples.elm

module Examples exposing (Point, Tree(..), pointCodec, treeCodec)

import Codec exposing (Codec)


type alias Point =
    { x : Int
    , y : Int
    }


type Tree a
    = Node (List (Tree a))
    | Leaf a


pointCodec : Codec Point
pointCodec =
    Codec.object Point
        |> Codec.field "x" .x Codec.int
        |> Codec.field "y" .y Codec.int
        |> Codec.buildObject


treeCodec : Codec a -> Codec (Tree a)
treeCodec meta =
    Codec.recursive
        (\rmeta ->
            let
                cata fnode fleaf tree =
                    case tree of
                        Node cs ->
                            fnode cs

                        Leaf x ->
                            fleaf x
            in
            Codec.adt cata
                |> Codec.alternative1 "Node" Node (Codec.list rmeta)
                |> Codec.alternative1 "Leaf" Leaf meta
                |> Codec.buildAdt (Node [])
        )
        (Node [])

CodecTests.elm

module Base exposing (suite)

import Codec exposing (Codec)
import Dict
import Expect exposing (Expectation)
import Fuzz exposing (Fuzzer)
import Json.Decode as JD exposing (Value)
import Json.Encode as JE
import Set
import Test exposing (Test, describe, fuzz, test)


suite : Test
suite =
    describe "Testing roundtrips"
        [ describe "Basic" basicTests
        , describe "Containers" containersTests
        , describe "Object" objectTests
        , describe "ADT" adtTests
        , describe "bimap" bimapTests
        , describe "maybe" maybeTests
        , describe "always"
            [ test "roundtrips"
                (\_ ->
                    Codec.always 632
                        |> Codec.decoder
                        |> (\d -> JD.decodeString d "{}")
                        |> Expect.equal (Ok 632)
                )
            ]
        , describe "recursive" recursiveTests
        ]


roundtrips : Fuzzer a -> Codec a -> Test
roundtrips fuzzer codec =
    fuzz fuzzer "is a roundtrip" <|
        \value ->
            value
                |> Codec.encoder codec
                |> JD.decodeValue (Codec.decoder codec)
                |> Expect.equal (Ok value)


roundtripsWithin : Fuzzer Float -> Codec Float -> Test
roundtripsWithin fuzzer codec =
    fuzz fuzzer "is a roundtrip" <|
        \value ->
            value
                |> Codec.encoder codec
                |> JD.decodeValue (Codec.decoder codec)
                |> Result.withDefault -999.1234567
                |> Expect.within (Expect.Relative 0.000001) value


basicTests =
    [ describe "Codec.string"
        [ roundtrips Fuzz.string Codec.string
        ]
    , describe "Codec.int"
        [ roundtrips Fuzz.int Codec.int
        ]
    , describe "Codec.float"
        [ roundtrips Fuzz.float Codec.float
        ]
    , describe "Codec.bool"
        [ roundtrips Fuzz.bool Codec.bool
        ]
    ]


containersTests =
    [ describe "Codec.array"
        [ roundtrips (Fuzz.array Fuzz.int) (Codec.array Codec.int)
        ]
    , describe "Codec.list"
        [ roundtrips (Fuzz.list Fuzz.int) (Codec.list Codec.int)
        ]
    , describe "Codec.dict"
        [ roundtrips
            (Fuzz.map2 Tuple.pair Fuzz.string Fuzz.int
                |> Fuzz.list
                |> Fuzz.map Dict.fromList
            )
            (Codec.dict Codec.int)
        ]
    , describe "Codec.set"
        [ roundtrips
            (Fuzz.list Fuzz.int |> Fuzz.map Set.fromList)
            (Codec.set Codec.int)
        ]
    , describe "Codec.tuple"
        [ roundtrips
            (Fuzz.tuple ( Fuzz.int, Fuzz.int ))
            (Codec.tuple Codec.int Codec.int)
        ]
    ]


objectTests =
    [ describe "with 0 fields"
        [ roundtrips (Fuzz.constant {})
            (Codec.object {}
                |> Codec.buildObject
            )
        ]
    , describe "with 1 field"
        [ roundtrips (Fuzz.map (\i -> { fname = i }) Fuzz.int)
            (Codec.object (\i -> { fname = i })
                |> Codec.field "fname" .fname Codec.int
                |> Codec.buildObject
            )
        ]
    , describe "with 2 fields"
        [ roundtrips
            (Fuzz.map2
                (\a b ->
                    { a = a
                    , b = b
                    }
                )
                Fuzz.int
                Fuzz.int
            )
            (Codec.object
                (\a b ->
                    { a = a
                    , b = b
                    }
                )
                |> Codec.field "a" .a Codec.int
                |> Codec.field "b" .b Codec.int
                |> Codec.buildObject
            )
        ]
    ]


type Newtype a
    = Newtype a


adtTests =
    [ describe "with 1 ctor, 0 args"
        [ roundtrips (Fuzz.constant ())
            (Codec.adt
                (\f v ->
                    case v of
                        () ->
                            f
                )
                |> Codec.alternative0 "()" ()
                |> Codec.buildAdt ()
            )
        ]
    , describe "with 1 ctor, 1 arg"
        [ roundtrips (Fuzz.map Newtype Fuzz.int)
            (Codec.adt
                (\f v ->
                    case v of
                        Newtype a ->
                            f a
                )
                |> Codec.alternative1 "Newtype" Newtype Codec.int
                |> Codec.buildAdt (Newtype 0)
            )
        ]
    , describe "with 2 ctors, 0,1 args" <|
        let
            match fnothing fjust value =
                case value of
                    Nothing ->
                        fnothing

                    Just v ->
                        fjust v

            codec =
                Codec.adt match
                    |> Codec.alternative0 "Nothing" Nothing
                    |> Codec.alternative1 "Just" Just Codec.int
                    |> Codec.buildAdt Nothing

            fuzzers =
                [ ( "1st ctor", Fuzz.constant Nothing )
                , ( "2nd ctor", Fuzz.map Just Fuzz.int )
                ]
        in
        fuzzers
            |> List.map
                (\( name, fuzz ) ->
                    describe name
                        [ roundtrips fuzz codec ]
                )
    ]


bimapTests =
    [ roundtripsWithin Fuzz.float <|
        Codec.bimap
            (\x -> x * 2)
            (\x -> x / 2)
            Codec.float
    ]


maybeTests =
    [ describe "single"
        [ roundtrips
            (Fuzz.oneOf
                [ Fuzz.constant Nothing
                , Fuzz.map Just Fuzz.int
                ]
            )
          <|
            Codec.maybe Codec.int
        ]

    {-
       This is a known limitation: using null as Nothing and identity as Just means that nesting two maybes squashes Just Nothing with Nothing
       , describe "double"
          [ roundtrips
              (Fuzz.oneOf
                  [ Fuzz.constant Nothing
                  , Fuzz.constant <| Just Nothing
                  , Fuzz.map (Just << Just) Fuzz.int
                  ]
              )
            <|
              Codec.maybe <|
                  Codec.maybe Codec.int
          ]
    -}
    ]


recursiveTests =
    [ describe "list"
        [ roundtrips (Fuzz.list Fuzz.int) <|
            Codec.recursive
                (\c ->
                    Codec.adt
                        (\fempty fcons value ->
                            case value of
                                [] ->
                                    fempty

                                x :: xs ->
                                    fcons x xs
                        )
                        |> Codec.alternative0 "[]" []
                        |> Codec.alternative2 "(::)" (::) Codec.int c
                        |> Codec.buildAdt []
                )
                []
        ]
    ]