Merge pull request #35 from MercuryTechnologies/tagged-object-option

Configurable sum of product styling
MercuryTechnologies · Dec 2, 2021 · 9f1f470 · 9f1f470
2 parents 0366d4d + 72b0396
commit 9f1f470
Show file tree

Hide file tree

Showing 11 changed files with 319 additions and 31 deletions.
diff --git a/.golden/kotlinEnumSumOfProductWithTaggedObjectAndSingleNullarySpec/golden 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()
+}
diff --git a/.golden/kotlinEnumSumOfProductWithTaggedObjectStyleSpec/golden 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()
+}
diff --git a/.golden/kotlinRecord0SumOfProductWithTaggedObjectAndSingleNullarySpec/golden b/.golden/kotlinRecord0SumOfProductWithTaggedObjectAndSingleNullarySpec/golden
@@ -0,0 +1,6 @@
+@Parcelize
+@Serializable
+data class Record0(
+    val record0Field0: Int,
+    val record0Field1: Int,
+) : Parcelable
diff --git a/.golden/kotlinRecord0SumOfProductWithTaggedObjectStyleSpec/golden b/.golden/kotlinRecord0SumOfProductWithTaggedObjectStyleSpec/golden
@@ -0,0 +1,6 @@
+@Parcelize
+@Serializable
+data class Record0(
+    val record0Field0: Int,
+    val record0Field1: Int,
+) : Parcelable
diff --git a/.golden/kotlinRecord1SumOfProductWithTaggedObjectStyleSpec/golden b/.golden/kotlinRecord1SumOfProductWithTaggedObjectStyleSpec/golden
@@ -0,0 +1,6 @@
+@Parcelize
+@Serializable
+data class Record1(
+    val record1Field0: Int,
+    val record1Field1: Int,
+) : Parcelable
diff --git a/moat.cabal b/moat.cabal
@@ -75,6 +75,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
@@ -45,6 +45,9 @@ module Moat
     -- ** Option type and defaults
     Options,
     defaultOptions,
+    EncodingStyle (..),
+    SumOfProductEncodingOptions (..),
+    defaultSumOfProductEncodingOptions,
 
     -- ** Helper type for omissions
     KeepOrDiscard (..),
@@ -65,6 +68,7 @@ module Moat
     omitFields,
     omitCases,
     makeBase,
+    sumOfProductEncodingOptions,
 
     -- * Pretty-printing
 
@@ -675,7 +679,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
@@ -708,7 +712,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]
@@ -844,7 +848,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
@@ -873,16 +877,17 @@ mkTypeAlias typName instTys = \case
 -- | Make a void type (empty enum)
 mkVoid ::
   () =>
+  Options ->
   -- | type name
   Name ->
   -- | type variables
   [Type] ->
   -- | 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 ::
   () =>
@@ -1485,12 +1490,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
@@ -1502,7 +1509,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
@@ -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 = ""