diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,10 @@
 
 ## Unreleased changes
 
+## 0.3.1.0
+
+- Generate correct JSON coders for record constructors for types with multiple constructors (https://github.com/folq/haskell-to-elm/issues/7)
+
 ## 0.3.0.0
 
 - Make compatible with GHC 8.8
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -178,10 +178,9 @@
 ```
 
 The rationale for having two instances of the classes for each type is that we
-both have to describe how the type is defined with the unapplied instances,
-which generates parameterised types, encoders, and decoders, and then we have
-to describe how to actually use those parameterised entities with the applied
-instances.
+both have to describe how the _type_ is defined (with the unapplied instances),
+which generates parameterised definitions, and then we describe how to actually
+use those parameterised definitions with the applied instances.
 
 These instances print the following code when run:
 
@@ -226,17 +225,38 @@
             Json.Decode.fail "No matching constructor")
 ```
 
-Notice that the generator encoder and decoder are parameterised by the encoder
-and decoder for their argument.
-
-In an actual project we would be writing the code to disk instead of printing it.
+Notice that the generated encoder and decoder are parameterised by the encoder
+and decoder for the type arguments.
 
 See [this file](examples/Parameterised.hs) for the full code with imports.
 
+## Using `DerivingVia` to reduce boilerplate
+
+We can use the `DerivingVia` extension to reduce some of the boilerplate that
+this library requires. This requires GHC version >= 8.8, because earlier
+versions had a bug that prevented it to work.
+
+In [this file](examples/DerivingVia.hs) we define a type called `ElmType` that
+we derive both the `haskell-to-elm` and Aeson classes through.
+
+After having defined that type, the code for `User` is simply:
+
+```haskell
+data User = User
+  { _name :: Text
+  , _age :: Int
+  } deriving (Generic, SOP.Generic, SOP.HasDatatypeInfo)
+    deriving (Aeson.ToJSON, Aeson.FromJSON, HasElmType, HasElmDecoder Aeson.Value, HasElmEncoder Aeson.Value) via ElmType "Api.User.User" User
+```
+
+This also means that we can ensure that we pass the same Aeson options to this library's
+Elm code generation functions and Aeson's JSON derivation functions, meaning that we don't
+risk mismatched JSON formats.
+
 ## Roadmap
 
 - [x] Derive JSON encoders and generically
-  - [ ] Support all Aeson options
+  - [ ] Support all Aeson options ([issue here](https://github.com/folq/haskell-to-elm/issues/10))
 - [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
diff --git a/examples/DerivingVia.hs b/examples/DerivingVia.hs
new file mode 100644
--- /dev/null
+++ b/examples/DerivingVia.hs
@@ -0,0 +1,108 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingVia #-}
+{-# language FlexibleContexts #-}
+{-# language KindSignatures #-}
+{-# language MultiParamTypeClasses #-}
+{-# language OverloadedStrings #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language UndecidableInstances #-}
+module DerivingVia where
+
+import qualified Data.Aeson as Aeson
+import Data.Foldable
+import qualified Data.HashMap.Lazy as HashMap
+import Data.Proxy
+import Data.String (fromString)
+import qualified Data.Text as Text
+import Data.Text (Text)
+import qualified Generics.SOP as SOP
+import GHC.Generics (Generic, Rep)
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
+
+import qualified Language.Elm.Name as Name
+import qualified Language.Elm.Pretty as Pretty
+import qualified Language.Elm.Simplification as Simplification
+import Language.Haskell.To.Elm
+
+-------------------------------------------------------------------------------
+-- A type to derive via, which should typically only be defined once per project.
+
+newtype ElmType (name :: Symbol) a
+  = ElmType a
+
+instance
+  (Generic a, Aeson.GToJSON Aeson.Zero (Rep a)) =>
+  Aeson.ToJSON (ElmType name a)
+  where
+  toJSON (ElmType a) =
+    Aeson.genericToJSON Aeson.defaultOptions {Aeson.fieldLabelModifier = dropWhile (== '_')} a
+
+instance
+  (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) =>
+  Aeson.FromJSON (ElmType name a)
+  where
+  parseJSON =
+    fmap ElmType . Aeson.genericParseJSON Aeson.defaultOptions {Aeson.fieldLabelModifier = dropWhile (== '_')}
+
+instance
+  (SOP.HasDatatypeInfo a, SOP.All2 HasElmType (SOP.Code a), KnownSymbol name) =>
+  HasElmType (ElmType name a)
+  where
+  elmDefinition =
+    Just
+      $ deriveElmTypeDefinition @a defaultOptions {fieldLabelModifier = dropWhile (== '_')}
+      $ fromString $ symbolVal $ Proxy @name
+
+instance
+  (SOP.HasDatatypeInfo a, HasElmType a, SOP.All2 (HasElmDecoder Aeson.Value) (SOP.Code a), HasElmType (ElmType name a), KnownSymbol name) =>
+  HasElmDecoder Aeson.Value (ElmType name a)
+  where
+  elmDecoderDefinition =
+    Just
+      $ deriveElmJSONDecoder
+        @a
+        defaultOptions {fieldLabelModifier = dropWhile (== '_')}
+        Aeson.defaultOptions {Aeson.fieldLabelModifier = dropWhile (== '_')}
+      $ Name.Qualified moduleName $ lowerName <> "Decoder"
+    where
+      Name.Qualified moduleName name = fromString $ symbolVal $ Proxy @name
+      lowerName = Text.toLower (Text.take 1 name) <> Text.drop 1 name
+
+instance
+  (SOP.HasDatatypeInfo a, HasElmType a, SOP.All2 (HasElmEncoder Aeson.Value) (SOP.Code a), HasElmType (ElmType name a), KnownSymbol name) =>
+  HasElmEncoder Aeson.Value (ElmType name a)
+  where
+  elmEncoderDefinition =
+    Just
+      $ deriveElmJSONEncoder
+        @a
+        defaultOptions {fieldLabelModifier = dropWhile (== '_')}
+        Aeson.defaultOptions {Aeson.fieldLabelModifier = dropWhile (== '_')}
+      $ Name.Qualified moduleName $ lowerName <> "Encoder"
+    where
+      Name.Qualified moduleName name = fromString $ symbolVal $ Proxy @name
+      lowerName = Text.toLower (Text.take 1 name) <> Text.drop 1 name
+
+-------------------------------------------------------------------------------
+
+data User = User
+  { _name :: Text
+  , _age :: Int
+  } deriving (Generic, SOP.Generic, SOP.HasDatatypeInfo)
+    deriving (Aeson.ToJSON, Aeson.FromJSON, HasElmType, HasElmDecoder Aeson.Value, HasElmEncoder Aeson.Value) via ElmType "Api.User.User" User
+
+main :: IO ()
+main = do
+  let
+    definitions =
+      Simplification.simplifyDefinition <$>
+        jsonDefinitions @User
+
+    modules =
+      Pretty.modules definitions
+
+  forM_ (HashMap.toList modules) $ \(_moduleName, contents) ->
+    print contents
diff --git a/haskell-to-elm.cabal b/haskell-to-elm.cabal
--- a/haskell-to-elm.cabal
+++ b/haskell-to-elm.cabal
@@ -1,13 +1,13 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.34.1.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9e59ffab4bdc032dd26d95e1ed709e107c6cc2ecac032d51ab4d8bac15ede294
+-- hash: fe23343d3ed509c0df894e027c919960fc7a515239ad623bba6e7e3cfbb9cd6e
 
 name:           haskell-to-elm
-version:        0.3.0.0
+version:        0.3.1.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
@@ -37,7 +37,7 @@
   exposed-modules:
       Language.Haskell.To.Elm
   other-modules:
-      Paths_haskell_to_elm
+      Language.Haskell.To.Elm.DataShape
   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
@@ -52,9 +52,33 @@
     , unordered-containers >=0.2.8
   default-language: Haskell2010
 
+executable deriving-via-example
+  main-is: DerivingVia.hs
+  other-modules:
+      Parameterised
+      User
+      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.3.0 && <0.3.1
+    , generics-sop >=0.4.0 && <0.6.0
+    , haskell-to-elm
+    , text >=1.2.0
+    , time >=1.8.0
+    , unordered-containers >=0.2.8
+  if !flag(examples)
+    buildable: False
+  default-language: Haskell2010
+
 executable parameterised-example
   main-is: Parameterised.hs
   other-modules:
+      DerivingVia
       User
       Paths_haskell_to_elm
   hs-source-dirs:
@@ -77,6 +101,7 @@
 executable user-example
   main-is: User.hs
   other-modules:
+      DerivingVia
       Parameterised
       Paths_haskell_to_elm
   hs-source-dirs:
diff --git a/src/Language/Haskell/To/Elm.hs b/src/Language/Haskell/To/Elm.hs
--- a/src/Language/Haskell/To/Elm.hs
+++ b/src/Language/Haskell/To/Elm.hs
@@ -18,15 +18,18 @@
 
 import qualified Bound
 import qualified Data.Aeson as Aeson
+import Data.Bifunctor (first, second)
 import Data.Foldable
 import Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as HashMap
 import qualified Data.Kind
 import Data.Maybe (catMaybes)
+import Data.Proxy
 import Data.String
 import Data.Text (Text)
 import Data.Time
-import Generics.SOP as SOP
+import Data.Void
+import qualified Generics.SOP as SOP
 import GHC.TypeLits
 
 import Language.Elm.Definition (Definition)
@@ -37,6 +40,7 @@
 import qualified Language.Elm.Pattern as Pattern
 import Language.Elm.Type (Type)
 import qualified Language.Elm.Type as Type
+import Language.Haskell.To.Elm.DataShape
 
 -------------------------------------------------------------------------------
 -- * Classes
@@ -165,15 +169,19 @@
   deriveParameterisedElmTypeDefinition =
     deriveParameterisedElmTypeDefinition @(numParams + 1) @(f (Parameter numParams))
 
-instance (KnownNat numParams, HasDatatypeInfo a, All2 HasElmType (Code a)) => DeriveParameterisedElmTypeDefinition numParams (a :: Data.Kind.Type) where
+instance (KnownNat numParams, SOP.HasDatatypeInfo a, SOP.All2 HasElmType (SOP.Code a)) => DeriveParameterisedElmTypeDefinition numParams (a :: Data.Kind.Type) where
   deriveParameterisedElmTypeDefinition options name =
-    case constructorInfo $ datatypeInfo (Proxy @a) of
-      Record _cname fields :* Nil ->
-        Definition.Alias name numParams (bindTypeParameters $ Type.Record (recordFields fields))
+    case dataShape @a $ ConstraintFun constraintFun of
+      [(_cname, RecordConstructorShape fields)] ->
+        Definition.Alias name numParams (bindTypeParameters $ Type.Record $ first fieldName <$> fields)
 
       cs ->
-        Definition.Type name numParams (fmap (fmap bindTypeParameters) <$> constructors cs)
+        Definition.Type name numParams (fmap (fmap bindTypeParameters) <$> map (uncurry constructor) cs)
     where
+      constraintFun :: forall v t. Dict (HasElmType t) -> Type v
+      constraintFun Dict =
+        elmType @t
+
       typeParameterMap :: HashMap Name.Qualified Int
       typeParameterMap =
         HashMap.fromList [(parameterName i, i) | i <- [0..numParams - 1]]
@@ -190,29 +198,20 @@
       numParams =
         fromIntegral $ natVal $ Proxy @numParams
 
-      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 :: String -> ConstructorShape (Type v) -> (Name.Constructor, [Type v])
+      constructor cname shape =
+        ( fromString cname
+        , case shape of
+          ConstructorShape fields ->
+            fields
 
-      constructor :: forall xs v. All HasElmType xs => ConstructorInfo xs -> (Name.Constructor, [Type v])
-      constructor (Constructor cname) = (fromString cname, constructorFields $ shape @_ @xs)
-      constructor (Infix _ _ _) = error "Infix constructors are not supported"
-      constructor (Record cname fs) = (fromString cname, [Type.Record $ recordFields fs])
+          RecordConstructorShape fs ->
+            [Type.Record $ first fieldName <$> 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'
+      fieldName :: String -> Name.Field
+      fieldName =
+        fromString . fieldLabelModifier options
 
 -- ** JSON decoders
 
@@ -251,14 +250,14 @@
   deriveParameterisedElmDecoderDefinition =
     deriveParameterisedElmDecoderDefinition @(numParams + 1) @value @(f (Parameter numParams))
 
-instance (HasElmType a, KnownNat numParams, HasDatatypeInfo a, All2 (HasElmDecoder Aeson.Value) (Code a))
+instance (HasElmType a, KnownNat numParams, SOP.HasDatatypeInfo a, SOP.All2 (HasElmDecoder Aeson.Value) (SOP.Code a))
   => DeriveParameterisedElmDecoderDefinition numParams Aeson.Value (a :: Data.Kind.Type) where
   deriveParameterisedElmDecoderDefinition options aesonOptions decoderName =
     Definition.Constant decoderName numParams parameterisedType $
       parameteriseBody $
-        case constructorInfo $ datatypeInfo (Proxy @a) of
-          Record _cname fields :* Nil ->
-            decodeRecord fields $
+        case dataShape @a $ ConstraintFun constraintFun of
+          [(_cname, RecordConstructorShape fields)] ->
+            decodeRecordFields fields $
             Expression.App "Json.Decode.succeed" $
             case Type.appsView (elmType @a) of
               (Type.Record fieldTypes, _) ->
@@ -268,8 +267,12 @@
                 Expression.Global typeName
 
           cs ->
-            decodeConstructors $ constructors cs
+            decodeConstructors cs
     where
+      constraintFun :: forall v t. Dict (HasElmDecoder Aeson.Value t) -> (Type Void, Expression v)
+      constraintFun Dict =
+        (elmType @t, elmDecoder @Aeson.Value @t)
+
       numParams =
         fromIntegral $ natVal $ Proxy @numParams
 
@@ -286,9 +289,7 @@
       typeParameterMap =
         HashMap.fromList [(parameterName i, i) | i <- [0..numParams - 1]]
 
-      bindTypeParameters
-        :: Type v
-        -> Type (Bound.Var Int v)
+      bindTypeParameters :: Type v -> Type (Bound.Var Int v)
       bindTypeParameters =
         Type.bind
           (\n -> maybe (Type.Global n) (pure . Bound.B) (HashMap.lookup n typeParameterMap))
@@ -320,42 +321,7 @@
           _ ->
             error "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 _ _ _) =
-        error "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 :: [Name.Field] -> Expression v
       explicitRecordConstructor names =
         go mempty names
         where
@@ -368,72 +334,30 @@
               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)
+      decodeRecordFields :: [(String, (Type Void, Expression v))] -> Expression v -> Expression v
+      decodeRecordFields [(_, (_, decoder))] e
         | 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
+          e Expression.|> decoder
+      decodeRecordFields fs e =
+        foldl' (Expression.|>) e $ decodeRecordField <$> fs
 
-      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"
-              ]
+      decodeRecordField :: (String, (Type Void, Expression v)) -> Expression v
+      decodeRecordField (fname, (type_, decoder))
+        | Aeson.omitNothingFields aesonOptions
+        , (Type.Global "Maybe.Maybe", _) <- Type.appsView type_ =
+          Expression.apps
+            "Json.Decode.Pipeline.optional"
+            [ jsonFieldName fname
+            , decoder
+            , "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
+          Expression.apps
+            "Json.Decode.Pipeline.required"
+            [ jsonFieldName fname
+            , decoder
+            ]
 
       constructorJSONName :: String -> Text
       constructorJSONName = fromString . Aeson.constructorTagModifier aesonOptions
@@ -444,15 +368,15 @@
       elmField :: String -> Name.Field
       elmField = fromString . fieldLabelModifier options
 
-      decodeConstructor :: String -> Expression v -> [Expression v] -> Expression v
-      decodeConstructor _ constr [] =
+      decodeConstructor :: String -> Expression v -> ConstructorShape (Type Void, Expression v) -> Expression v
+      decodeConstructor _ constr (ConstructorShape []) =
         Expression.App "Json.Decode.succeed" constr
 
-      decodeConstructor contentsName constr [constrField] =
+      decodeConstructor contentsName constr (ConstructorShape [(_, fieldDecoder)]) =
         Expression.App "Json.Decode.succeed" constr Expression.|>
-          Expression.apps "Json.Decode.Pipeline.required" [Expression.String (fromString contentsName), constrField]
+          Expression.apps "Json.Decode.Pipeline.required" [Expression.String (fromString contentsName), fieldDecoder]
 
-      decodeConstructor contentsName constr constrFields =
+      decodeConstructor contentsName constr (ConstructorShape fields) =
         Expression.apps
           "Json.Decode.field"
           [ Expression.String (fromString contentsName)
@@ -461,34 +385,50 @@
             (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
+              (Expression.apps "Json.Decode.index" [Expression.Int index, fieldDecoder])
+            | (index, (_, fieldDecoder)) <- zip [0..] fields
             ]
           ]
 
-      decodeConstructors :: [(String, [Expression v])] -> Expression v
-      decodeConstructors [(constr, constrFields)]
+      decodeConstructor _contentsName constr (RecordConstructorShape fields) =
+        Expression.apps "Json.Decode.map"
+          [ constr
+          , decodeRecordFields fields $
+            Expression.App "Json.Decode.succeed" $
+              explicitRecordConstructor $ elmField . fst <$> fields
+          ]
+
+      decodeConstructors :: [(String, ConstructorShape (Type Void, Expression v))] -> Expression v
+      decodeConstructors [(constr, constrShape)]
         | not $ Aeson.tagSingleConstructors aesonOptions =
           let
             qualifiedConstr =
               Expression.Global $ Name.Qualified moduleName_ $ fromString constr
           in
-          case constrFields of
-            [constrField] ->
-              Expression.apps "Json.Decode.map" [qualifiedConstr, constrField]
+          case constrShape of
+            ConstructorShape [(_, fieldDecoder)] ->
+              Expression.apps "Json.Decode.map" [qualifiedConstr, fieldDecoder]
 
-            _ ->
+            ConstructorShape fields ->
               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
+                  (Expression.apps "Json.Decode.index" [Expression.Int index, fieldDecoder])
+                | (index, (_, fieldDecoder)) <- zip [0..] fields
                 ]
 
+            RecordConstructorShape fields ->
+              Expression.apps "Json.Decode.map"
+                [ qualifiedConstr
+                , decodeRecordFields fields $
+                  Expression.App "Json.Decode.succeed" $
+                    explicitRecordConstructor $ elmField . fst <$> fields
+                ]
+
       decodeConstructors constrs
-        | Aeson.allNullaryToStringTag aesonOptions && allNullary constrs =
+        | Aeson.allNullaryToStringTag aesonOptions && all (nullary . snd) constrs =
           "Json.Decode.string" Expression.|> Expression.App "Json.Decode.andThen" (Expression.Lam
             (Bound.toScope $ Expression.Case (pure $ Bound.B ()) $
               [ ( Pattern.String $ constructorJSONName constr
@@ -513,9 +453,11 @@
               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)
+                    , Bound.toScope $
+                      decodeConstructor contentsName qualifiedConstr $
+                      second (fmap $ Bound.F . Bound.F) <$> shape
                     )
-                | (constr, fields) <- constrs
+                | (constr, shape) <- constrs
                 , let
                     qualifiedConstr =
                       Expression.Global $ Name.Qualified moduleName_ $ fromString constr
@@ -529,9 +471,6 @@
 
           _ -> error "Only the DataAeson.TaggedObject sumEncoding is currently supported"
 
-      allNullary :: forall c f. [(c, [f])] -> Bool
-      allNullary = all (null . snd)
-
 -- ** JSON encoders
 
 -- | Automatically create an Elm JSON encoder definition given a Haskell type.
@@ -568,19 +507,24 @@
   deriveParameterisedElmEncoderDefinition =
     deriveParameterisedElmEncoderDefinition @(numParams + 1) @value @(f (Parameter numParams))
 
-instance (HasElmType a, KnownNat numParams, HasDatatypeInfo a, All2 (HasElmEncoder Aeson.Value) (Code a))
+instance (HasElmType a, KnownNat numParams, SOP.HasDatatypeInfo a, SOP.All2 (HasElmEncoder Aeson.Value) (SOP.Code a))
   => DeriveParameterisedElmEncoderDefinition numParams Aeson.Value (a :: Data.Kind.Type) where
   deriveParameterisedElmEncoderDefinition options aesonOptions encoderName =
     Definition.Constant encoderName numParams parameterisedType $
       parameteriseBody $
         Expression.Lam $ Bound.toScope $
-          case constructorInfo $ datatypeInfo (Proxy @a) of
-            Record _cname fields :* Nil ->
-              encodeRecord fields $ pure $ Bound.B ()
+          case dataShape @a $ ConstraintFun constraintFun of
+            [(_cname, RecordConstructorShape fields)] ->
+              Expression.App "Json.Encode.object" $
+              encodedRecordFieldList fields $ pure $ Bound.B ()
 
             cs ->
-              encodeConstructors (constructors cs) (pure $ Bound.B ())
+              encodeConstructors cs (pure $ Bound.B ())
     where
+      constraintFun :: forall v t. Dict (HasElmEncoder Aeson.Value t) -> (Type Void, Expression v)
+      constraintFun Dict =
+        (elmType @t, elmEncoder @Aeson.Value @t)
+
       numParams =
         fromIntegral $ natVal $ Proxy @numParams
 
@@ -597,9 +541,7 @@
       typeParameterMap =
         HashMap.fromList [(parameterName i, i) | i <- [0..numParams - 1]]
 
-      bindTypeParameters
-        :: Type v
-        -> Type (Bound.Var Int v)
+      bindTypeParameters :: Type v -> Type (Bound.Var Int v)
       bindTypeParameters =
         Type.bind
           (\n -> maybe (Type.Global n) (pure . Bound.B) (HashMap.lookup n typeParameterMap))
@@ -631,85 +573,31 @@
           _ ->
             error "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 {} =
-        error "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
+      encodedRecordFieldList :: [(String, (Type Void, Expression v))] -> Expression v -> Expression v
+      encodedRecordFieldList [(_, (_, encoder))] 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
-                ]
+          Expression.App encoder e
+      encodedRecordFieldList fs e =
+        case foldMap (recordField e) fs of
+          (nonNullable, []) ->
+            Expression.List nonNullable
 
-      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
+          ([], nullable) ->
+            Expression.App "List.concat" $ Expression.List nullable
 
-      isMaybe :: forall t. HasElmType t => Bool
-      isMaybe =
-        case Type.appsView $ elmType @t of
-          (Type.Global "Maybe.Maybe", _) -> True
-          _ -> False
+          (nonNullable, nullable) ->
+            Expression.apps "Basics.++"
+              [ Expression.List nonNullable
+              , Expression.App "List.concat" $ Expression.List nullable
+              ]
 
       recordField
-        :: forall x v
-        . HasElmEncoder Aeson.Value x
-        => FieldInfo x
-        -> Expression v
+        :: Expression v
+        -> (String, (Type Void, Expression v))
         -> ([Expression v], [Expression v])
-      recordField (FieldInfo fname) e
-        | Aeson.omitNothingFields aesonOptions && isMaybe @x =
+      recordField e (fname, (type_, encoder))
+        | Aeson.omitNothingFields aesonOptions
+        , (Type.Global "Maybe.Maybe", _) <- Type.appsView type_ =
           ( []
           , [ Expression.Case (Expression.App (Expression.Proj $ elmField fname) e)
               [ ( Pattern.Con "Maybe.Nothing" []
@@ -717,9 +605,10 @@
                 )
               , ( Pattern.Con "Maybe.Just" [Pattern.Var 0]
                 , Bound.toScope $
-                  Expression.App
-                    (elmEncoder @Aeson.Value @x)
-                    (Expression.App (Expression.Proj $ elmField fname) (Bound.F <$> e))
+                  fmap Bound.F $
+                  Expression.tuple
+                    (jsonFieldName fname)
+                    (Expression.App encoder (Expression.App (Expression.Proj $ elmField fname) e))
                 )
               ]
             ]
@@ -728,20 +617,11 @@
         | otherwise =
           ( [ Expression.tuple
               (jsonFieldName fname)
-              (Expression.App (elmEncoder @Aeson.Value @x) (Expression.App (Expression.Proj $ elmField fname) e))
+              (Expression.App encoder (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 = fromString . Aeson.constructorTagModifier aesonOptions
 
@@ -754,31 +634,40 @@
       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 :: [(Type Void, Expression v)] -> Expression (Bound.Var Int v)
+      encodeConstructorFields [(_, encoder)] =
+        Expression.App (Bound.F <$> encoder) (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
+            [ Expression.App (Bound.F <$> encoder) (pure $ Bound.B index)
+            | (index, (_, encoder)) <- zip [0..] constrFields
             ]
           ]
 
-      encodeConstructors :: [(String, [Expression v])] -> Expression v -> Expression v
-      encodeConstructors [(constr, constrFields)] expr
+      encodeConstructors :: [(String, ConstructorShape (Type Void, Expression v))] -> Expression v -> Expression v
+      encodeConstructors [(constr, constrShape)] expr
         | not $ Aeson.tagSingleConstructors aesonOptions =
           Expression.Case expr
-            [ ( Pattern.Con (elmConstr constr) (Pattern.Var . fst <$> zip [0..] constrFields)
-              , Bound.toScope $ encodeConstructorFields constrFields
-              )
+            [ case constrShape of
+                ConstructorShape constrFields ->
+                  ( Pattern.Con (elmConstr constr) (Pattern.Var . fst <$> zip [0..] constrFields)
+                  , Bound.toScope $ encodeConstructorFields constrFields
+                  )
+
+                RecordConstructorShape recordFields ->
+                  ( Pattern.Con (elmConstr constr) [Pattern.Var 0]
+                  , Bound.toScope $
+                    Expression.App "Json.Encode.object" $
+                    encodedRecordFieldList (second (second $ fmap Bound.F) <$> recordFields) $ pure $ Bound.B 0
+                  )
             ]
 
       encodeConstructors constrs expr
-        | Aeson.allNullaryToStringTag aesonOptions && allNullary constrs =
+        | Aeson.allNullaryToStringTag aesonOptions && all (nullary . snd) constrs =
           Expression.Case expr
             [ ( Pattern.Con (elmConstr constr) []
               , Bound.toScope $
@@ -791,27 +680,35 @@
         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 (fromString tagName))
-                      (Expression.App "Json.Encode.string" $ Expression.String $ constructorJSONName constr)
-                    :
-                    [ Expression.tuple
-                      (Expression.String (fromString contentsName))
-                      (encodeConstructorFields constrFields)
-                    | not $ null constrFields
-                    ]
-                )
-              | (constr, constrFields) <- constrs
+              [ case constrShape of
+                  ConstructorShape constrFields ->
+                    ( Pattern.Con (elmConstr constr) (Pattern.Var . fst <$> zip [0..] constrFields)
+                    , Bound.toScope $
+                      Expression.App "Json.Encode.object" $
+                      Expression.List $
+                        tagTuple :
+                        [ Expression.tuple
+                          (Expression.String (fromString contentsName))
+                          (encodeConstructorFields constrFields)
+                        | not $ null constrFields
+                        ]
+                    )
+                  RecordConstructorShape recordFields ->
+                    ( Pattern.Con (elmConstr constr) [Pattern.Var 0]
+                    , Bound.toScope $
+                      Expression.App "Json.Encode.object" $
+                        Expression.List [tagTuple] Expression.++
+                        encodedRecordFieldList (second (second $ fmap Bound.F) <$> recordFields) (pure $ Bound.B 0)
+                    )
+              | (constr, constrShape) <- constrs
+              , let
+                tagTuple =
+                  Expression.tuple
+                    (Expression.String (fromString tagName))
+                    (Expression.App "Json.Encode.string" $ Expression.String $ constructorJSONName constr)
               ]
 
           _ -> error "Only the DataAeson.TaggedObject sumEncoding is currently supported"
-
-      allNullary :: forall c f. [(c, [f])] -> Bool
-      allNullary = all (null . snd)
 
 -------------
 
diff --git a/src/Language/Haskell/To/Elm/DataShape.hs b/src/Language/Haskell/To/Elm/DataShape.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/To/Elm/DataShape.hs
@@ -0,0 +1,112 @@
+{-# language AllowAmbiguousTypes #-}
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language DeriveFunctor #-}
+{-# language FlexibleContexts #-}
+{-# language GADTs #-}
+{-# language RankNTypes #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language TypeOperators #-}
+module Language.Haskell.To.Elm.DataShape where
+
+import Generics.SOP
+
+type DataShape a = [(String, ConstructorShape a)]
+
+data ConstructorShape a
+  = ConstructorShape [a]
+  | RecordConstructorShape [(String, a)]
+  deriving Functor
+
+nullary :: ConstructorShape a -> Bool
+nullary (ConstructorShape []) = True
+nullary _ = False
+
+data Dict constraint where
+  Dict :: constraint => Dict constraint
+
+newtype ConstraintFun constraint a = ConstraintFun (forall t. Dict (constraint t) -> a)
+
+dataShape
+  :: forall typ constraint a
+  . (All2 constraint (Code typ), HasDatatypeInfo typ)
+  => ConstraintFun constraint a
+  -> DataShape a
+dataShape f =
+  constructorShapes @(Code typ) @constraint f $ constructorInfo $ datatypeInfo $ Proxy @typ
+
+constructorShapes
+  :: forall constrs constraint a
+  . All2 constraint constrs
+  => ConstraintFun constraint a
+  -> NP ConstructorInfo constrs
+  -> [(String, ConstructorShape a)]
+constructorShapes f infos =
+  case infos of
+    Nil ->
+      []
+
+    info :* infos' ->
+      constructorShape f info : constructorShapes f infos'
+
+constructorShape
+  :: forall constr constraint a
+  . All constraint constr
+  => ConstraintFun constraint a
+  -> ConstructorInfo constr
+  -> (String, ConstructorShape a)
+constructorShape f info =
+  case info of
+    Constructor cname ->
+      (cname, ConstructorShape $ constructorFieldShape f $ shape @_ @constr)
+
+    Infix {} ->
+      error "Infix constructors are not supported"
+
+    Record cname fs ->
+      (cname, RecordConstructorShape $ recordFieldShape f fs)
+
+constructorFieldShape
+  :: All constraint fields
+  => ConstraintFun constraint a
+  -> Shape fields
+  -> [a]
+constructorFieldShape f shape_ =
+  case shape_ of
+    ShapeNil ->
+      []
+
+    s@(ShapeCons _) -> go f s
+      where
+        go
+          :: forall field fields constraint a
+          . (constraint field, All constraint fields)
+          => ConstraintFun constraint a
+          -> Shape (field ': fields)
+          -> [a]
+        go f'@(ConstraintFun fun) (ShapeCons s') = fun @field Dict : constructorFieldShape f' s'
+
+recordFieldShape
+  :: forall fields constraint a
+  . All constraint fields
+  => ConstraintFun constraint a
+  -> NP FieldInfo fields
+  -> [(String, a)]
+recordFieldShape f infos =
+  case infos of
+    Nil ->
+      []
+
+    info :* infos' ->
+      go f info : recordFieldShape f infos'
+
+      where
+        go
+          :: forall field
+          . constraint field
+          => ConstraintFun constraint a
+          -> FieldInfo field
+          -> (String, a)
+        go (ConstraintFun fun) (FieldInfo fname) =
+          (fname, fun @field Dict)