haskell-to-elm (empty) → 0.1.0.0

raw patch · 8 files changed

+1170/−0 lines, 8 filesdep +aesondep +basedep +boundsetup-changed

Dependencies added: aeson, base, bound, elm-syntax, generics-sop, haskell-to-elm, protolude, text, time, unordered-containers

Files

• CHANGELOG.md +7/−0
• LICENSE +30/−0
• README.md +161/−0
• Setup.hs +2/−0
• examples/User.hs +53/−0
• haskell-to-elm.cabal +96/−0
• src/Language/Haskell/To/Elm.hs +819/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,7 @@+# Changelog for haskell-to-elm++## Unreleased changes++## 0.1.0.0++- Initial release

@@ -0,0 +1,30 @@+Copyright Olle Fredriksson (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Olle Fredriksson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,161 @@+# haskell-to-elm++`haskell-to-elm` is a library that takes Haskell type definitions as input and+generates matching Elm type definitions and JSON encoders and decoders that+match Aeson's format.++## The problem++Let's say we're building a web page with a Haskell backend and an Elm frontend.++We might have a Haskell type like this, that we pass to the frontend encoded as+JSON. The JSON encoder is derived using the Aeson library.++```haskell+data User = User+  { name :: Text+  , age :: Int+  } deriving (Generic, ToJSON)+```++We mirror the type on the Elm side and add a JSON decoder as follows:++```elm+type alias User =+    { name : String+    , age : Int+    }++decoder : Decoder User+decoder =+    Decode.map2 User+        (Decode.field "name" Decode.string)+        (Decode.field "age" Decode.int)+```++Now, let's say we want to change a field in the backend:++```haskell+-- Haskell+data User = User+  { name :: Text+--, age :: Int+  , birthday :: Date -- <---- new!+  } deriving (Generic, ToJSON)+```++If we now run the application again, but forget to update the Elm code, the+`User` decoder will fail at runtime in Elm.++## The solution++`haskell-to-elm` solves this problem by letting us _generate_ the Elm `User`+type and `decoder` from the Haskell `User` type.++With `haskell-to-elm` as part of your build pipeline you can make sure that the+frontend is always in sync with your backend, and get type errors in your+frontend code when you change your backend types.++The companion library [servant-to-elm](https://github.com/folq/servant-to-elm) also+lets you generate Elm client libraries for your Servant APIs.++## Basic usage++To generate code for the `User` type above, we first need to derive a bunch of class instances:++```haskell+data User = User+  { name :: Text+  , age :: Int+  } deriving+    ( Generic+    , Aeson.ToJSON+    , SOP.Generic+    , SOP.HasDatatypeInfo+    , HasElmDecoder Aeson.Value+    , HasElmEncoder Aeson.Value+    , HasElmType+    )++instance HasElmDefinition User where+  elmDefinition =+    deriveElmTypeDefinition @User defaultOptions "Api.User.User"++instance HasElmDecoderDefinition Aeson.Value User where+  elmDecoderDefinition =+    deriveElmJSONDecoder @User defaultOptions Aeson.defaultOptions "Api.User.decoder"++instance HasElmEncoderDefinition Aeson.Value User where+  elmEncoderDefinition =+    deriveElmJSONEncoder @User defaultOptions Aeson.defaultOptions "Api.User.encoder"+```++Then we can print the generated Elm code using the following code:++```haskell+main :: IO ()+main = do+  let+    definitions =+      jsonDefinitions @User++    modules =+      Pretty.modules definitions++  forM_ (HashMap.toList modules) $ \(_moduleName, contents) ->+    print contents+```++Running `main` will print the following Elm code:++```elm+module Api.User exposing (..)++import Json.Decode+import Json.Decode.Pipeline+import Json.Encode+++type alias User =+    { name : String, age : Int }+++encoder : User -> Json.Encode.Value+encoder a =+    Json.Encode.object [ ("name" , Json.Encode.string a.name)+    , ("age" , Json.Encode.int a.age) ]+++decoder : Json.Decode.Decoder User+decoder =+    Json.Decode.succeed User |>+    Json.Decode.Pipeline.required "name" Json.Decode.string |>+    Json.Decode.Pipeline.required "age" Json.Decode.int+```++In an actual project we would be writing the code to disk instead of printing it.++See [this file](examples/User.hs) for the full code with imports.++## Roadmap++- [x] Derive JSON encoders and generically+  - [ ] Support all Aeson options+- [x] Pretty-print the Elm AST+  - [x] Separate pretty printing from code generation: [elm-syntax](https://github.com/folq/elm-syntax)+- [x] Generate Elm modules+- [x] Servant client library generation: [servant-to-elm](https://github.com/folq/servant-to-elm)+- [x] Test that encoding and decoding round-trip: [elm-to-haskell-test](https://github.com/folq/elm-to-haskell-test)++## Related projects++Libraries that use or are used by haskell-to-elm:+- [elm-syntax](https://github.com/folq/elm-syntax) defines Haskell ASTs for Elm's syntax, and lets us pretty-print it.+- [servant-to-elm](https://github.com/folq/servant-to-elm) can be used to generate Elm client libraries from Servant APIs.+- [haskell-to-elm-test](https://github.com/folq/haskell-to-elm-test) does end-to-end testing of this library.++Others:+- [elm-export](http://hackage.haskell.org/package/elm-export)+- [elm-bridge](http://hackage.haskell.org/package/elm-bridge)+- [elm-street](http://hackage.haskell.org/package/elm-street)+- [elminator](https://github.com/sras/elminator)

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+module User where++import Protolude++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Lazy as HashMap+import qualified Generics.SOP as SOP++import qualified Language.Elm.Pretty as Pretty+import Language.Haskell.To.Elm++data User = User+  { name :: Text+  , age :: Int+  } deriving+    ( Generic+    , Aeson.ToJSON+    , SOP.Generic+    , SOP.HasDatatypeInfo+    , HasElmDecoder Aeson.Value+    , HasElmEncoder Aeson.Value+    , HasElmType+    )++instance HasElmDefinition User where+  elmDefinition =+    deriveElmTypeDefinition @User defaultOptions "Api.User.User"++instance HasElmDecoderDefinition Aeson.Value User where+  elmDecoderDefinition =+    deriveElmJSONDecoder @User defaultOptions Aeson.defaultOptions "Api.User.decoder"++instance HasElmEncoderDefinition Aeson.Value User where+  elmEncoderDefinition =+    deriveElmJSONEncoder @User defaultOptions Aeson.defaultOptions "Api.User.encoder"++main :: IO ()+main = do+  let+    definitions =+      jsonDefinitions @User++    modules =+      Pretty.modules definitions++  forM_ (HashMap.toList modules) $ \(_moduleName, contents) ->+    print contents

@@ -0,0 +1,96 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: ae480eeef791a5ae2e0dd89113815afda032b3f664b4e92f9241893aff5a8626++name:           haskell-to-elm+version:        0.1.0.0+synopsis:       Generate Elm types and JSON encoders and decoders from Haskell types+description:    Please see the README on GitHub at <https://github.com/folq/haskell-to-elm#readme>+category:       Elm, Compiler, Language+homepage:       https://github.com/folq/haskell-to-elm#readme+bug-reports:    https://github.com/folq/haskell-to-elm/issues+author:         Olle Fredriksson+maintainer:     fredriksson.olle@gmail.com+copyright:      2019 Olle Fredriksson+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/folq/haskell-to-elm++flag examples+  description: Build examples+  manual: True+  default: False++library+  exposed-modules:+      Language.Haskell.To.Elm+  other-modules:+      Paths_haskell_to_elm+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields+  build-depends:+      aeson >=1.4.0+    , base >=4.7 && <5+    , bound >=2.0.0+    , elm-syntax >=0.1.0 && <0.1.1+    , generics-sop >=0.4.0+    , protolude >=0.2.3+    , text >=1.2.0+    , time >=1.8.0+    , unordered-containers >=0.2.8+  default-language: Haskell2010++executable user-example+  main-is: User.hs+  other-modules:+      Paths_haskell_to_elm+  hs-source-dirs:+      examples+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields+  build-depends:+      aeson >=1.4.0+    , base >=4.7 && <5+    , bound >=2.0.0+    , elm-syntax >=0.1.0 && <0.1.1+    , generics-sop >=0.4.0+    , haskell-to-elm+    , protolude >=0.2.3+    , text >=1.2.0+    , time >=1.8.0+    , unordered-containers >=0.2.8+  if !flag(examples)+    buildable: False+  default-language: Haskell2010++test-suite haskell-to-elm-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_haskell_to_elm+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson >=1.4.0+    , base >=4.7 && <5+    , bound >=2.0.0+    , elm-syntax >=0.1.0 && <0.1.1+    , generics-sop >=0.4.0+    , haskell-to-elm+    , protolude >=0.2.3+    , text >=1.2.0+    , time >=1.8.0+    , unordered-containers >=0.2.8+  default-language: Haskell2010

@@ -0,0 +1,819 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+module Language.Haskell.To.Elm where++import Protolude hiding (All, Infix, Type)++import qualified Bound+import qualified Data.Aeson as Aeson+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import Data.String+import Data.Text (Text)+import Data.Time+import Generics.SOP as SOP++import Language.Elm.Definition (Definition)+import qualified Language.Elm.Definition as Definition+import Language.Elm.Expression (Expression)+import qualified Language.Elm.Expression as Expression+import qualified Language.Elm.Name as Name+import qualified Language.Elm.Pattern as Pattern+import Language.Elm.Type (Type)+import qualified Language.Elm.Type as Type++-------------------------------------------------------------------------------+-- * Classes++-- | Represents that the corresponding Elm type for the Haskell type @a@ is @'elmType' \@a@.+--+-- This class has a default instance for types that satisfy 'HasElmDefinition',+-- which refers to the name of that definition.+class HasElmType a where+  elmType :: Type v+  default elmType :: HasElmDefinition a => Type v+  elmType = Type.Global $ Definition.name $ elmDefinition @a++-- | Represents that we can generate the definition for the Elm type that+-- corresponds to @a@ using @'elmDefinition' \@a@.+--+-- See 'deriveElmTypeDefinition' for a way to automatically derive 'elmDefinition'.+class HasElmDefinition a where+  elmDefinition :: Definition++-- | Represents that the Elm type that corresponds to @a@ has a decoder from+-- @value@, namely @'elmDecoder' \@value \@a@.+--+-- This class has a default instance for types that satisfy+-- 'HasElmDecoderDefinition', which refers to the name of that definition.+class HasElmType a => HasElmDecoder value a where+  elmDecoder :: Expression v+  default elmDecoder :: HasElmDecoderDefinition value a => Expression v+  elmDecoder = Expression.Global $ Definition.name $ elmDecoderDefinition @value @a++-- | Represents that the Elm type that corresponds to @a@ has an encoder into+-- @value@, namely @'elmEncoder' \@value \@a@.+--+-- This class has a default instance for types that satisfy+-- 'HasElmEncoderDefinition', which refers to the name of that definition.+class HasElmType a => HasElmEncoder value a where+  elmEncoder :: Expression v+  default elmEncoder :: HasElmEncoderDefinition value a => Expression v+  elmEncoder = Expression.Global $ Definition.name $ elmEncoderDefinition @value @a++-- | Represents that we can generate the Elm decoder definition from @value@+-- for the Elm type that corresponds to @a@.+--+-- See 'deriveElmJSONDecoder' for a way to automatically derive+-- 'elmDecoderDefinition' when @value = 'Aeson.Value'@.+class HasElmDecoderDefinition value a where+  elmDecoderDefinition :: Definition++-- | Represents that we can generate the Elm encoder definition into @value@+-- for the Elm type that corresponds to @a@.+--+-- See 'deriveElmJSONEncoder' for a way to automatically derive+-- 'elmEncoderDefinition' when @value = 'Aeson.Value'@.+class HasElmEncoderDefinition value a where+  elmEncoderDefinition :: Definition++-------------------------------------------------------------------------------+-- * Derivers++-- | Elm code generation options+newtype Options = Options+  { fieldLabelModifier :: String -> String -- ^ Use this function to go from Haskell record field name to Elm record field name.+  }++defaultOptions :: Options+defaultOptions =+  Options+    { fieldLabelModifier = identity+    }++-- | Automatically create an Elm definition given a Haskell type.+--+-- This is suitable for use as a 'HasElmDefinition' instance:+--+-- @+-- instance 'HasElmDefinition' MyType where+--   'elmDefinition' =+--     'deriveElmTypeDefinition' \@MyType 'defaultOptions' \"Api.MyType.MyType\"+-- @+deriveElmTypeDefinition :: forall a. (HasDatatypeInfo a, All2 HasElmType (Code a)) => Options -> Name.Qualified -> Definition+deriveElmTypeDefinition options name =+  case datatypeInfo (Proxy @a) of+    ADT _mname _tname (Record _cname fields :* Nil) ->+      Definition.Alias name (Type.Record (recordFields fields))++    ADT _mname _tname cs ->+      Definition.Type name (constructors cs)++    Newtype _mname _tname (Record _cname fields) ->+      Definition.Alias name (Type.Record (recordFields fields))++    Newtype _mname _tname c ->+      Definition.Type name (constructors (c :* Nil))+  where+    recordFields :: All HasElmType xs => NP FieldInfo xs -> [(Name.Field, Type v)]+    recordFields Nil = []+    recordFields (f :* fs) = field f : recordFields fs++    field :: forall x v. HasElmType x => FieldInfo x -> (Name.Field, Type v)+    field (FieldInfo fname) =+      (fromString $ fieldLabelModifier options fname, elmType @x)++    constructors :: All2 HasElmType xss => NP ConstructorInfo xss -> [(Name.Constructor, [Type v])]+    constructors Nil = []+    constructors (c :* cs) = constructor c : constructors cs++    constructor :: forall xs v. All HasElmType xs => ConstructorInfo xs -> (Name.Constructor, [Type v])+    constructor (Constructor cname) = (fromString cname, constructorFields $ shape @_ @xs)+    constructor (Infix _ _ _) = panic "Infix constructors are not supported"+    constructor (Record cname fs) = (fromString cname, [Type.Record $ recordFields fs])++    constructorFields :: All HasElmType xs => Shape xs -> [Type v]+    constructorFields ShapeNil = []+    constructorFields s@(ShapeCons _) = go s+      where+        go :: forall x xs v. (HasElmType x, All HasElmType xs) => Shape (x ': xs) -> [Type v]+        go (ShapeCons s') = elmType @x : constructorFields s'++-- | Automatically create an Elm JSON decoder definition given a Haskell type.+--+-- This is suitable for use as a @'HasElmDecoderDefinition' 'Aeson.Value'@ instance:+--+-- @+-- instance 'HasElmDecoderDefinition' 'Aeson.Value' MyType where+--   'elmDecoderDefinition' =+--     'deriveElmJSONDecoder' \@MyType 'defaultOptions' 'Aeson.defaultOptions' "Api.MyType.decoder"+-- @+--+-- Uses the given 'Aeson.Options' to match the JSON format of derived+-- 'Aeson.FromJSON' and 'Aeson.ToJSON' instances.+deriveElmJSONDecoder+  :: forall a+  . (HasDatatypeInfo a, HasElmType a, All2 (HasElmDecoder Aeson.Value) (Code a))+  => Options+  -> Aeson.Options+  -> Name.Qualified+  -> Definition+deriveElmJSONDecoder options aesonOptions decoderName =+  Definition.Constant decoderName (Type.App "Json.Decode.Decoder" $ elmType @a) $+  case datatypeInfo (Proxy @a) of+    ADT _mname _tname (Record _cname fields :* Nil) ->+      decodeRecord fields $+      Expression.App "Json.Decode.succeed" $+      case Type.appsView (elmType @a) of+        (Type.Record fieldTypes, _) ->+          explicitRecordConstructor $ fst <$> fieldTypes++        _ ->+          Expression.Global typeName++    ADT _mname _tname cs ->+      decodeConstructors $ constructors cs++    Newtype _mname _tname (Record _cname fields) ->+      decodeRecord fields $+      Expression.App "Json.Decode.succeed" $+      case Type.appsView (elmType @a) of+        (Type.Record fieldTypes, _) ->+          explicitRecordConstructor $ fst <$> fieldTypes++        _ ->+          Expression.Global typeName++    Newtype _mname _tname c ->+      decodeConstructors $ constructors (c :* Nil)+  where+    typeName@(Name.Qualified moduleName_ _) =+      case Type.appsView (elmType @a) of+        (Type.Global tname, _) -> tname++        _ ->+          panic "Can't automatically derive JSON decoder for an anonymous Elm type"++    constructors+      :: All2 (HasElmDecoder Aeson.Value) xss+      => NP ConstructorInfo xss+      -> [(String, [Expression v])]+    constructors Nil = []+    constructors (c :* cs) = constructor c : constructors cs++    constructor+      :: forall xs v+      . All (HasElmDecoder Aeson.Value) xs+      => ConstructorInfo xs+      -> (String, [Expression v])+    constructor (Constructor cname) =+      (cname, constructorFields $ shape @_ @xs)+    constructor (Infix _ _ _) =+      panic "Infix constructors are not supported"+    constructor (Record cname fs) =+      (cname, [decodeRecord fs $ explicitRecordConstructor $ recordFieldNames fs])++    constructorFields+      :: All (HasElmDecoder Aeson.Value) xs+      => Shape xs+      -> [Expression v]+    constructorFields ShapeNil = []+    constructorFields s@(ShapeCons _) = go s+      where+        go+          :: forall x xs v+          . (HasElmDecoder Aeson.Value x, All (HasElmDecoder Aeson.Value) xs)+          => Shape (x ': xs)+          -> [Expression v]+        go (ShapeCons s') = elmDecoder @Aeson.Value @x : constructorFields s'++    explicitRecordConstructor+      :: [Name.Field]+      -> Expression v+    explicitRecordConstructor names =+      go mempty names+      where+        go :: HashMap Name.Field v -> [Name.Field] -> Expression v+        go locals fnames =+          case fnames of+            [] ->+              Expression.Record [(name, Expression.Var $ locals HashMap.! name) | name <- names]++            fname:fnames' ->+              Expression.Lam $ Bound.toScope $ go (HashMap.insert fname (Bound.B ()) $ Bound.F <$> locals) fnames'++    decodeRecord+      :: All (HasElmDecoder Aeson.Value) xs+      => NP FieldInfo xs+      -> Expression v+      -> Expression v+    decodeRecord (f :* Nil)+      | Aeson.unwrapUnaryRecords aesonOptions =+        unwrappedRecordField f+    decodeRecord fs =+      recordFields fs++    recordFields+      :: All (HasElmDecoder Aeson.Value) xs+      => NP FieldInfo xs+      -> Expression v+      -> Expression v+    recordFields Nil e = e+    recordFields (f :* fs) e =+      recordFields fs $ recordField f e++    isMaybe :: forall t. HasElmType t => Bool+    isMaybe =+      case Type.appsView $ elmType @t of+        (Type.Global "Maybe.Maybe", _) -> True+        _ -> False++    recordField+      :: forall x v+      . HasElmDecoder Aeson.Value x+      => FieldInfo x+      -> Expression v+      -> Expression v+    recordField (FieldInfo fname) e+      | Aeson.omitNothingFields aesonOptions && isMaybe @x =+        e Expression.|>+          Expression.apps+            "Json.Decode.Pipeline.optional"+            [ jsonFieldName fname+            , elmDecoder @Aeson.Value @x+            , "Maybe.Nothing"+            ]++      | otherwise =+        e Expression.|>+          Expression.apps+            "Json.Decode.Pipeline.required"+            [ jsonFieldName fname+            , elmDecoder @Aeson.Value @x+            ]++    unwrappedRecordField+      :: forall x v+      . HasElmDecoder Aeson.Value x+      => FieldInfo x+      -> Expression v+      -> Expression v+    unwrappedRecordField (FieldInfo _) e =+      e Expression.|> elmDecoder @Aeson.Value @x++    recordFieldNames+      :: All (HasElmDecoder Aeson.Value) xs+      => NP FieldInfo xs+      -> [Name.Field]+    recordFieldNames Nil = []+    recordFieldNames (FieldInfo fname :* fs) =+      elmField fname : recordFieldNames fs++    constructorJSONName :: String -> Text+    constructorJSONName = toS . Aeson.constructorTagModifier aesonOptions++    jsonFieldName :: String -> Expression v+    jsonFieldName = Expression.String . toS . Aeson.fieldLabelModifier aesonOptions++    elmField :: String -> Name.Field+    elmField = fromString . fieldLabelModifier options++    decodeConstructor :: String -> Expression v -> [Expression v] -> Expression v+    decodeConstructor _ constr [] =+      Expression.App "Json.Decode.succeed" constr++    decodeConstructor contentsName constr [constrField] =+      Expression.App "Json.Decode.succeed" constr Expression.|>+        Expression.apps "Json.Decode.Pipeline.required" [Expression.String (toS contentsName), constrField]++    decodeConstructor contentsName constr constrFields =+      Expression.apps+        "Json.Decode.field"+        [ Expression.String (toS contentsName)+        , foldl'+          (Expression.|>)+          (Expression.App "Json.Decode.succeed" constr)+          [ Expression.App+            "Json.Decode.Pipeline.custom"+            (Expression.apps "Json.Decode.index" [Expression.Int index, field])+          | (index, field) <- zip [0..] constrFields+          ]+        ]++    decodeConstructors :: [(String, [Expression v])] -> Expression v+    decodeConstructors [(constr, constrFields)]+      | not $ Aeson.tagSingleConstructors aesonOptions =+        let+          qualifiedConstr =+            Expression.Global $ Name.Qualified moduleName_ $ toS constr+        in+        case constrFields of+          [constrField] ->+            Expression.apps "Json.Decode.map" [qualifiedConstr, constrField]++          _ ->+            foldl'+              (Expression.|>)+              (Expression.App "Json.Decode.succeed" qualifiedConstr)+              [Expression.App+                "Json.Decode.Pipeline.custom"+                (Expression.apps "Json.Decode.index" [Expression.Int index, field])+              | (index, field) <- zip [0..] constrFields+              ]++    decodeConstructors constrs+      | Aeson.allNullaryToStringTag aesonOptions && allNullary constrs =+        "Json.Decode.string" Expression.|> Expression.App "Json.Decode.andThen" (Expression.Lam+          (Bound.toScope $ Expression.Case (pure $ Bound.B ()) $+            [ ( Pattern.String $ constructorJSONName constr+              , Bound.toScope $ Expression.App "Json.Decode.succeed" qualifiedConstr+              )+            | (constr, _) <- constrs+            , let+                qualifiedConstr =+                  Expression.Global $ Name.Qualified moduleName_ $ toS constr+            ]+            +++            [ ( Pattern.Wildcard+              , Bound.toScope $ Expression.App "Json.Decode.fail" $ Expression.String "No matching constructor"+              )+            ]+          ))++    decodeConstructors constrs =+      case Aeson.sumEncoding aesonOptions of+        Aeson.TaggedObject tagName contentsName ->+          Expression.apps "Json.Decode.field" [Expression.String $ toS tagName, "Json.Decode.string"] Expression.|>+            Expression.App "Json.Decode.andThen" (Expression.Lam+              (Bound.toScope $ Expression.Case (pure $ Bound.B ()) $+                [ ( Pattern.String $ constructorJSONName constr+                  , Bound.toScope $ decodeConstructor contentsName qualifiedConstr (fmap (Bound.F . Bound.F) <$> fields)+                  )+              | (constr, fields) <- constrs+              , let+                  qualifiedConstr =+                    Expression.Global $ Name.Qualified moduleName_ $ toS constr+              ]+              +++              [ ( Pattern.Wildcard+                , Bound.toScope $ Expression.App "Json.Decode.fail" $ Expression.String "No matching constructor"+                )+              ]+            ))++        _ -> panic "Only the DataAeson.TaggedObject sumEncoding is currently supported"++    allNullary :: forall c f. [(c, [f])] -> Bool+    allNullary = all (null . snd)++-- | Automatically create an Elm JSON encoder definition given a Haskell type.+--+-- This is suitable for use as a @'HasElmEncoderDefinition' 'Aeson.Value'@ instance:+--+-- @+-- instance 'HasElmEncoderDefinition' 'Aeson.Value' MyType where+--   'elmEncoderDefinition' =+--     'deriveElmJSONEncoder' \@MyType 'defaultOptions' 'Aeson.defaultOptions' "Api.MyType.encoder"+-- @+--+-- Uses the given 'Aeson.Options' to match the JSON format of derived+-- 'Aeson.FromJSON' and 'Aeson.ToJSON' instances.+deriveElmJSONEncoder+  :: forall a+  . (HasDatatypeInfo a, HasElmType a, All2 (HasElmEncoder Aeson.Value) (Code a))+  => Options+  -> Aeson.Options+  -> Name.Qualified+  -> Definition+deriveElmJSONEncoder options aesonOptions encoderName =+  Definition.Constant encoderName (Type.Fun (elmType @a) "Json.Encode.Value") $+  Expression.Lam $ Bound.toScope $+    case datatypeInfo (Proxy @a) of+      ADT _mname _tname (Record _cname fields :* Nil) ->+        encodeRecord fields $ pure $ Bound.B ()++      ADT _mname _tname cs ->+        encodeConstructors (constructors cs) (pure $ Bound.B ())++      Newtype _mname _tname (Record _cname fields) ->+        encodeRecord fields $ pure $ Bound.B ()++      Newtype _mname _tname c ->+        encodeConstructors (constructors (c :* Nil)) (pure $ Bound.B ())+  where+    (Name.Qualified moduleName_ _) =+      case Type.appsView (elmType @a) of+        (Type.Global tname, _) -> tname++        _ ->+          panic "Can't automatically derive JSON encoder for an anonymous Elm type"++    constructors+      :: All2 (HasElmEncoder Aeson.Value) xss+      => NP ConstructorInfo xss+      -> [(String, [Expression v])]+    constructors Nil = []+    constructors (c :* cs) = constructor c : constructors cs++    constructor+      :: forall xs v+      . All (HasElmEncoder Aeson.Value) xs+      => ConstructorInfo xs+      -> (String, [Expression v])+    constructor (Constructor cname) =+      (cname, constructorFields $ shape @_ @xs)+    constructor Infix {} =+      panic "Infix constructors are not supported"+    constructor (Record cname fs) =+      (cname, [Expression.Lam $ Bound.toScope $ encodeRecord fs (pure $ Bound.B ())])++    constructorFields+      :: All (HasElmEncoder Aeson.Value) xs+      => Shape xs+      -> [Expression v]+    constructorFields ShapeNil = []+    constructorFields s@(ShapeCons _) = go s+      where+        go+          :: forall x xs v+          . (HasElmEncoder Aeson.Value x, All (HasElmEncoder Aeson.Value) xs)+          => Shape (x ': xs)+          -> [Expression v]+        go (ShapeCons s') = elmEncoder @Aeson.Value @x : constructorFields s'++    encodeRecord+      :: All (HasElmEncoder Aeson.Value) xs+      => NP FieldInfo xs+      -> Expression v+      -> Expression v+    encodeRecord (f :* Nil) e+      | Aeson.unwrapUnaryRecords aesonOptions =+        unwrappedRecordField f e+    encodeRecord fs e =+      Expression.App "Json.Encode.object" $+        case recordFields fs e of+          (nonNullable, []) ->+            Expression.List nonNullable++          ([], nullable) ->+            Expression.App "List.concat" $ Expression.List nullable++          (nonNullable, nullable) ->+            Expression.apps "Basics.++"+              [ Expression.List nonNullable+              , Expression.App "List.concat" $ Expression.List nullable+              ]++    recordFields+      :: All (HasElmEncoder Aeson.Value) xs+      => NP FieldInfo xs+      -> Expression v+      -> ([Expression v], [Expression v])+    recordFields Nil _ = mempty+    recordFields (f :* fs) e =+      recordField f e <> recordFields fs e++    isMaybe :: forall t. HasElmType t => Bool+    isMaybe =+      case Type.appsView $ elmType @t of+        (Type.Global "Maybe.Maybe", _) -> True+        _ -> False++    recordField+      :: forall x v+      . HasElmEncoder Aeson.Value x+      => FieldInfo x+      -> Expression v+      -> ([Expression v], [Expression v])+    recordField (FieldInfo fname) e+      | Aeson.omitNothingFields aesonOptions && isMaybe @x =+        ( []+        , [ Expression.Case (Expression.App (Expression.Proj $ elmField fname) e)+            [ ( Pattern.Con "Maybe.Nothing" []+              , Bound.toScope $ Expression.List []+              )+            , ( Pattern.Con "Maybe.Just" [Pattern.Var 0]+              , Bound.toScope $+                Expression.App+                  (elmEncoder @Aeson.Value @x)+                  (Expression.App (Expression.Proj $ elmField fname) (Bound.F <$> e))+              )+            ]+          ]+        )++      | otherwise =+        ( [ Expression.tuple+            (jsonFieldName fname)+            (Expression.App (elmEncoder @Aeson.Value @x) (Expression.App (Expression.Proj $ elmField fname) e))+          ]+        , []+        )++    unwrappedRecordField+      :: forall x v+      . HasElmEncoder Aeson.Value x+      => FieldInfo x+      -> Expression v+      -> Expression v+    unwrappedRecordField (FieldInfo _) =+      Expression.App (elmEncoder @Aeson.Value @x)++    constructorJSONName :: String -> Text+    constructorJSONName = toS . Aeson.constructorTagModifier aesonOptions++    jsonFieldName :: String -> Expression v+    jsonFieldName = Expression.String . toS . Aeson.fieldLabelModifier aesonOptions++    elmField :: String -> Name.Field+    elmField = fromString . fieldLabelModifier options++    elmConstr :: String -> Name.Qualified+    elmConstr = Name.Qualified moduleName_ . fromString++    encodeConstructorFields :: [Expression v] -> Expression (Bound.Var Int v)+    encodeConstructorFields [constrField] =+      Expression.App (Bound.F <$> constrField) (pure $ Bound.B 0)++    encodeConstructorFields constrFields =+      Expression.apps+        "Json.Encode.list"+        [ "Basics.identity"+        , Expression.List+          [ Expression.App (Bound.F <$> field) (pure $ Bound.B index)+          | (index, field) <- zip [0..] constrFields+          ]+        ]++    encodeConstructors :: [(String, [Expression v])] -> Expression v -> Expression v+    encodeConstructors [(constr, constrFields)] expr+      | not $ Aeson.tagSingleConstructors aesonOptions =+        Expression.Case expr+          [ ( Pattern.Con (elmConstr constr) (Pattern.Var . fst <$> zip [0..] constrFields)+            , Bound.toScope $ encodeConstructorFields constrFields+            )+          ]++    encodeConstructors constrs expr+      | Aeson.allNullaryToStringTag aesonOptions && allNullary constrs =+        Expression.Case expr+          [ ( Pattern.Con (elmConstr constr) []+            , Bound.toScope $+              Expression.App "Json.Encode.string" $ Expression.String $ constructorJSONName constr+            )+          | (constr, _) <- constrs+          ]++    encodeConstructors constrs expr =+      case Aeson.sumEncoding aesonOptions of+        Aeson.TaggedObject tagName contentsName ->+          Expression.Case expr+            [ ( Pattern.Con (elmConstr constr) (Pattern.Var . fst <$> zip [0..] constrFields)+              , Bound.toScope $+                Expression.App "Json.Encode.object" $+                Expression.List $+                  Expression.tuple+                    (Expression.String (toS tagName))+                    (Expression.App "Json.Encode.string" $ Expression.String $ constructorJSONName constr)+                  :+                  [ Expression.tuple+                    (Expression.String (toS contentsName))+                    (encodeConstructorFields constrFields)+                  | not $ null constrFields+                  ]+              )+            | (constr, constrFields) <- constrs+            ]++        _ -> panic "Only the DataAeson.TaggedObject sumEncoding is currently supported"++    allNullary :: forall c f. [(c, [f])] -> Bool+    allNullary = all (null . snd)++-------------++instance HasElmType Int where+  elmType =+    "Basics.Int"++instance HasElmEncoder Aeson.Value Int where+  elmEncoder =+    "Json.Encode.int"++instance HasElmDecoder Aeson.Value Int where+  elmDecoder =+    "Json.Decode.int"++instance HasElmType Double where+  elmType =+    "Basics.Float"++instance HasElmEncoder Aeson.Value Double where+  elmEncoder =+    "Json.Encode.float"++instance HasElmDecoder Aeson.Value Double where+  elmDecoder =+    "Json.Decode.float"++instance HasElmType Bool where+  elmType =+    "Basics.Bool"++instance HasElmEncoder Aeson.Value Bool where+  elmEncoder =+    "Json.Encode.bool"++instance HasElmDecoder Aeson.Value Bool where+  elmDecoder =+    "Json.Decode.bool"++instance HasElmType Text where+  elmType =+    "String.String"++instance HasElmEncoder Text Text where+  elmEncoder =+    "Basics.identity"++instance HasElmDecoder Text Text where+  elmDecoder =+    "Basics.identity"++instance HasElmEncoder Text Char where+  elmEncoder =+    "String.fromChar"++instance HasElmEncoder Text Int where+  elmEncoder =+    "String.fromInt"++instance HasElmEncoder Text Double where+  elmEncoder =+    "String.fromFloat"++instance HasElmEncoder Aeson.Value Text where+  elmEncoder =+    "Json.Encode.string"++instance HasElmDecoder Aeson.Value Text where+  elmDecoder =+    "Json.Decode.string"++instance HasElmType Char where+  elmType =+    "Char.Char"++instance HasElmEncoder Aeson.Value Char where+  elmEncoder =+    "Json.Encode.string" Expression.<< "String.fromChar"++instance HasElmDecoder Aeson.Value Char where+  elmDecoder =+    "Json.Decode.string" Expression.|>+      Expression.App "Json.Decode.andThen"+      (Expression.Lam $ Bound.toScope $+        Expression.Case+          (Expression.App "String.uncons" $ Expression.Var $ Bound.B ())+          [ ( Pattern.Con "Maybe.Just" [Pattern.tuple (Pattern.Var 0) (Pattern.String "")]+            , Bound.toScope $ Expression.App "Json.Decode.succeed" $ Expression.Var $ Bound.B 0+            )+          , ( Pattern.Wildcard+            , Bound.toScope $ Expression.App "Json.Decode.fail" $ Expression.String "Not a char"+            )+          ]+      )++instance HasElmType UTCTime where+  elmType =+    "Time.Posix"++instance HasElmEncoder Aeson.Value UTCTime where+  elmEncoder =+    "Iso8601.encode"++instance HasElmDecoder Aeson.Value UTCTime where+  elmDecoder =+    "Iso8601.decoder"++instance HasElmEncoder a b => HasElmEncoder (Maybe a) (Maybe b) where+  elmEncoder = Expression.App "Maybe.map" (elmEncoder @a @b)++instance HasElmType a => HasElmType (Maybe a) where+  elmType =+    Type.App "Maybe.Maybe" (elmType @a)++instance HasElmEncoder Aeson.Value a => HasElmEncoder Aeson.Value (Maybe a) where+  elmEncoder =+    Expression.apps "Maybe.Extra.unwrap" ["Json.Encode.null", elmEncoder @Aeson.Value @a]++instance HasElmDecoder Aeson.Value a => HasElmDecoder Aeson.Value (Maybe a) where+  elmDecoder =+    Expression.App "Json.Decode.nullable" (elmDecoder @Aeson.Value @a)++instance HasElmType a => HasElmType [a] where+  elmType =+    Type.App "List.List" (elmType @a)++instance HasElmEncoder Aeson.Value a => HasElmEncoder Aeson.Value [a] where+  elmEncoder =+    Expression.App "Json.Encode.list" (elmEncoder @Aeson.Value @a)++instance HasElmDecoder Aeson.Value a => HasElmDecoder Aeson.Value [a] where+  elmDecoder =+    Expression.App "Json.Decode.list" (elmDecoder @Aeson.Value @a)++instance (HasElmType a, HasElmType b) => HasElmType (a, b) where+  elmType =+    Type.apps "Basics.," [elmType @a, elmType @b]++instance (HasElmEncoder Aeson.Value a, HasElmEncoder Aeson.Value b) => HasElmEncoder Aeson.Value (a, b) where+  elmEncoder =+    Expression.Lam $ Bound.toScope $+      Expression.Case (pure $ Bound.B ())+        [ ( Pattern.tuple (Pattern.Var 0) (Pattern.Var 1)+          , Bound.toScope $+            Expression.apps+              "Json.Encode.list"+              [ "Basics.identity"+              , Expression.List+                  [ Expression.App (elmEncoder @Aeson.Value @a) $ pure $ Bound.B 0+                  , Expression.App (elmEncoder @Aeson.Value @b) $ pure $ Bound.B 1+                  ]+              ]+          )+        ]++instance (HasElmDecoder Aeson.Value a, HasElmDecoder Aeson.Value b) => HasElmDecoder Aeson.Value (a, b) where+  elmDecoder =+    Expression.apps+      "Json.Decode.map2"+      [ "Tuple.pair"+      , Expression.apps "Json.Decode.index" [Expression.Int 0, elmDecoder @Aeson.Value @a]+      , Expression.apps "Json.Decode.index" [Expression.Int 1, elmDecoder @Aeson.Value @b]+      ]++-- | A shorthand for a list of the type definitions for+-- @'jsonDefinitions' \@MyType@ is a shorthand for creating a list of its+-- 'elmDefinition', @'elmEncoderDefinition' \@'Aeson.Value'@, and+-- @'elmDecoderDefinition' \@'Aeson.Value'@.+jsonDefinitions :: forall t. (HasElmDefinition t, HasElmEncoderDefinition Aeson.Value t, HasElmDecoderDefinition Aeson.Value t) => [Definition]+jsonDefinitions =+  [ elmDefinition @t+  , elmEncoderDefinition @Aeson.Value @t+  , elmDecoderDefinition @Aeson.Value @t+  ]

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"