Generic print that truncates all Doubles in output

print.hs

{-# LANGUAGE
RecordWildCards,
MultiWayIf
  #-}


import Data.Generics.Uniplate.Data
import System.IO
import GHC.IO.Encoding
import GHC.IO.Buffer
import System.IO.Unsafe
import Data.IORef
import Numeric


-- Magic print
print' s = do
  Just enc <- hGetEncoding stdout
  hSetEncoding stdout (hackTextEncoding enc)
  bm <- hGetBuffering stdout
  hSetBuffering stdout NoBuffering
  print (transformBi hackDouble s)
  hSetBuffering stdout bm
  hSetEncoding stdout enc

main = do
  print' ([1/7 :: Double, 1/11, 0], Just (0.134556356 :: Double))
  -- Outputs ([0.1429,0.0909,0.0],Just 0.1346)

-- Awful things

hackDouble :: Double -> Double
hackDouble d = unsafePerformIO $ do
  putStr (showFFloat Nothing (fromIntegral (round (d*10000)) / 10000) "")
  putStr "\1"
  return 0

hackTextEncoder :: TextEncoder s -> IO (TextEncoder s)
hackTextEncoder BufferCodec{..} = do
  st <- newIORef 0
  return BufferCodec {
    getState = getState,
    setState = setState,
    recover = recover,
    close = close,
    encode = \bufFrom bufTo -> do
      let raw = bufRaw bufFrom
      c <- peekCharBuf raw (bufL bufFrom)
      n <- readIORef st
      if | n /= 0 -> do
             writeIORef st (n-1)
             return (InputUnderflow, bufferRemove 1 bufFrom, bufTo)
         | c == '\1' -> do
             writeIORef st 3 
             return (InputUnderflow, bufferRemove 1 bufFrom, bufTo)
         | otherwise ->
             encode bufFrom bufTo
    }

hackTextEncoding :: TextEncoding -> TextEncoding
hackTextEncoding TextEncoding{..} = TextEncoding {
  textEncodingName = textEncodingName,
  mkTextEncoder = hackTextEncoder =<< mkTextEncoder,
  mkTextDecoder = mkTextDecoder }