haskell-to-elm 0.3.0.0 → 0.3.1.0
raw patch · 6 files changed
+456/−290 lines, 6 filesnew-component:exe:deriving-via-examplePVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- README.md +29/−9
- examples/DerivingVia.hs +108/−0
- haskell-to-elm.cabal +29/−4
- src/Language/Haskell/To/Elm.hs +174/−277
- src/Language/Haskell/To/Elm/DataShape.hs +112/−0
CHANGELOG.md view
@@ -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
README.md view
@@ -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
+ examples/DerivingVia.hs view
@@ -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
haskell-to-elm.cabal view
@@ -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:
src/Language/Haskell/To/Elm.hs view
@@ -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) -------------
+ src/Language/Haskell/To/Elm/DataShape.hs view
@@ -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)