*lyxia*
2018-03-03 15:13:35.63697 UTC

1 | {-# LANGUAGE FlexibleContexts #-} |

2 | {-# LANGUAGE FlexibleInstances #-} |

3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} |

4 | {-# LANGUAGE StandaloneDeriving #-} |

5 | {-# LANGUAGE ScopedTypeVariables #-} |

6 | {-# LANGUAGE DerivingStrategies #-} |

7 | |

8 | import Data.Functor.Classes |

9 | import Data.Coerce |

10 | |

11 | |

12 | ------------------- |

13 | -- Example usage -- |

14 | ------------------- |

15 | |

16 | data Bar f = Bar { |

17 | bar1 :: f String, |

18 | bar2 :: f Int |

19 | } |

20 | |

21 | -- Two lines to derive Show1 f => Show (Bar f) |

22 | -- See also [Note about INCOHERENT] |

23 | deriving instance {-# INCOHERENT #-} Show1 f => Show (Bar (Showing f)) |

24 | instance Show1 f => Show (Bar f) where showsPrec = showingPrec |

25 | |

26 | main :: IO () |

27 | main = print (Bar (Just "") Nothing) |

28 | |

29 | |

30 | -------------------- |

31 | -- Implementation -- |

32 | -------------------- |

33 | |

34 | -- A wrapper that doesn't appear in its Show instance |

35 | -- and defers to (Show1 f) and (Show a). |

36 | newtype Showing f a = Showing (f a) |

37 | |

38 | instance (Show1 f, Show a) => Show (Showing f a) where |

39 | showsPrec d (Showing x) = showsPrec1 d x |

40 | |

41 | -- This instance is not really necessary, see [Note on small wrinkle] |

42 | deriving newtype instance Show1 f => Show1 (Showing f) |

43 | |

44 | showingPrec :: forall h f. (Show (h (Showing f)), Coercible (h f) (h (Showing f))) => Int -> h f -> ShowS |

45 | showingPrec n = showsPrec n . (coerce :: h f -> h (Showing f)) |

46 | |

47 | |

48 | -- [Note about INCOHERENT] |

49 | -- The INCOHERENT above makes this compile. |

50 | showBar :: Show1 f => Bar f -> String |

51 | showBar = show |

52 | |

53 | -- [Note on small wrinkle] |

54 | -- The (Show1 (Showing f)) instance makes this compile. |

55 | -- (i.e., showing a Bar (Showing f) via its non-incoherent instance) |

56 | showBarShowing :: Show1 f => Bar (Showing f) -> String |

57 | showBarShowing = showBar |