{-# LANGUAGE CPP #-}
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Safe #-}
#endif
{-# OPTIONS_HADDOCK hide #-}
-- | Terminal control and text helper functions. Internal QuickCheck module.
module Test.QuickCheck.Text
  ( Str(..)
  , ranges

  , number
  , short
  , showErr
  , oneLine
  , isOneLine
  , bold
  , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage
  , drawTable, Cell(..)
  , paragraphs

  , newTerminal
  , withStdioTerminal
  , withHandleTerminal
  , withNullTerminal
  , terminalOutput
  , handle
  , Terminal
  , putTemp
  , putPart
  , putLine
  )
 where

--------------------------------------------------------------------------
-- imports

import System.IO
  ( hFlush
  , hPutStr
  , stdout
  , stderr
  , Handle
  , BufferMode (..)
  , hGetBuffering
  , hSetBuffering
  , hIsTerminalDevice
  )

import Data.IORef
import Data.List (intersperse, transpose)
import Text.Printf
import Test.QuickCheck.Exception

--------------------------------------------------------------------------
-- literal string

newtype Str = MkStr String

instance Show Str where
  show :: Str -> String
show (MkStr String
s) = String
s

ranges :: (Show a, Integral a) => a -> a -> Str
ranges :: forall a. (Show a, Integral a) => a -> a -> Str
ranges a
k a
n = String -> Str
MkStr (a -> String
forall a. Show a => a -> String
show a
n' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show (a
n'a -> a -> a
forall a. Num a => a -> a -> a
+a
ka -> a -> a
forall a. Num a => a -> a -> a
-a
1))
 where
  n' :: a
n' = a
k a -> a -> a
forall a. Num a => a -> a -> a
* (a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
k)

--------------------------------------------------------------------------
-- formatting

number :: Int -> String -> String
number :: Int -> ShowS
number Int
n String
s = Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"" else String
"s"

short :: Int -> String -> String
short :: Int -> ShowS
short Int
n String
s
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k     = Int -> ShowS
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) String
s
  | Bool
otherwise = String
s
 where
  k :: Int
k = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
  i :: Int
i = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 then Int
3 else Int
0

showErr :: Show a => a -> String
showErr :: forall a. Show a => a -> String
showErr = [String] -> String
unwords ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

oneLine :: String -> String
oneLine :: ShowS
oneLine = [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

isOneLine :: String -> Bool
isOneLine :: String -> Bool
isOneLine String
xs = Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
xs

ljust :: Int -> ShowS
ljust Int
n String
xs = String
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
' '
rjust :: Int -> ShowS
rjust Int
n String
xs = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
centre :: Int -> ShowS
centre Int
n String
xs =
  Int -> ShowS
ljust Int
n ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
  Int -> Char -> String
forall a. Int -> a -> [a]
replicate ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs

lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String
lpercent :: forall a b. (Integral a, Integral b) => a -> b -> String
lpercent a
n b
k =
  Double -> b -> String
forall a. Integral a => Double -> a -> String
lpercentage (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ b -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
k) b
k

rpercent :: forall a b. (Integral a, Integral b) => a -> b -> String
rpercent a
n b
k =
  Double -> b -> String
forall a. Integral a => Double -> a -> String
rpercentage (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ b -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
k) b
k

lpercentage, rpercentage :: Integral a => Double -> a -> String
lpercentage :: forall a. Integral a => Double -> a -> String
lpercentage Double
p a
n =
  String -> Integer -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.*f" Integer
places (Double
100Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"%"
  where
    -- Show no decimal places if k <= 100,
    -- one decimal place if k <= 1000,
    -- two decimal places if k <= 10000, and so on.
    places :: Integer
    places :: Integer
places =
      Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
10 (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 :: Double) Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`max` Integer
0

rpercentage :: forall a. Integral a => Double -> a -> String
rpercentage Double
p a
n = String
padding String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> a -> String
forall a. Integral a => Double -> a -> String
lpercentage Double
p a
n
  where
    padding :: String
padding = if Double
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.1 then String
" " else String
""

data Cell = LJust String | RJust String | Centred String deriving Int -> Cell -> ShowS
[Cell] -> ShowS
Cell -> String
(Int -> Cell -> ShowS)
-> (Cell -> String) -> ([Cell] -> ShowS) -> Show Cell
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cell -> ShowS
showsPrec :: Int -> Cell -> ShowS
$cshow :: Cell -> String
show :: Cell -> String
$cshowList :: [Cell] -> ShowS
showList :: [Cell] -> ShowS
Show

text :: Cell -> String
text :: Cell -> String
text (LJust String
xs) = String
xs
text (RJust String
xs) = String
xs
text (Centred String
xs) = String
xs

-- Flatten a table into a list of rows
flattenRows :: [[Cell]] -> [String]
flattenRows :: [[Cell]] -> [String]
flattenRows [[Cell]]
rows = ([Cell] -> String) -> [[Cell]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [Cell] -> String
row [[Cell]]
rows
  where
    cols :: [[Cell]]
cols = [[Cell]] -> [[Cell]]
forall a. [[a]] -> [[a]]
transpose [[Cell]]
rows
    widths :: [Int]
widths = ([Cell] -> Int) -> [[Cell]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([Cell] -> [Int]) -> [Cell] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cell -> Int) -> [Cell] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (Cell -> String) -> Cell -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell -> String
text)) [[Cell]]
cols

    row :: [Cell] -> String
row [Cell]
cells = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" " ((Int -> Cell -> String) -> [Int] -> [Cell] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Cell -> String
cell [Int]
widths [Cell]
cells))
    cell :: Int -> Cell -> String
