ascii-holidays-0.1.0.1: Util.hs

-- Reimplementation of:
--   Bash tree: https://github.com/sergiolepore/ChristBASHTree
--   Perl tree: https://github.com/rcaputo/acme-poe-tree

-- package name: 'ascii-holidays' , 'posix-holidays' etc

-- TODO: handle screen resizes

module Util (
     getWriteAt
   , Write(..)
   , Stroke(..)

   , getNextYear
   , builtInColors
   , chunksOf

   -- Re-exports:
   , module Control.Monad
   , shuffleM
   , threadDelay
   , newStdGen, RandomGen(..), randoms
   -- , module System.Console.TermInfo
   , Color(..), getCapability, setupTermFromEnv, termColumns, termLines
   ) where

import Control.Concurrent (threadDelay)
import Control.Monad (forM_)
import Data.Time (toGregorian, utctDay, getCurrentTime)
import System.Console.Terminfo hiding (row, col)
import System.Random (randoms, RandomGen(..), newStdGen)
import System.Random.Shuffle (shuffleM)

data Stroke = Bold | Plain | Dim

-- TODO: rename
data Write = Write Int Int Stroke Color String

-- from https://rosettacode.org/wiki/Spinning_rod_animation/Text#Haskell :
-- TODO: maybe remove?:
runCapability :: Terminal -> String -> IO ()
runCapability term cap =
    forM_ (getCapability term (tiGetOutput1 cap)) (runTermOutput term)

-- Could see how many more we can work with with 'termColors' and 'ColorNumber':
builtInColors :: [Color]
builtInColors = [Black, Red, Green, Yellow, Blue, Magenta, Cyan, White]

getNextYear :: IO Integer
getNextYear = do
   (thisYear, _, _) <- (toGregorian . utctDay) <$> getCurrentTime
   pure $ thisYear + 1

getWriteAt :: Terminal -> IO (Write -> IO ())
getWriteAt term = do
   let Just gotoPos = getCapability term cursorAddress
       Just withFGColor = getCapability term withForegroundColor
       Just makeBold = getCapability term withBold
       Just clear = getCapability term clearScreen
       Just numLines = getCapability term termLines
       Just withAttrs = getCapability term withAttributes
   runCapability term "civis" -- Make cursor invisible
   runTermOutput term $ clear numLines
   pure $ \(Write row col stroke color s) -> do
      runTermOutput term $ gotoPos $ Point row col
      let f = case stroke of
             Bold -> makeBold -- Setting bold twice to be sure; may very well be redundant
             _ -> id
          attrs = defaultAttributes{
               invisibleAttr = True -- Doesn't seem to work; that's why we had to "civis" above
             , dimAttr = case stroke of
                 Dim -> True
                 _ -> False
             , boldAttr = case stroke of
                 Bold -> True
                 _ -> False
             }
      runTermOutput term $ withAttrs attrs $ f $ withFGColor color $ termText s

-- So we don't need to depend on 'split':
chunksOf :: Int -> [x] -> [[x]]
chunksOf n l = case splitAt n l of
   ([], []) -> []
   (x, []) -> [x]
   (x, xs) -> x : chunksOf n xs