Merge pull request #85 from uffizio/feature-generic-show

Feature: generic `Show`
eskimor · Sep 24, 2023 · d947035 · d947035
2 parents 797c1d5 + 65613fd
commit d947035
Show file tree

Hide file tree

Showing 3 changed files with 18 additions and 4 deletions.
diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs
@@ -77,6 +77,9 @@ moduleToText settings m =
                 <> _genericsImports settings
                 <> _argonautCodecsImports settings
                 <> _foreignImports settings
+                <> if any (\ (SumType _ _ requestedInstances) -> Show `elem` requestedInstances) (psTypes m)
+                   then [ImportLine "Data.Show.Generic" Nothing (Set.fromList ["genericShow"])]
+                   else [ ]
     allImports = Map.elems $ mergeImportLines otherImports (psImportLines m)
 
 _genericsImports :: Switches.Settings -> [ImportLine]
@@ -261,6 +264,10 @@ instances settings st@(SumType t _ is) = map go is
         constraintsInner = T.intercalate ", " $ map instances sumTypeParameters
         instances params = genericInstance settings params <> ", " <> decodeJsonInstance params <> ", " <> decodeJsonFieldInstance params
         bracketWrap x = "(" <> x <> ")"
+    go Show = T.unlines
+      [ T.unwords ["instance", "show" <> _typeName t, "∷", "Show", typeInfoToText False t, "where"]
+      , "  " <> T.unwords ["show", "value", "=", "genericShow", "value"]
+      ]
     go i = "derive instance " <> T.toLower c <> _typeName t <> " :: " <> extras i <> c <> " " <> typeInfoToText False t <> postfix i
       where
         c = T.pack $ show i

diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs
@@ -26,6 +26,7 @@ module Language.PureScript.Bridge.SumType
     , sumTypeConstructors
     , recLabel
     , recValue
+    , showing
     ) where
 
 import           Control.Lens hiding (from, to)
@@ -67,7 +68,7 @@ mkSumType p = SumType (mkTypeInfo p) constructors (Encode : Decode : EncodeJson
     constructors = gToConstructors (from (undefined :: t))
 
 -- | Purescript typeclass instances that can be generated for your Haskell types.
-data Instance = Encode | EncodeJson | Decode | DecodeJson | Generic | Newtype | Eq | Ord
+data Instance = Encode | EncodeJson | Decode | DecodeJson | Generic | Newtype | Eq | Ord | Show
   deriving (Eq, Show)
 
 {- | The Purescript typeclass `Newtype` might be derivable if the original
@@ -91,6 +92,9 @@ equal _ (SumType ti dc is) = SumType ti dc . nub $ Eq : is
 order :: Ord a => Proxy a -> SumType t -> SumType t
 order _ (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is
 
+showing :: Show a => Proxy a -> SumType t -> SumType t
+showing _ (SumType ti dc is) = SumType ti dc . nub $ Show : is
+
 data DataConstructor (lang :: Language) = DataConstructor
   { _sigConstructor :: !Text
     -- ^ e.g. `Left`/`Right` for `Either`

diff --git a/test/Spec.hs b/test/Spec.hs
@@ -39,7 +39,7 @@ allTests = do
              in bst `shouldBe` ti
         it "tests with custom type Foo" $
             let prox = Proxy :: Proxy Foo
-                bst = bridgeSumType (buildBridge defaultBridge) (order prox $ mkSumType prox)
+                bst = bridgeSumType (buildBridge defaultBridge) (showing prox . order prox $ mkSumType prox)
                 st =
                     SumType
                         TypeInfo {_typePackage = "", _typeModule = "TestData", _typeName = "Foo", _typeParameters = []}
@@ -57,11 +57,11 @@ allTests = do
                                     ]
                             }
                         ]
-                        [Eq, Ord, Encode, Decode, EncodeJson, DecodeJson, Generic]
+                        [Show, Eq, Ord, Encode, Decode, EncodeJson, DecodeJson, Generic]
              in bst `shouldBe` st
         it "tests generation of for custom type Foo" $
             let prox = Proxy :: Proxy Foo
-                recType = bridgeSumType (buildBridge defaultBridge) (order prox $ mkSumType prox)
+                recType = bridgeSumType (buildBridge defaultBridge) (showing prox . order prox $ mkSumType prox)
                 recTypeText = sumTypeToText defaultSettings recType
                 txt =
                     T.stripEnd $
@@ -71,6 +71,9 @@ allTests = do
                             , "  | Bar Int"
                             , "  | FooBar Int String"
                             , ""
+                            , "instance showFoo ∷ Show Foo where"
+                            , "  show value = genericShow value"
+                            , ""
                             , "derive instance eqFoo :: Eq Foo"
                             , "derive instance ordFoo :: Ord Foo"
                             , "instance encodeJsonFoo :: EncodeJson Foo where"