diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index bb41f898..4e4b22a3 100644 --- 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 index ec2b00f5..be66e31a 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -25,6 +25,7 @@ module Language.PureScript.Bridge.SumType , sumTypeConstructors , recLabel , recValue + , showing ) where import Control.Lens hiding (from, to) @@ -66,7 +67,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 @@ -90,6 +91,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 index 8316ef40..c04b5dba 100644 --- 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"