diff --git a/.golden/kotlinEnumSumOfProductWithTaggedObjectAndSingleNullarySpec/golden b/.golden/kotlinEnumSumOfProductWithTaggedObjectAndSingleNullarySpec/golden new file mode 100644 index 0000000..451ad41 --- /dev/null +++ b/.golden/kotlinEnumSumOfProductWithTaggedObjectAndSingleNullarySpec/golden @@ -0,0 +1,14 @@ +@JsonClassDiscriminator("tag") +@Parcelize +@Serializable +sealed class Enum : Parcelable { + @Parcelize + @Serializable + @SerialName("dataCons0") + data class DataCons0(val contents: Record0) : Enum() + + @Parcelize + @Serializable + @SerialName("dataCons1") + object DataCons1 : Enum() +} \ No newline at end of file diff --git a/.golden/kotlinEnumSumOfProductWithTaggedObjectStyleSpec/golden b/.golden/kotlinEnumSumOfProductWithTaggedObjectStyleSpec/golden new file mode 100644 index 0000000..082e355 --- /dev/null +++ b/.golden/kotlinEnumSumOfProductWithTaggedObjectStyleSpec/golden @@ -0,0 +1,14 @@ +@JsonClassDiscriminator("tag") +@Parcelize +@Serializable +sealed class Enum : Parcelable { + @Parcelize + @Serializable + @SerialName("dataCons0") + data class DataCons0(val contents: Record0) : Enum() + + @Parcelize + @Serializable + @SerialName("dataCons1") + data class DataCons1(val contents: Record1) : Enum() +} \ No newline at end of file diff --git a/.golden/kotlinRecord0SumOfProductWithTaggedObjectAndSingleNullarySpec/golden b/.golden/kotlinRecord0SumOfProductWithTaggedObjectAndSingleNullarySpec/golden new file mode 100644 index 0000000..19c6cfc --- /dev/null +++ b/.golden/kotlinRecord0SumOfProductWithTaggedObjectAndSingleNullarySpec/golden @@ -0,0 +1,6 @@ +@Parcelize +@Serializable +data class Record0( + val record0Field0: Int, + val record0Field1: Int, +) : Parcelable \ No newline at end of file diff --git a/.golden/kotlinRecord0SumOfProductWithTaggedObjectStyleSpec/golden b/.golden/kotlinRecord0SumOfProductWithTaggedObjectStyleSpec/golden new file mode 100644 index 0000000..19c6cfc --- /dev/null +++ b/.golden/kotlinRecord0SumOfProductWithTaggedObjectStyleSpec/golden @@ -0,0 +1,6 @@ +@Parcelize +@Serializable +data class Record0( + val record0Field0: Int, + val record0Field1: Int, +) : Parcelable \ No newline at end of file diff --git a/.golden/kotlinRecord1SumOfProductWithTaggedObjectStyleSpec/golden b/.golden/kotlinRecord1SumOfProductWithTaggedObjectStyleSpec/golden new file mode 100644 index 0000000..e1201f1 --- /dev/null +++ b/.golden/kotlinRecord1SumOfProductWithTaggedObjectStyleSpec/golden @@ -0,0 +1,6 @@ +@Parcelize +@Serializable +data class Record1( + val record1Field0: Int, + val record1Field1: Int, +) : Parcelable \ No newline at end of file diff --git a/moat.cabal b/moat.cabal index 7c2ac00..2c8fb2b 100644 --- a/moat.cabal +++ b/moat.cabal @@ -70,6 +70,8 @@ test-suite spec Common SumOfProductSpec SumOfProductWithLinkEnumInterfaceSpec + SumOfProductWithTaggedObjectAndSingleNullarySpec + SumOfProductWithTaggedObjectStyleSpec Moat Moat.Class Moat.Pretty.Kotlin diff --git a/src/Moat.hs b/src/Moat.hs index ba128ea..29544dc 100644 --- a/src/Moat.hs +++ b/src/Moat.hs @@ -44,6 +44,9 @@ module Moat -- ** Option type and defaults Options, defaultOptions, + EncodingStyle (..), + SumOfProductEncodingOptions (..), + defaultSumOfProductEncodingOptions, -- ** Helper type for omissions KeepOrDiscard (..), @@ -64,6 +67,7 @@ module Moat omitFields, omitCases, makeBase, + sumOfProductEncodingOptions, -- * Pretty-printing @@ -662,7 +666,7 @@ consToMoatType :: consToMoatType o@Options {..} parentName instTys variant ts bs = \case [] -> do value <- lift $ newName "value" - matches <- liftCons (mkVoid parentName instTys ts) + matches <- liftCons (mkVoid o parentName instTys ts) lift $ lamE [varP value] (caseE (varE value) matches) cons -> do -- TODO: use '_' instead of matching @@ -695,7 +699,7 @@ consToMoatType o@Options {..} parentName instTys variant ts bs = \case cases <- forM cons' (liftEither . mkCase o) ourMatch <- matchProxy - =<< lift (enumExp parentName instTys dataInterfaces dataProtocols dataAnnotations cases dataRawValue ts bs) + =<< lift (enumExp parentName instTys dataInterfaces dataProtocols dataAnnotations cases dataRawValue ts bs sumOfProductEncodingOptions) pure [pure ourMatch] liftCons :: (Functor f, Applicative g) => f a -> f [g a] @@ -831,7 +835,7 @@ mkTypeTag Options {..} typName instTys = \case mkName (nameStr typName ++ "Tag") let tag = tagExp typName parentName field False - matchProxy =<< lift (enumExp parentName instTys dataInterfaces dataProtocols dataAnnotations [] dataRawValue [tag] (False, Nothing, [])) + matchProxy =<< lift (enumExp parentName instTys dataInterfaces dataProtocols dataAnnotations [] dataRawValue [tag] (False, Nothing, []) sumOfProductEncodingOptions) _ -> throwError $ NotANewtype typName -- make a newtype into a type alias @@ -860,6 +864,7 @@ mkTypeAlias typName instTys = \case -- | Make a void type (empty enum) mkVoid :: () => + Options -> -- | type name Name -> -- | type variables @@ -867,9 +872,9 @@ mkVoid :: -- | tags [Exp] -> MoatM Match -mkVoid typName instTys ts = +mkVoid Options {..} typName instTys ts = matchProxy - =<< lift (enumExp typName instTys [] [] [] [] Nothing ts (False, Nothing, [])) + =<< lift (enumExp typName instTys [] [] [] [] Nothing ts (False, Nothing, []) sumOfProductEncodingOptions) mkNewtype :: () => @@ -1462,12 +1467,14 @@ enumExp :: [Exp] -> -- | Make base? (Bool, Maybe MoatType, [Protocol]) -> + SumOfProductEncodingOptions -> Q Exp -enumExp parentName tyVars ifaces protos anns cases raw tags bs = +enumExp parentName tyVars ifaces protos anns cases raw tags bs sop = do enumInterfaces_ <- Syntax.lift ifaces enumAnnotations_ <- Syntax.lift anns enumProtocols_ <- Syntax.lift protos + sumOfProductEncodingOptions_ <- Syntax.lift sop applyBase bs $ RecConE 'MoatEnum @@ -1479,7 +1486,8 @@ enumExp parentName tyVars ifaces protos anns cases raw tags bs = ('enumCases, ListE cases), ('enumRawValue, rawValueE raw), ('enumPrivateTypes, ListE []), - ('enumTags, ListE tags) + ('enumTags, ListE tags), + ('enumSumOfProductEncodingOption, sumOfProductEncodingOptions_) ] newtypeExp :: diff --git a/src/Moat/Pretty/Kotlin.hs b/src/Moat/Pretty/Kotlin.hs index c5fe357..20b244f 100644 --- a/src/Moat/Pretty/Kotlin.hs +++ b/src/Moat/Pretty/Kotlin.hs @@ -4,7 +4,9 @@ module Moat.Pretty.Kotlin where import qualified Data.Char as Char +import Data.Functor ((<&>)) import Data.List (intercalate) +import Data.Maybe (catMaybes) import Moat.Types -- | Convert a 'MoatData' into a canonical representation in Kotlin @@ -16,7 +18,7 @@ prettyKotlinData :: MoatData -> String prettyKotlinData = \case MoatStruct {..} -> "" - ++ prettyAnnotations structAnnotations + ++ prettyAnnotations Nothing noIndent structAnnotations ++ "data class " ++ prettyMoatTypeHeader structName structTyVars ++ "(" @@ -31,10 +33,11 @@ prettyKotlinData = \case enumName enumTyVars enumCases + enumSumOfProductEncodingOption indents MoatNewtype {..} -> "" - ++ prettyAnnotations newtypeAnnotations + ++ prettyAnnotations Nothing noIndent newtypeAnnotations ++ "value class " ++ prettyMoatTypeHeader newtypeName newtypeTyVars ++ "(val " @@ -120,15 +123,22 @@ prettyMoatTypeHeader :: String -> [String] -> String prettyMoatTypeHeader name [] = name prettyMoatTypeHeader name tyVars = name ++ "<" ++ intercalate ", " tyVars ++ ">" -prettyAnnotations :: [Annotation] -> String -prettyAnnotations = concatMap (\ann -> "@" ++ prettyAnnotation ann ++ "\n") +-- | This function will take a name and the indentation level and render +-- annotations in the style '@{string}\n...'. The name parameter is only used +-- when a 'SerialName' annotation is given for a sum of product +prettyAnnotations :: Maybe String -> String -> [Annotation] -> String +prettyAnnotations mCaseNm indents = + concatMap (\ann -> indents <> "@" <> ann <> "\n") + . catMaybes + . fmap prettyAnnotation where - prettyAnnotation :: Annotation -> String + prettyAnnotation :: Annotation -> Maybe String prettyAnnotation = \case - JvmInline -> "JvmInline" - Parcelize -> "Parcelize" - Serializable -> "Serializable" - RawAnnotation s -> s + JvmInline -> Just "JvmInline" + Parcelize -> Just "Parcelize" + Serializable -> Just "Serializable" + SerialName -> mCaseNm <&> \caseNm -> "SerialName(\"" <> caseNm <> "\")" + RawAnnotation s -> Just s prettyInterfaces :: [Interface] -> String prettyInterfaces [] = "" @@ -193,6 +203,44 @@ prettyApp t1 t2 = (args, ret) -> (e1 : args, ret) go e1 e2 = ([e1], e2) +prettyTaggedObject :: + String -> + [Annotation] -> + [(String, [(Maybe String, MoatType)])] -> + String -> + SumOfProductEncodingOptions -> + String +prettyTaggedObject parentName anns cases indents SumOfProductEncodingOptions {..} = + intercalate + "\n\n" + ( cases <&> \case + (caseNm, [(_, Concrete {concreteName = concreteName})]) -> + prettyAnnotations (Just caseNm) indents anns + ++ indents + ++ "data class " + ++ toUpperFirst caseNm + ++ "(val " + ++ contentsFieldName + ++ ": " + ++ concreteName + ++ ") : " + ++ parentName + ++ "()" + (caseNm, []) -> + prettyAnnotations (Just caseNm) indents anns + ++ indents + ++ "object " + ++ toUpperFirst caseNm + ++ " : " + ++ parentName + ++ "()" + (caseNm, _) -> + error $ + "prettyTaggedObject: The data constructor " + <> caseNm + <> " can have zero or one concrete type constructor!" + ) + prettyEnum :: () => [Annotation] -> @@ -204,12 +252,14 @@ prettyEnum :: [String] -> -- | cases [(String, [(Maybe String, MoatType)])] -> + -- | encoding style + SumOfProductEncodingOptions -> -- | indents String -> String -prettyEnum anns ifaces name tyVars cases indents +prettyEnum anns ifaces name tyVars cases sop@SumOfProductEncodingOptions {..} indents | isCEnum cases = - prettyAnnotations (dontAddSerializeToEnums anns) + prettyAnnotations Nothing noIndent (dontAddSerializeToEnums anns) ++ "enum class " ++ prettyMoatTypeHeader name tyVars ++ prettyInterfaces ifaces @@ -218,12 +268,25 @@ prettyEnum anns ifaces name tyVars cases indents ++ prettyCEnumCases indents (map fst cases) ++ "}" | allConcrete cases = - prettyAnnotations anns - ++ "sealed class " - ++ prettyMoatTypeHeader name tyVars - ++ prettyInterfaces ifaces + case encodingStyle of + TaggedFlatObjectStyle -> + prettyAnnotations Nothing noIndent anns + ++ "sealed class " + ++ prettyMoatTypeHeader name tyVars + ++ prettyInterfaces ifaces + TaggedObjectStyle -> + prettyAnnotations + Nothing + noIndent + (sumAnnotations ++ anns) + ++ "sealed class " + ++ prettyMoatTypeHeader name tyVars + ++ prettyInterfaces ifaces + ++ " {\n" + ++ prettyTaggedObject name anns cases indents sop + ++ "\n}" | otherwise = - prettyAnnotations (dontAddSerializeToEnums anns) + prettyAnnotations Nothing noIndent (dontAddSerializeToEnums anns) ++ "enum class " ++ prettyMoatTypeHeader name tyVars ++ prettyInterfaces ifaces @@ -254,3 +317,6 @@ toUpperFirst :: String -> String toUpperFirst = \case [] -> [] (c : cs) -> Char.toUpper c : cs + +noIndent :: String +noIndent = "" diff --git a/src/Moat/Types.hs b/src/Moat/Types.hs index 3976ffc..3325657 100644 --- a/src/Moat/Types.hs +++ b/src/Moat/Types.hs @@ -4,15 +4,18 @@ {-# LANGUAGE DerivingStrategies #-} module Moat.Types - ( MoatType (..), - MoatData (..), + ( Annotation (..), Backend (..), - Protocol (..), + EncodingStyle (..), Interface (..), - Options (..), KeepOrDiscard (..), - Annotation (..), + MoatData (..), + MoatType (..), + Options (..), + Protocol (..), + SumOfProductEncodingOptions (..), defaultOptions, + defaultSumOfProductEncodingOptions, ) where @@ -177,7 +180,9 @@ data MoatData -- | The tags of the struct. See 'Tag'. -- -- Only used by the Swift backend. - enumTags :: [MoatType] + enumTags :: [MoatType], + -- | + enumSumOfProductEncodingOption :: SumOfProductEncodingOptions } | -- | A newtype. -- Kotlin backend: becomes a value class. @@ -238,6 +243,10 @@ data Annotation Serializable | -- | /escape hatch/ to add an arbitrary annotation RawAnnotation String + | -- | The 'SerialName' annotation is an annotation for products in a sum of + -- products and only applies when used on the sum, see + -- https://kotlin.github.io/kotlinx.serialization/kotlinx-serialization-core/kotlinx-serialization-core/kotlinx.serialization/-serial-name/index.html + SerialName deriving stock (Eq, Read, Show) deriving stock (Lift) @@ -388,8 +397,54 @@ data Options = Options -- "Optional\". The default value ('False') -- will keep it as sugar. A value of 'True' -- will expand it to be desugared. - optionalExpand :: Bool + optionalExpand :: Bool, + -- | Only applies for a sum in a sum of products. The options + -- determine the rendering style for the sum of products. + -- The user is responsible for choosing the right options + -- for the products in a SOP. See 'SumOfProductEncodingOptions' + sumOfProductEncodingOptions :: SumOfProductEncodingOptions + } + +data SumOfProductEncodingOptions = SumOfProductEncodingOptions + { -- | The encoding style for the sum of product, the library matches the options + -- available in aeson, see + -- https://hackage.haskell.org/package/aeson/docs/Data-Aeson-TH.html#t:SumEncoding + -- and 'EncodingStyle' + encodingStyle :: EncodingStyle, + -- | The annotations to add solely to sum in the sum of product, e.g. + -- in kotlinx.serialization we want to add '@JsonClassDiscriminator("tag")' + -- annotation to the sum type but not the products! + sumAnnotations :: [Annotation], + -- | The field name to use for the products, aeson uses "contents" for the TaggedObject + -- style. This is unused in the 'TaggedFlatObjectStyle' + contentsFieldName :: String } + deriving stock (Eq, Read, Show, Lift) + +-- | The resulting enum style for our datatype. This names match +-- the style in Aeson. A 'TaggedObjectStyle' will have a JSON +-- payload like, +-- +-- @ +-- { +-- "tag": ..., +-- "contents": ... +-- } +-- @ +-- +-- In 'TaggedFlatObjectStyle', the contents are unpacked at the same +-- level as "tag" +data EncodingStyle = TaggedObjectStyle | TaggedFlatObjectStyle + deriving stock (Eq, Read, Show, Lift) + +-- | The default 'SumOfProductEncodingOptions' +defaultSumOfProductEncodingOptions :: SumOfProductEncodingOptions +defaultSumOfProductEncodingOptions = + SumOfProductEncodingOptions + { encodingStyle = TaggedFlatObjectStyle, + sumAnnotations = [], + contentsFieldName = "contents" + } -- | The default 'Options'. -- @@ -413,6 +468,7 @@ data Options = Options -- , omitCases = const Keep -- , makeBase = (False, Nothing, []) -- , optionalExpand = False +-- , sumOfProductEncodingOptions = defaultSumOfProductEncodingOptions -- } -- @ defaultOptions :: Options @@ -434,7 +490,8 @@ defaultOptions = omitFields = const Keep, omitCases = const Keep, makeBase = (False, Nothing, []), - optionalExpand = False + optionalExpand = False, + sumOfProductEncodingOptions = defaultSumOfProductEncodingOptions } data KeepOrDiscard = Keep | Discard diff --git a/test/SumOfProductWithTaggedObjectAndSingleNullarySpec.hs b/test/SumOfProductWithTaggedObjectAndSingleNullarySpec.hs new file mode 100644 index 0000000..682e2e8 --- /dev/null +++ b/test/SumOfProductWithTaggedObjectAndSingleNullarySpec.hs @@ -0,0 +1,47 @@ +module SumOfProductWithTaggedObjectAndSingleNullarySpec where + +import Common +import Moat +import Test.Hspec +import Test.Hspec.Golden +import Prelude hiding (Enum) + +data Record0 = Record0 + { record0Field0 :: Int, + record0Field1 :: Int + } + +mobileGenWith + ( defaultOptions + { dataAnnotations = [Parcelize, Serializable], + dataInterfaces = [Parcelable] + } + ) + ''Record0 + +data Enum + = DataCons0 Record0 + | DataCons1 + +mobileGenWith + ( defaultOptions + { dataAnnotations = [Parcelize, Serializable, SerialName], + dataInterfaces = [Parcelable], + sumOfProductEncodingOptions = + SumOfProductEncodingOptions + { encodingStyle = TaggedObjectStyle, + sumAnnotations = [RawAnnotation "JsonClassDiscriminator(\"tag\")"], + contentsFieldName = "contents" + } + } + ) + ''Enum + +spec :: Spec +spec = + describe "stays golden" $ do + let moduleName = "SumOfProductWithTaggedObjectAndSingleNullarySpec" + it "kotlin" $ + defaultGolden ("kotlinRecord0" <> moduleName) (showKotlin @Record0) + it "kotlin" $ + defaultGolden ("kotlinEnum" <> moduleName) (showKotlin @Enum) diff --git a/test/SumOfProductWithTaggedObjectStyleSpec.hs b/test/SumOfProductWithTaggedObjectStyleSpec.hs new file mode 100644 index 0000000..cf812e7 --- /dev/null +++ b/test/SumOfProductWithTaggedObjectStyleSpec.hs @@ -0,0 +1,62 @@ +module SumOfProductWithTaggedObjectStyleSpec where + +import Common +import Moat +import Test.Hspec +import Test.Hspec.Golden +import Prelude hiding (Enum) + +data Record0 = Record0 + { record0Field0 :: Int, + record0Field1 :: Int + } + +mobileGenWith + ( defaultOptions + { dataAnnotations = [Parcelize, Serializable], + dataInterfaces = [Parcelable] + } + ) + ''Record0 + +data Record1 = Record1 + { record1Field0 :: Int, + record1Field1 :: Int + } + +mobileGenWith + ( defaultOptions + { dataAnnotations = [Parcelize, Serializable], + dataInterfaces = [Parcelable] + } + ) + ''Record1 + +data Enum + = DataCons0 Record0 + | DataCons1 Record1 + +mobileGenWith + ( defaultOptions + { dataAnnotations = [Parcelize, Serializable, SerialName], + dataInterfaces = [Parcelable], + sumOfProductEncodingOptions = + SumOfProductEncodingOptions + { encodingStyle = TaggedObjectStyle, + sumAnnotations = [RawAnnotation "JsonClassDiscriminator(\"tag\")"], + contentsFieldName = "contents" + } + } + ) + ''Enum + +spec :: Spec +spec = + describe "stays golden" $ do + let moduleName = "SumOfProductWithTaggedObjectStyleSpec" + it "kotlin" $ + defaultGolden ("kotlinRecord0" <> moduleName) (showKotlin @Record0) + it "kotlin" $ + defaultGolden ("kotlinRecord1" <> moduleName) (showKotlin @Record1) + it "kotlin" $ + defaultGolden ("kotlinEnum" <> moduleName) (showKotlin @Enum)