cell Int
n (LJust String
xs) = Int -> ShowS
ljust Int
n String
xs
    cell Int
n (RJust String
xs) = Int -> ShowS
rjust Int
n String
xs
    cell Int
n (Centred String
xs) = Int -> ShowS
centre Int
n String
xs

-- Draw a table given a header and contents
drawTable :: [String] -> [[Cell]] -> [String]
drawTable :: [String] -> [[Cell]] -> [String]
drawTable [String]
headers [[Cell]]
table =
  [String
line] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [Char -> Char -> ShowS
border Char
'|' Char
' ' String
header | String
header <- [String]
headers] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [String
line | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
headers) Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rows)] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [Char -> Char -> ShowS
border Char
'|' Char
' ' String
row | String
row <- [String]
rows] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [String
line]
  where
    rows :: [String]
rows = [[Cell]] -> [String]
flattenRows [[Cell]]
table

    headerwidth :: Int
headerwidth = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
headers)
    bodywidth :: Int
bodywidth = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
rows)
    width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
headerwidth Int
bodywidth

    line :: String
line = Char -> Char -> ShowS
border Char
'+' Char
'-' ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
'-'
    border :: Char -> Char -> ShowS
border Char
x Char
y String
xs = [Char
x, Char
y] String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
centre Int
width String
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
y, Char
x]

paragraphs :: [[String]] -> [String]
paragraphs :: [[String]] -> [String]
paragraphs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([[String]] -> [[String]]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
intersperse [String
""] ([[String]] -> [[String]])
-> ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> Bool) -> [[String]] -> [[String]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)

bold :: String -> String
-- not portable:
--bold s = "\ESC[1m" ++ s ++ "\ESC[0m"
bold :: ShowS
bold String
s = String
s -- for now

--------------------------------------------------------------------------
-- putting strings

data Terminal
  = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ())

newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal
newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal
newTerminal String -> IO ()
out String -> IO ()
err =
  do IORef ShowS
res <- ShowS -> IO (IORef ShowS)
forall a. a -> IO (IORef a)
newIORef (String -> ShowS
showString String
"")
     IORef Int
tmp <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
     Terminal -> IO Terminal
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef ShowS
-> IORef Int -> (String -> IO ()) -> (String -> IO ()) -> Terminal
MkTerminal IORef ShowS
res IORef Int
tmp String -> IO ()
out String -> IO ()
err)

withBuffering :: IO a -> IO a
withBuffering :: forall a. IO a -> IO a
withBuffering IO a
action = do
  BufferMode
mode <- Handle -> IO BufferMode
hGetBuffering Handle
stderr
  -- By default stderr is unbuffered.  This is very slow, hence we explicitly
  -- enable line buffering.
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
  IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
