My custom prompt printer

Prompt.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}


module Main (main) where

import System.IO
import System.Environment
import qualified System.Exit as Exit
import Text.Printf
import Data.Monoid
import Data.String
import Text.Read


main :: IO ()
main = getArgs >>= \case
      width : height : time : user : path : exitCode : _ ->
            case (readEither width, readEither height) of
                  (Right w, Right h) -> printPrompt (w, h)
                                                    time
                                                    user
                                                    path
                                                    exitCode
                  _ -> exit 2
      _otherwise -> exit 1



exit :: Int -- ^ Exit code /= 0
     -> IO ()
exit = Exit.exitWith . Exit.ExitFailure



data Info = Time String
          | User String
          | Path String
          | Exit String



printPrompt :: (Int, Int) -- ^ Terminal width/height
            -> String     -- ^ Time field, e.g. 16:38:19
            -> String     -- ^ User field, e.g. main@thinkpad
            -> String     -- ^ Working dir, e.g. ~/bin/
            -> String     -- ^ Exit code of the last operation, e.g. 1
            -> IO ()
printPrompt (width, _height) time user path exitCode = do
      let info = mconcat [ "┌"
                         , display (Time time)
                         , display (User user)
                         , display (Path path)
                         , display (Exit exitCode)
                         ]
      putStr (getString info)
      putStrLn (fillerUntil info "─" width)
      -- putStr "└──╼ " -- Handled by $PS1
      hFlush stdout
      Exit.exitSuccess



-- | Generate padding text to fill a 'Lengthed' 'String' to a certain size. The
--   padding is assumed to consist of printable characters only.
fillerUntil :: Lengthed -- ^ Initial text
            -> String   -- ^ Filler to be repeated
            -> Int      -- ^ Length to pad to
            -> String   -- ^ Padding String
fillerUntil (Lengthed _ l) filler i = (take (i-l) . concat . repeat) filler



display :: Info -> Lengthed
display (Time t)   = handle 34 t
display (User u)   = handle 32 u
display (Path p)   = handle 33 p
display (Exit "0") = ""
display (Exit ec)  = handle 31 ec



handle :: Int -> String -> Lengthed
handle colour =  ("─[" <>) . (<> "]") . colourize colour . toLengthed


-- | String with printable length information
data Lengthed = Lengthed String Int



getString :: Lengthed -> String
getString (Lengthed s _) = s



instance Monoid Lengthed where
      mempty = Lengthed "" 0
      mappend (Lengthed as ai) (Lengthed bs bi) = Lengthed (as ++ bs) (ai + bi)

instance IsString Lengthed where
      fromString = toLengthed



-- | Clamp a 'Lengthed' 'String' in ANSI colour codes without altering its
--   printable length
colourize :: Int -> Lengthed -> Lengthed
colourize i (Lengthed text l) = Lengthed coloured l
      where coloured = printf "\ESC[%dm%s\ESC[0m" i text



-- | Convert a 'String' to a 'Lengthed' 'String', assuming all characters are
--   printable and occupy one terminal cell.
toLengthed :: String -> Lengthed
toLengthed str = Lengthed str (length str)