Geometry.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Language.Haskell.Printf.Geometry (
  sign',
  padDecimal,
  prefix,
  fromPrintfArg,
  formatOne,
  Value (..),
) where

import Control.Monad
import Data.Maybe
import Language.Haskell.PrintfArg
import Parser.Types (Adjustment (..))

import Buf
import StrUtils

data Value buf = Value
  { valArg :: PrintfArg buf
  , valPrefix :: Maybe buf
  , valSign :: Maybe buf
  }
  deriving (Show)

sign' :: (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf
sign' pf
  | value pf < 0 = Just (singleton '-')
  | spaced pf = Just (singleton ' ')
  | signed pf = Just (singleton '+')
  | otherwise = Nothing

padDecimal :: (Buf buf, Eq v, Num v) => PrintfArg v -> buf -> buf
padDecimal spec
  | prec spec == Just 0 && value spec == 0 = const mempty
  | otherwise = maybe id (`justifyRight` '0') (prec spec)

prefix :: (Num n, Eq n, Buf buf) => buf -> PrintfArg n -> Maybe buf
prefix s pf = guard (prefixed pf && value pf /= 0) >> Just s

fromPrintfArg ::
  (Buf buf) =>
  (n -> buf) ->
  (PrintfArg n -> Maybe buf) ->
  (PrintfArg n -> Maybe buf) ->
  PrintfArg n ->
  Value buf
fromPrintfArg f b c a = Value (f <$> a) (b a) (c a)

formatOne :: (Buf buf) => Value buf -> buf
formatOne Value{..}
  | Nothing <- width valArg = prefix' <> text
  | Just w <- width valArg = case adjustment valArg of
    Just ZeroPadded
      | isn'tDecimal || isNothing (prec valArg) ->
        prefix' <> justifyRight (w - size prefix') '0' text
    Just LeftJustified -> justifyLeft w ' ' (prefix' <> text)
    _ -> justify' w (prefix' <> text)
 where
  isn'tDecimal = fieldSpec valArg `notElem` ("diouxX" :: String)
  justify' n
    | n < 0 = justifyLeft (abs n) ' '
    | otherwise = justifyRight n ' '
  prefix' = fromMaybe mempty valSign <> fromMaybe mempty valPrefix
  text = value valArg