mode

withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
withHandleTerminal :: forall a. Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
withHandleTerminal Handle
outh Maybe Handle
merrh Terminal -> IO a
action = do
  let
    err :: String -> IO ()
err =
      case Maybe Handle
merrh of
        Maybe Handle
Nothing -> IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        Just Handle
errh -> Handle -> String -> IO ()
handle Handle
errh
  (String -> IO ()) -> (String -> IO ()) -> IO Terminal
newTerminal (Handle -> String -> IO ()
handle Handle
outh) String -> IO ()
err IO Terminal -> (Terminal -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Terminal -> IO a
action

withStdioTerminal :: (Terminal -> IO a) -> IO a
withStdioTerminal :: forall a. (Terminal -> IO a) -> IO a
withStdioTerminal Terminal -> IO a
action = do
  Bool
isatty <- Handle -> IO Bool
hIsTerminalDevice Handle
stderr
  if Bool
isatty then
    IO a -> IO a
forall a. IO a -> IO a
withBuffering (Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
forall a. Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
withHandleTerminal Handle
stdout (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
stderr) Terminal -> IO a
action)
   else
    IO a -> IO a
forall a. IO a -> IO a
withBuffering (Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
forall a. Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
withHandleTerminal Handle
stdout Maybe Handle
forall a. Maybe a
Nothing Terminal -> IO a
action)

withNullTerminal :: (Terminal -> IO a) -> IO a
withNullTerminal :: forall a. (Terminal -> IO a) -> IO a
withNullTerminal Terminal -> IO a
action =
  (String -> IO ()) -> (String -> IO ()) -> IO Terminal
newTerminal (IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())) (IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())) IO Terminal -> (Terminal -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Terminal -> IO a
action

terminalOutput :: Terminal -> IO String
terminalOutput :: Terminal -> IO String
terminalOutput (MkTerminal IORef ShowS
res IORef Int
_ String -> IO ()
_ String -> IO ()
_) = (ShowS -> String) -> IO ShowS -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"") (IORef ShowS -> IO ShowS
forall a. IORef a -> IO a
readIORef IORef ShowS
res)

handle :: Handle -> String -> IO ()
handle :: Handle -> String -> IO ()
handle Handle
h String
s = do
  Handle -> String -> IO ()
hPutStr Handle
h String
s
  Handle -> IO ()
hFlush Handle
h

putPart, putTemp, putLine :: Terminal -> String -> IO ()
putPart :: Terminal -> String -> IO ()
putPart tm :: Terminal
tm@(MkTerminal IORef ShowS
res IORef Int
_ String -> IO ()
out String -> IO ()
_) String
s =
  do Terminal -> String -> IO ()
putTemp Terminal
tm String
""
     String -> IO ()
forall a. [a] -> IO ()
force String
s
     String -> IO ()
out String
s
     IORef ShowS -> (ShowS -> ShowS) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ShowS
res (ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s)
  where
    force :: [a] -> IO ()
    force :: forall a. [a] -> IO ()
force = () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> ([a] -> ()) -> [a] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ()
forall a. [a] -> ()
seqList

    seqList :: [a] -> ()
    seqList :: forall a. [a] -> ()
seqList [] = ()
    seqList (a
x:[a]
xs) = a
x a -> () -> ()
forall a b. a -> b -> b
`seq` [a] -> ()
forall a. [a] -> ()
seqList [a]
xs

putLine :: Terminal -> String -> IO ()
putLine Terminal
tm String
s = Terminal -> String -> IO ()
putPart Terminal
tm (String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")

putTemp :: Terminal -> String -> IO ()
putTemp tm :: Terminal
tm@(MkTerminal IORef ShowS
_ IORef Int
tmp String -> IO ()
_ String -> IO ()
err) String
s =
  do Int
oldLen <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
tmp
     let newLen :: Int
newLen = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
         maxLen :: Int
maxLen = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
newLen Int
oldLen
     String -> IO ()
err (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
maxLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
newLen) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
maxLen Char
'\b'
     IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
tmp Int
newLen

--------------------------------------------------------------------------
-- the end.