{-# 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 (forall a. Show a => a -> String
show a
n' forall a. [a] -> [a] -> [a]
++ String
" -- " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (a
n'forall a. Num a => a -> a -> a
+a
kforall a. Num a => a -> a -> a
-a
1))
 where
  n' :: a
n' = a
k forall a. Num a => a -> a -> a
* (a
n forall a. Integral a => a -> a -> a
`div` a
k)

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

number :: Int -> String -> String
number :: Int -> ShowS
number Int
n String
s = forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ if Int
n 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 forall a. Ord a => a -> a -> Bool
< Int
k     = forall a. Int -> [a] -> [a]
take (Int
nforall a. Num a => a -> a -> a
-Int
2forall a. Num a => a -> a -> a
-Int
i) String
s forall a. [a] -> [a] -> [a]
++ String
".." forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
kforall a. Num a => a -> a -> a
-Int
i) String
s
  | Bool
otherwise = String
s
 where
  k :: Int
k = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
  i :: Int
i = if Int
n 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

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

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

ljust :: Int -> ShowS
ljust Int
n String
xs = String
xs forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
' '
rjust :: Int -> ShowS
rjust Int
n String
xs = forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
' ' forall a. [a] -> [a] -> [a]
++ String
xs
centre :: Int -> ShowS
centre Int
n String
xs =
  Int -> ShowS
ljust Int
n forall a b. (a -> b) -> a -> b
$
  forall a. Int -> a -> [a]
replicate ((Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) forall a. Integral a => a -> a -> a
`div` Int
2) Char
' ' 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 =
  forall a. Integral a => Double -> a -> String
lpercentage (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Fractional a => a -> a -> a
/ 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 =
  forall a. Integral a => Double -> a -> String
rpercentage (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Fractional a => a -> a -> a
/ 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 =
  forall r. PrintfType r => String -> r
printf String
"%.*f" Integer
places (Double
100forall a. Num a => a -> a -> a
*Double
p) 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 =
      forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Floating a => a -> a -> a
logBase Double
10 (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n) forall a. Num a => a -> a -> a
- Double
2 :: Double) 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 forall a. [a] -> [a] -> [a]
++ forall a. Integral a => Double -> a -> String
lpercentage Double
p a
n
  where
    padding :: String
padding = if Double
p 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cell] -> ShowS
$cshowList :: [Cell] -> ShowS
show :: Cell -> String
$cshow :: Cell -> String
showsPrec :: Int -> Cell -> ShowS
$cshowsPrec :: Int -> 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 = forall a b. (a -> b) -> [a] -> [b]
map [Cell] -> String
row [[Cell]]
rows
  where
    cols :: [[Cell]]
cols = forall a. [[a]] -> [[a]]
transpose [[Cell]]
rows
    widths :: [Int]
widths = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell -> String
text)) [[Cell]]
cols

    row :: [Cell] -> String
row [Cell]
cells = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse 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] forall a. [a] -> [a] -> [a]
++
  [Char -> Char -> ShowS
border Char
'|' Char
' ' String
header | String
header <- [String]
headers] forall a. [a] -> [a] -> [a]
++
  [String
line | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
headers) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rows)] forall a. [a] -> [a] -> [a]
++
  [Char -> Char -> ShowS
border Char
'|' Char
' ' String
row | String
row <- [String]
rows] forall a. [a] -> [a] -> [a]
++
  [String
line]
  where
    rows :: [String]
rows = [[Cell]] -> [String]
flattenRows [[Cell]]
table

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

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

paragraphs :: [[String]] -> [String]
paragraphs :: [[String]] -> [String]
paragraphs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse [String
""] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall a. a -> IO (IORef a)
newIORef (String -> ShowS
showString String
"")
     IORef Int
tmp <- forall a. a -> IO (IORef a)
newIORef Int
0
     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 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 -> forall a b. a -> b -> a
const (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 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
    forall a. IO a -> IO a
withBuffering (forall a. Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
withHandleTerminal Handle
stdout (forall a. a -> Maybe a
Just Handle
stderr) Terminal -> IO a
action)
   else
    forall a. IO a -> IO a
withBuffering (forall a. Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a
withHandleTerminal Handle
stdout 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 (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())) (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())) 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 ()
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ String
"") (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
""
     forall a. [a] -> IO ()
force String
s
     String -> IO ()
out String
s
     forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ShowS
res (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 = forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> ()
seqList

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

putLine :: Terminal -> String -> IO ()
putLine Terminal
tm String
s = Terminal -> String -> IO ()
putPart Terminal
tm (String
s 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 <- forall a. IORef a -> IO a
readIORef IORef Int
tmp
     let newLen :: Int
newLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
         maxLen :: Int
maxLen = forall a. Ord a => a -> a -> a
max Int
newLen Int
oldLen
     String -> IO ()
err forall a b. (a -> b) -> a -> b
$ String
s forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
maxLen forall a. Num a => a -> a -> a
- Int
newLen) Char
' ' forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
maxLen Char
'\b'
     forall a. IORef a -> a -> IO ()
writeIORef IORef Int
tmp Int
newLen

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