module Main
  (
    main
  ) where

import Control.Concurrent (threadDelay)
import Control.Monad (forM_, replicateM_)
import System.IO (hFlush, stdout)
import Text.Printf(printf)

import Data.Colour.SRGB (sRGB24)

import System.Console.ANSI
import System.Environment ( getArgs )

examples :: [(String, IO ())]
examples =
  [ ( "Cursor movement", cursorMovementExample )
  , ( "Line change", lineChangeExample )
  , ( "Set cursor position", setCursorPositionExample )
  , ( "Save restore cursor", saveRestoreCursorExample )
  , ( "Clear", clearExample )
  , ( "Line wrap", lineWrapExample )
  , ( "Scroll", scrollExample )
  , ( "Screen buffers", screenBuffersExample )
  , ( "SGR color", sgrColorExample )
  , ( "SGR other", sgrOtherExample )
  , ( "Cursor visibility", cursorVisibilityExample )
  , ( "Hyperlink", hyperlinkExample )
  , ( "Title", titleExample )
  , ( "Get cursor position", getCursorPositionExample )
  , ( "Get terminal size", getTerminalSizeExample )
  , ( "Get layer color", getLayerColorExample )
  ]

main :: IO ()
main = do
  args <- getArgs
  let numExamples = zip [1 ..] examples
  if wantHelp args
    then
      listExamples numExamples
    else do
      let wantedNumExamples = filter (isExample args) numExamples
          wantedExamples = map getExample wantedNumExamples
      stdoutSupportsANSI <- hNowSupportsANSI stdout
      if stdoutSupportsANSI
        then
          mapM_ (resetScreen >>) wantedExamples
        else
          putStrLn "Standard output does not support 'ANSI' escape codes."
 where
  wantHelp :: [String] -> Bool
  wantHelp args = "-h" `elem` args || "--help" `elem` args

  listExamples :: [(Int, (String, IO ()))] -> IO ()
  listExamples = mapM_ (\(n, (d, _)) -> putStrLn $ show n ++ ": " ++ d)

  isExample :: [String] -> (Int, (String, IO ())) -> Bool
  isExample args (n, _) = show n `elem` args

  getExample :: (Int, (String, IO ())) -> IO ()
  getExample (_, (_, example)) = example

-- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation
-- of an erased state is implementation-dependent. There may or may not be a
-- distinction between a character position in the erased state and one imaging
-- SPACE. Consequently, to reset the screen, the default graphic rendition must
-- be selected (setSGR [Reset]) before all character positions are put into the
-- erased state (clearScreen).
resetScreen :: IO ()
resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0

pause :: IO ()
pause = do
  hFlush stdout
  -- 1 second pause
  threadDelay 1000000

cursorMovementExample :: IO ()
cursorMovementExample = do
  putStrLn "Line One"
  putStr "Line Two"
  pause
  -- Line One
  -- Line Two

  cursorUp 1
  putStr " - Extras"
  pause
  -- Line One - Extras
  -- Line Two

  cursorBackward 2
  putStr "zz"
  pause
  -- Line One - Extrzz
  -- Line Two

  cursorForward 2
  putStr "- And More"
  pause
  -- Line One - Extrzz  - And More
  -- Line Two

  cursorDown 1
  putStr "Disconnected"
  pause
  -- Line One - Extrzz  - And More
  -- Line Two                     Disconnected

lineChangeExample :: IO ()
lineChangeExample = do
  putStrLn "Line One"
  putStr "Line Two"
  pause
  -- Line One
  -- Line Two

  cursorUpLine 1
  putStr "New Line One"
  pause
  -- New Line One
  -- Line Two

  cursorDownLine 1
  putStr "New Line Two"
  pause
  -- New Line One
  -- New Line Two

setCursorPositionExample :: IO ()
setCursorPositionExample = do
  putStrLn "Line One"
  putStrLn "Line Two"
  pause
  -- Line One
  -- Line Two

  setCursorPosition 0 5
  putStr "Foo"
  pause
  -- Line Foo
  -- Line Two

  setCursorPosition 1 5
  putStr "Bar"
  pause
  -- Line Foo
  -- Line Bar

  setCursorColumn 1
  putStr "oaf"
  pause
  -- Line Foo
  -- Loaf Bar

