module Test.IOTasks.Internal.Output (
  Output, newOutput,
  putT, putLnT, printT,
  putP, putLnP, printP,
  oFlush
  ) where

import Control.Monad.Extra (ifM)

import System.Console.ANSI
import System.IO (Handle, hPutStr, hFlush)
import Data.IORef

data Output = Output
  { Output -> Handle
handle :: Handle
  , Output -> IORef TextDim
_tempSize :: IORef TextDim
  , Output -> IORef TextDim -> Handle -> String -> IO ()
_tempOutput :: IORef TextDim -> Handle -> String -> IO ()
  , Output -> IORef TextDim -> Handle -> String -> IO ()
_permanentOutput :: IORef TextDim -> Handle -> String -> IO ()
  }

oFlush :: Output -> IO ()
oFlush :: Output -> IO ()
oFlush = Handle -> IO ()
hFlush (Handle -> IO ()) -> (Output -> Handle) -> Output -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Output -> Handle
handle

data TextDim = TextDim { TextDim -> Int
width :: Int, TextDim -> Int
height :: Int, TextDim -> Int
offset :: Int } deriving (TextDim -> TextDim -> Bool
(TextDim -> TextDim -> Bool)
-> (TextDim -> TextDim -> Bool) -> Eq TextDim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextDim -> TextDim -> Bool
== :: TextDim -> TextDim -> Bool
$c/= :: TextDim -> TextDim -> Bool
/= :: TextDim -> TextDim -> Bool
Eq, Int -> TextDim -> ShowS
[TextDim] -> ShowS
TextDim -> String
(Int -> TextDim -> ShowS)
-> (TextDim -> String) -> ([TextDim] -> ShowS) -> Show TextDim
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextDim -> ShowS
showsPrec :: Int -> TextDim -> ShowS
$cshow :: TextDim -> String
show :: TextDim -> String
$cshowList :: [TextDim] -> ShowS
showList :: [TextDim] -> ShowS
Show)

emptyDim :: TextDim
emptyDim :: TextDim
emptyDim = Int -> Int -> Int -> TextDim
TextDim Int
0 Int
1 Int
0

