OVERLAPPINGを使ってShow [Char]の定義を上書きするようなやり方はやばいぞ

customshow.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-} -- これがないとエラーになる（この拡張はかなりやばい）
import Data.List

class MyShow a where
  myShow :: a -> String

instance MyShow Int where myShow = show
instance MyShow Char where myShow = show

instance MyShow a => MyShow [a] where
  myShow xs = "[" ++ concat (intersperse "," (map myShow xs)) ++ "]"

instance {-# OVERLAPPING #-} MyShow [Char] where
  myShow xs = "\"" ++ xs ++ "\""

data Showable where
  Showable :: MyShow a => a -> Showable

showAsList :: Showable -> String
showAsList (Showable x) = myShow [x]

foo :: (forall a. MyShow a => a -> a -> a -> IO ()) -> IO ()
foo f = do f 4 5 (6 :: Int)
           f 'b' 'a' 'r'

printAsList :: MyShow a => a -> IO ()
printAsList x = putStrLn $ myShow [x]

main :: IO ()
main = do
  putStrLn $ myShow ([1,2,3] :: [Int])
  putStrLn $ myShow "foo"
  foo (\x y z -> putStrLn $ myShow [x,y,z])
  putStrLn $ showAsList (Showable (42 :: Int))
  putStrLn $ showAsList (Showable 'x')
  printAsList (37 :: Int)
  printAsList 'z'

{-
実行結果：
[1,2,3]
"foo"
[4,5,6]
['b','a','r']   <-- "bar" じゃない！
[42]
['x']           <-- "x" じゃない！
[37]
['z']           <-- "z" じゃない！
-}

show.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
import Data.List

data Showable where
  Showable :: Show a => a -> Showable

showAsList :: Showable -> String
showAsList (Showable x) = show [x]

foo :: (forall a. Show a => a -> a -> a -> IO ()) -> IO ()
foo f = do f 4 5 (6 :: Int)
           f 'b' 'a' 'r'

printAsList :: Show a => a -> IO ()
printAsList x = putStrLn $ show [x]

main :: IO ()
main = do
  putStrLn $ show ([1,2,3] :: [Int])
  putStrLn $ show "foo"
  foo (\x y z -> putStrLn $ show [x,y,z])
  putStrLn $ showAsList (Showable (42 :: Int))
  putStrLn $ showAsList (Showable 'x')
  printAsList (37 :: Int)
  printAsList 'z'

{-
実行結果：
[1,2,3]
"foo"
[4,5,6]
"bar"
[42]
"x"
[37]
"z"
-}