saveRestoreCursorExample :: IO ()
saveRestoreCursorExample = do
  putStr "Start sentence ..."
  pause
  -- Start sentence ...

  saveCursor
  setCursorPosition 2 3
  putStr "SPLASH!"
  pause
  -- Start sentence ...
  --
  --    SPLASH!

  restoreCursor
  putStr " end sentence, uninterrupted."
  pause
  -- Start sentence ... end sentence, uninterrupted
  --
  --    SPLASH!

clearExample :: IO ()
clearExample = do
  putStrLn "Line One"
  putStrLn "Line Two"
  pause
  -- Line One
  -- Line Two

  setCursorPosition 0 4
  clearFromCursorToScreenEnd
  pause
  -- Line

  resetScreen
  putStrLn "Line One"
  putStrLn "Line Two"
  pause
  -- Line One
  -- Line Two

  setCursorPosition 1 4
  clearFromCursorToScreenBeginning
  pause
  --
  --     Two

  resetScreen
  putStrLn "Line One"
  putStrLn "Line Two"
  pause
  -- Line One
  -- Line Two

  setCursorPosition 0 4
  clearFromCursorToLineEnd
  pause
  -- Line
  -- Line Two

  setCursorPosition 1 4
  clearFromCursorToLineBeginning
  pause
  -- Line
  --      Two

  clearLine
  pause
  -- Line

  clearScreen
  pause
  --

lineWrapExample :: IO ()
lineWrapExample = do
  putStrLn $ take 240 $ cycle "Default-line-wrap|"
  pause
  -- Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Def
  -- ault-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Defaul
  -- t-line-wrap|Default-line-wrap|Default-line-wrap|Default-line-wrap|Default-l
  disableLineWrap
  putStrLn $ take 240 $ cycle "Disable-line-wrap|"
  pause
  -- Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Disable-line-wrap|Dis
  enableLineWrap
  putStrLn $ take 240 $ cycle "Enable-line-wrap|"
  pause
  -- Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-
  -- line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wr
  -- ap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enable-line-wrap|Enab

scrollExample :: IO ()
scrollExample = do
  putStrLn "Line One"
  putStrLn "Line Two"
  putStrLn "Line Three"
  pause
  -- Line One
  -- Line Two
  -- Line Three

  scrollPageDown 2
  pause
  --
  --
  -- Line One
  -- Line Two
  -- Line Three

  scrollPageUp 3
  pause
  -- Line Two
  -- Line Three

screenBuffersExample :: IO ()
screenBuffersExample = do
  replicateM_ 5 $ putStrLn "This message is on the Normal Screen Bufffer"
  replicateM_ 5 pause
  useAlternateScreenBuffer
  replicateM_ 5 $ putStrLn "This message is on the Alternate Screen Bufffer"
  replicateM_ 5 pause
  useNormalScreenBuffer
  replicateM_ 5 $ putStrLn "This message is continuing where we left off"
  replicateM_ 5 pause

