Merge pull request #75 from MercuryTechnologies/tad/generic-newtype-test

Propagate 'Codable' bounds through MoatData tyvars

Author: tadfisher

.golden/kotlinGenericNewtypeSpec/golden

@@ -0,0 +1,3 @@
+@Parcelize
+@Serializable
+value class LTree<A : Parcelable>(val value: List<A>) : Parcelable

.golden/kotlinGenericStructSpec/golden

@@ -0,0 +1,4 @@
+data class Tree<A : Parcelable>(
+    val rootLabel: A,
+    val subForest: List<Tree<A>>,
+) : Parcelable

.golden/swiftGenericNewtypeSpec/golden

@@ -0,0 +1,4 @@
+struct LTree<A: Hashable & Codable>: Hashable, Codable {
+    typealias LTreeTag = Tagged<LTree, [A]>
+    let value: LTreeTag
+}

.golden/swiftGenericStructSpec/golden

@@ -0,0 +1,4 @@
+struct Tree<A: Hashable & Codable>: Hashable, Codable {
+    var rootLabel: A
+    var subForest: [Tree<A>]
+}

.golden/swiftMultipleTypeVariableSpec/golden

@@ -1,4 +1,4 @@
-struct Data<A, B>: CaseIterable, Hashable, Codable {
+struct Data<A: Hashable & Codable, B: Hashable & Codable>: CaseIterable, Hashable, Codable {
     var field0: A
     var field1: B
 }

.golden/swiftTypeVariableSpec/golden

@@ -1,3 +1,3 @@
-struct Data<A>: CaseIterable, Hashable, Codable {
+struct Data<A: Hashable & Codable>: CaseIterable, Hashable, Codable {
     var field0: A
 }

moat.cabal

@@ -83,6 +83,8 @@ test-suite spec
       DuplicateRecordFieldSpec
       EnumValueClassDocSpec
       EnumValueClassSpec
+      GenericNewtypeSpec
+      GenericStructSpec
       MultipleTypeVariableSpec
       StrictEnumsSpec
       StrictFieldsSpec

src/Moat/Pretty/Swift.hs

@@ -29,7 +29,7 @@ prettySwiftDataWith indent = \case
   MoatEnum {..} ->
     prettyTypeDoc "" enumDoc []
       ++ "enum "
-      ++ prettyMoatTypeHeader enumName enumTyVars
+      ++ prettyMoatTypeHeader enumName (addTyVarBounds enumTyVars enumProtocols)
       ++ prettyRawValueAndProtocols enumRawValue enumProtocols
       ++ " {"
       ++ newlineNonEmpty enumCases
@@ -42,7 +42,7 @@ prettySwiftDataWith indent = \case
   MoatStruct {..} ->
     prettyTypeDoc "" structDoc []
       ++ "struct "
-      ++ prettyMoatTypeHeader structName structTyVars
+      ++ prettyMoatTypeHeader structName (addTyVarBounds structTyVars structProtocols)
       ++ prettyRawValueAndProtocols Nothing structProtocols
       ++ " {"
       ++ newlineNonEmpty structFields
@@ -55,13 +55,13 @@ prettySwiftDataWith indent = \case
   MoatAlias {..} ->
     prettyTypeDoc "" aliasDoc []
       ++ "typealias "
-      ++ prettyMoatTypeHeader aliasName aliasTyVars
+      ++ prettyMoatTypeHeader aliasName (addTyVarBounds aliasTyVars [])
       ++ " = "
       ++ prettyMoatType aliasTyp
   MoatNewtype {..} ->
     prettyTypeDoc "" newtypeDoc []
       ++ "struct "
-      ++ prettyMoatTypeHeader newtypeName newtypeTyVars
+      ++ prettyMoatTypeHeader newtypeName (addTyVarBounds newtypeTyVars newtypeProtocols)
       ++ prettyRawValueAndProtocols Nothing newtypeProtocols
       ++ " {\n"
       ++ indents
@@ -112,17 +112,17 @@ prettyRawValueAndProtocols Nothing ps = ": " ++ prettyProtocols ps
 prettyRawValueAndProtocols (Just ty) [] = ": " ++ prettyMoatType ty
 prettyRawValueAndProtocols (Just ty) ps = ": " ++ prettyMoatType ty ++ ", " ++ prettyProtocols ps
 
+prettyProtocol :: Protocol -> String
+prettyProtocol = \case
+  Hashable -> "Hashable"
+  Codable -> "Codable"
+  Equatable -> "Equatable"
+  OtherProtocol s -> s
+
 prettyProtocols :: [Protocol] -> String
 prettyProtocols = \case
   [] -> ""
   ps -> intercalate ", " (prettyProtocol <$> ps)
-    where
-      prettyProtocol :: Protocol -> String
-      prettyProtocol = \case
-        Hashable -> "Hashable"
-        Codable -> "Codable"
-        Equatable -> "Equatable"
-        OtherProtocol s -> s
 
 -- TODO: Need a plan to avoid @error@ in these pure functions
 {-# ANN prettyTags "HLint: ignore" #-}
@@ -281,3 +281,28 @@ prettyPrivateTypes indents = go
 onLast :: (a -> a) -> [a] -> [a]
 onLast _ [] = []
 onLast f (x : xs) = x : map f xs
+
+-- | Copy protocols from the parent type to upper bounds of generic type
+--   parameters.
+--
+--   This is needed for protocols with compiler-synthesized implementations
+--   (similar to 'deriving stock'), of which there are currently three:
+--
+--   - 'Equatable'
+--   - 'Hashable'
+--   - 'Codable'
+--
+--   See the [Swift documentation](https://docs.swift.org/swift-book/documentation/the-swift-programming-language/protocols#Adopting-a-Protocol-Using-a-Synthesized-Implementation).
+addTyVarBounds :: [String] -> [Protocol] -> [String]
+addTyVarBounds tyVars protos =
+  let isSynthesized :: Protocol -> Bool
+      isSynthesized = \case
+        Hashable -> True
+        Codable -> True
+        Equatable -> True
+        OtherProtocol _ -> False
+      synthesizedProtos = filter isSynthesized protos
+      bounds = ": " ++ intercalate " & " (map prettyProtocol synthesizedProtos)
+   in case synthesizedProtos of
+        [] -> tyVars
+        _ -> map (++ bounds) tyVars

test/GenericNewtypeSpec.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+module GenericNewtypeSpec where
+
+import Common
+import Data.List.NonEmpty (NonEmpty)
+import Moat
+import Test.Hspec
+import Test.Hspec.Golden
+import Prelude
+
+newtype LTree a = LTree (NonEmpty a)
+  deriving stock (Show, Eq)
+
+mobileGenWith
+  ( defaultOptions
+      { dataAnnotations = [Parcelize, Serializable]
+      , dataInterfaces = [Parcelable]
+      , dataProtocols = [Hashable, Codable]
+      , dataRawValue = Just Str
+      , generateDocComments = False
+      }
+  )
+  ''LTree
+
+spec :: Spec
+spec =
+  describe "stays golden" $ do
+    let moduleName = "GenericNewtypeSpec"
+    it "swift" $
+      defaultGolden ("swift" <> moduleName) (showSwift @(LTree _))
+    it "kotlin" $
+      defaultGolden ("kotlin" <> moduleName) (showKotlin @(LTree _))

test/GenericStructSpec.hs

@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GenericStructSpec where
+
+import Common
+import Data.Tree (Tree)
+import Moat
+import Test.Hspec
+import Test.Hspec.Golden
+import Prelude
+
+mobileGenWith
+  ( defaultOptions
+      { dataInterfaces = [Parcelable]
+      , dataProtocols = [Hashable, Codable]
+      , generateDocComments = False
+      }
+  )
+  ''Tree
+
+spec :: Spec
+spec =
+  describe "stays golden" $ do
+    let moduleName = "GenericStructSpec"
+    it "swift" $
+      defaultGolden ("swift" <> moduleName) (showSwift @(Tree _))
+    it "kotlin" $
+      defaultGolden ("kotlin" <> moduleName) (showKotlin @(Tree _))