stringDim :: String -> TextDim
stringDim :: String -> TextDim
stringDim String
"" = TextDim
emptyDim
stringDim String
s = Int -> Int -> Int -> TextDim
TextDim ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (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]
ls) ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls) (String -> Int
nonEmptyLength (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ls)
  where
    ls :: [String]
ls = String -> [String]
lines' String
s

nonEmptyLength :: String -> Int
nonEmptyLength :: String -> Int
nonEmptyLength = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ShowS -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse

lines' :: String -> [String]
lines' :: String -> [String]
lines' String
s
  | String -> Char
forall a. HasCallStack => [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = String -> [String]
lines String
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""]
  | Bool
otherwise = String -> [String]
lines String
s

shrinkDim :: TextDim -> TextDim -> TextDim
shrinkDim :: TextDim -> TextDim -> TextDim
shrinkDim (TextDim Int
w Int
h Int
o) (TextDim Int
x Int
y Int
z) = Int -> Int -> Int -> TextDim
TextDim (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x) Int
newHeight Int
newOffset
  where
    newHeight :: Int
newHeight = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-(Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    newOffset :: Int
newOffset
      | Int
newHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h = Int
z
      | Bool
otherwise = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
z

newOutput :: Handle -> IO Output
newOutput :: Handle -> IO Output
newOutput Handle
h = do
  IORef TextDim
dRef <- TextDim -> IO (IORef TextDim)
forall a. a -> IO (IORef a)
newIORef TextDim
emptyDim
  IO Bool -> IO Output -> IO Output -> IO Output
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Handle -> IO Bool
hSupportsANSI Handle
h)
    (Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ Handle
-> IORef TextDim
-> (IORef TextDim -> Handle -> String -> IO ())
-> (IORef TextDim -> Handle -> String -> IO ())
-> Output
Output Handle
h IORef TextDim
dRef (Bool -> IORef TextDim -> Handle -> String -> IO ()
resetCursorAndWrite Bool
False) (Bool -> IORef TextDim -> Handle -> String -> IO ()
resetCursorAndWrite Bool
True))
    (Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ Handle
-> IORef TextDim
-> (IORef TextDim -> Handle -> String -> IO ())
-> (IORef TextDim -> Handle -> String -> IO ())
-> Output
Output Handle
h IORef TextDim
dRef ((Handle -> String -> IO ())
-> IORef TextDim -> Handle -> String -> IO ()
forall a b. a -> b -> a
const Handle -> String -> IO ()
hPutStr') ((Handle -> String -> IO ())
-> IORef TextDim -> Handle -> String -> IO ()
forall a b. a -> b -> a
const Handle -> String -> IO ()
hPutStr))
  where
    hPutStr' :: Handle -> String -> IO ()
hPutStr' Handle
h String
s = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ if String -> Char
forall a. HasCallStack => [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then String
s else String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

resetCursorAndWrite :: Bool -> IORef TextDim -> Handle -> String -> IO ()
resetCursorAndWrite :: Bool -> IORef TextDim -> Handle -> String -> IO ()
resetCursorAndWrite Bool
perm IORef TextDim
dRef Handle
h String
s = do
  TextDim
d <- IORef TextDim -> IO TextDim
forall a. IORef a -> IO a
readIORef IORef TextDim
dRef
  Handle -> Int -> IO ()
hCursorUpLine Handle
h (TextDim -> Int
height TextDim
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Handle -> Int -> IO ()
hCursorForward Handle
h (TextDim -> Int
offset TextDim
d)
  let s' :: String
s' = TextDim -> ShowS
padString TextDim
d String
s
  Handle -> String -> IO ()
hPutStr Handle
h String
s'
  IORef TextDim -> TextDim -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TextDim
dRef (TextDim -> IO ()) -> TextDim -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
perm
    then TextDim -> TextDim -> TextDim
shrinkDim TextDim
d (String -> TextDim
stringDim String
s)
    else (String -> TextDim
stringDim String
s'){offset = offset d}

padString :: TextDim -> String -> String
padString :: TextDim -> ShowS
padString TextDim
d String
s = [String] -> String
unlines' ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> ShowS
forall a. Int -> a -> [a] -> [a]
extendTo (TextDim -> Int
width TextDim
d) Char
' ') ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [String] -> [String]
forall a. Int -> a -> [a] -> [a]
extendTo (TextDim -> Int
height TextDim
d) String
"" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines' String
s
  where
    extendTo :: Int -> a -> [a] -> [a]
    extendTo :: forall a. Int -> a -> [a] -> [a]
extendTo Int
n a
x [a]
xs = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) a
x
    unlines' :: [String] -> String
    unlines' :: [String] -> String
unlines' [String]
xs
      | Bool
newLineTerminated = [String] -> String
unlines ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
xs
      | Bool
otherwise = ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
xs
      where newLineTerminated :: Bool
newLineTerminated = String -> Char
forall a. HasCallStack => [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'

putT :: Output -> String -> IO ()
putT :: Output -> String -> IO ()
putT (Output Handle
h IORef TextDim
d IORef TextDim -> Handle -> String -> IO ()
f IORef TextDim -> Handle -> String -> IO ()
_) = IORef TextDim -> Handle -> String -> IO ()
f IORef TextDim
d Handle
h

putLnT :: Output -> String -> IO ()
putLnT :: Output -> String -> IO ()
putLnT Output
h = Output -> String -> IO ()
putT Output
h (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")

printT :: Show a => Output -> a -> IO ()
printT :: forall a. Show a => Output -> a -> IO ()
printT Output
h = Output -> String -> IO ()
putLnT Output
h (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

putP :: Output -> String -> IO ()
putP :: Output -> String -> IO ()
putP (Output Handle
h IORef TextDim
d IORef TextDim -> Handle -> String -> IO ()
_ IORef TextDim -> Handle -> String -> IO ()
g) = IORef TextDim -> Handle -> String -> IO ()
g IORef TextDim
d Handle
h

putLnP :: Output -> String -> IO ()
putLnP :: Output -> String -> IO ()
putLnP Output
h = Output -> String -> IO ()
putP Output
h (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")

printP :: Show a => Output -> a -> IO ()
printP :: forall a. Show a => Output -> a -> IO ()
printP Output
h = Output -> String -> IO ()
putLnP Output
h (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show