sgrColorExample :: IO ()
sgrColorExample = do
  let colors = enumFromTo minBound maxBound :: [Color]
  forM_ [Foreground, Background, Underlining] $ \layer ->  do
    forM_ [Dull, Vivid] $ \intensity -> do
      resetScreen
      forM_ colors $ \color -> do
        setSGR [Reset]
        setSGR [SetColor layer intensity color]
        setSGR [SetUnderlining SingleUnderline]
        print color
      pause
  -- The ANSI eight standard colors, 6 times in sequence (three layers and two
  -- intensities)

  resetScreen
  putStrLn "True color (24 bit color depth)"
  putStrLn "-------------------------------"
  putStrLn ""
  setSGR [SetRGBColor Foreground $ sRGB24 0 0 0]
  forM_ [0 .. 23] $ \row -> do
    forM_ [0 .. 47] $ \col -> do
      let r = row * 11
          g = 255 - r
          b = col * 5
      setSGR [SetRGBColor Background $ sRGB24 r g b]
      putStr "-"
    putStrLn ""
  replicateM_ 5 pause
  -- True colors, a swatch of 24 rows and 48 columns

  resetScreen
  putStrLn "A 256-color palette"
  putStrLn "-------------------"
  putStrLn ""

  -- First 16 colors ('system' colors in xterm protocol), in a row
  --
  -- 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 A A B B C C D D E E F F
  forM_ [Dull .. Vivid] $ \intensity -> do
    forM_ [Black .. White] $ \color -> do
      let i = fromEnum intensity * 8 + fromEnum color
          eol = i == 15
      setSGR [SetPaletteColor Background $ xtermSystem intensity color]
      setSGR [SetPaletteColor Foreground $ xtermSystem Dull Black]
      printf "%X " i
      setSGR [SetPaletteColor Foreground $ xtermSystem Vivid White]
      printf "%X" i
      if eol
        then putStrLn ""
        else do
          setSGR [Reset]
          putStr " "
  putStrLn ""

  -- Next 216 colors (6 level RGB in xterm protocol), in 12 rows of 18
  --
  -- 000 001 002 003 004 005 010 011 012 013 014 015 020 021 022 023 024 025
  -- 030 031 032 033 034 035 040 041 042 043 044 045 050 051 052 053 054 055
  -- 100 101 102 103 104 105 110 111 112 113 114 115 120 121 122 123 124 125
  -- ... and so on ...
  forM_ [0 .. 5] $ \r -> do
    forM_ [0 .. 5] $ \g -> do
      forM_ [0 .. 5] $ \b -> do
        let i = 16 + b + g * 6 + r * 36
            eol = i `mod` 18 == 15
            r' = (r + 3) `mod` 6
            g' = (g + 3) `mod` 6
            b' = (b + 3) `mod` 6
        setSGR [SetPaletteColor Foreground $ xterm6LevelRGB r' g' b']
        setSGR [SetPaletteColor Background $ xterm6LevelRGB r g b]
        putStr $ show r ++ show g ++ show b
        if eol
          then putStrLn ""
          else do
            setSGR [Reset]
            putStr " "
  putStrLn ""

  -- Final 24 colors (24 levels of gray in xterm protocol), in two rows
  --
  --   0   1   2   3   4   5   6   7   8   9  10  11
  --  12  13  14  15  16  17  18  19  20  21  22  23
  forM_ [0 .. 23] $ \y -> do
    setSGR [SetPaletteColor Foreground $ xterm24LevelGray $ (y + 12) `mod` 24]
    setSGR [SetPaletteColor Background $ xterm24LevelGray y]
    printf "%3d" y
    if y == 11
      then putStrLn ""
      else do
        setSGR [Reset]
        putStr " "
  replicateM_ 5 pause

  resetScreen
  setSGR [Reset]
  setSGR [SetUnderlining SingleUnderline]
  forM_
    (zip "Underlining: True color (24 bit color depth)" (cycle [0, 10 .. 255])) $
    \(c, i) -> do
      setSGR [SetRGBColor Underlining $ sRGB24 i 0 0]
      putChar c
  putChar '\n'
  putChar '\n'
  setSGR [Reset]
  setSGR [SetUnderlining SingleUnderline]
  forM_ (zip "Underlining: A 256-color palette" (cycle [0 .. 5])) $
    \(c, i) -> do
      setSGR [SetPaletteColor Underlining $ xterm6LevelRGB i 0 0]
      putChar c
  putChar '\n'
  replicateM_ 5 pause

sgrOtherExample :: IO ()
sgrOtherExample = do
  let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold")
                     , (SetConsoleIntensity FaintIntensity, "Faint")
                     , (SetConsoleIntensity NormalIntensity, "Normal")
                     , (SetItalicized True, "Italic")
                     , (SetItalicized False, "No Italics")
                     , (SetUnderlining SingleUnderline, "Single Underline")
                     , (SetUnderlining DoubleUnderline, "Double Underline")
                     , (SetUnderlining CurlyUnderline, "Curly Underline")
                     , (SetUnderlining DottedUnderline, "Dotted Underline")
                     , (SetUnderlining DashedUnderline, "Dashed Underline")
                     , (SetUnderlining NoUnderline, "No Underline")
                     , (SetBlinkSpeed SlowBlink, "Slow Blink")
                     , (SetBlinkSpeed RapidBlink, "Rapid Blink")
                     , (SetBlinkSpeed NoBlink, "No Blink")
                     , (SetVisible False, "Conceal")
                     , (SetVisible True, "Reveal")
                     ]
  forM_ named_styles $ \(style, name) -> do
    resetScreen
    setSGR [style]
    putStrLn name
    pause
  -- Text describing a style displayed in that style in sequence

  setSGR [SetColor Foreground Vivid Red]
  setSGR [SetColor Background Vivid Blue]

  clearScreen >> setCursorPosition 0 0
  setSGR [SetSwapForegroundBackground False]
  putStr "Red-On-Blue"
  pause
  -- Red-On-Blue

  clearScreen >> setCursorPosition 0 0
  setSGR [SetSwapForegroundBackground True]
  putStr "Blue-On-Red"
  pause
  -- Blue-On-Red

cursorVisibilityExample :: IO ()
cursorVisibilityExample = do
  putStr "Cursor Demo"
  pause
  -- Cursor Demo|

  hideCursor
  pause
  -- Cursor Demo

  showCursor
  pause
  -- Cursor Demo|

hyperlinkExample :: IO ()
hyperlinkExample = do
  putStr "Hyperlink demo: "
  hyperlink "https://example.com" "Example hyperlink\n"
  putStrLn ""
  putStrLn "Linked hyperlinks demo:"
  hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink one\n"
  hyperlinkWithId "ref" "https://example.com" "Example linked hyperlink two\n"

  replicateM_ 5 pause
  -- Hyperlink demo: Example hyperlink
  --
  -- Linked hyperlinks demo:
  -- Example linked hyperlink one
  -- Example linked hyperlink two

titleExample :: IO ()
titleExample = do
  putStr "Title Demo"
  pause
  -- ~/foo/ - ansi-terminal-ex - 83x70
  ------------------------------------
  -- Title Demo

  setTitle "Yup, I'm a new title!"
  pause
  -- Yup, I'm a new title! - ansi-terminal-ex - 83x70
  ---------------------------------------------------
  -- Title Demo

getCursorPositionExample :: IO ()
getCursorPositionExample = do
  putStrLn "         11111111112222222222"
  putStrLn "12345678901234567890123456789"
  putStr   "Report cursor position here:"
  pause
  --          11111111112222222222
  -- 12345678901234567890123456789
  -- Report cursor position here:|
  result <- getCursorPosition
  putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n"
  case result of
    Just (row, col) -> putStrLn $ "The cursor was at row number " ++
      show (row + 1) ++ " and column number " ++ show (col + 1) ++ ".\n"
    Nothing -> putStrLn "Error: unable to get the cursor position\n"
  replicateM_ 3 pause
  --          11111111112222222222
  -- 12345678901234567890123456789
  -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.
  --
  -- The cursor was at row number 3 and column number 29.

getTerminalSizeExample :: IO ()
getTerminalSizeExample = do
  result <- getTerminalSize
  case result of
    Just (h, w) -> putStrLn $ "The size of the terminal is " ++ show h ++
      " rows by " ++ show w ++ " columns.\n"
    Nothing -> putStrLn "Error: unable to get the terminal size\n"
  pause
  -- The size of the terminal is 25 rows by 80 columns.

getLayerColorExample :: IO ()
getLayerColorExample = do
  fgResult <- getLayerColor Foreground
  case fgResult of
    Just fgCol -> putStrLn $ "The reported foreground color is:\n" ++
      show fgCol ++ "\n"
    Nothing -> putStrLn "Error: unable to get the foreground color\n"
  bgResult <- getLayerColor Background
  case bgResult of
    Just bgCol -> putStrLn $ "The reported background color is:\n" ++
      show bgCol ++ "\n"
    Nothing -> putStrLn "Error: unable to get the background color\n"
