{-# 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
  { forall buf. Value buf -> PrintfArg buf
valArg :: PrintfArg buf
  , forall buf. Value buf -> Maybe buf
valPrefix :: Maybe buf
  , forall buf. Value buf -> Maybe buf
valSign :: Maybe buf
  }
  deriving (Int -> Value buf -> ShowS
forall buf. Show buf => Int -> Value buf -> ShowS
forall buf. Show buf => [Value buf] -> ShowS
forall buf. Show buf => Value buf -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value buf] -> ShowS
$cshowList :: forall buf. Show buf => [Value buf] -> ShowS
show :: Value buf -> String
$cshow :: forall buf. Show buf => Value buf -> String
showsPrec :: Int -> Value buf -> ShowS
$cshowsPrec :: forall buf. Show buf => Int -> Value buf -> ShowS
Show)

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

padDecimal :: (Buf buf, Eq v, Num v) => PrintfArg v -> buf -> buf
padDecimal :: forall buf v. (Buf buf, Eq v, Num v) => PrintfArg v -> buf -> buf
padDecimal PrintfArg v
spec
  | forall v. PrintfArg v -> Maybe Int
prec PrintfArg v
spec forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
0 Bool -> Bool -> Bool
&& forall v. PrintfArg v -> v
value PrintfArg v
spec forall a. Eq a => a -> a -> Bool
== v
0 = forall a b. a -> b -> a
const forall a. Monoid a => a
mempty
  | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. Buf a => Int -> Char -> a -> a
`justifyRight` Char
'0') (forall v. PrintfArg v -> Maybe Int
prec PrintfArg v
spec)

prefix :: (Num n, Eq n, Buf buf) => buf -> PrintfArg n -> Maybe buf
prefix :: forall n buf.
(Num n, Eq n, Buf buf) =>
buf -> PrintfArg n -> Maybe buf
prefix buf
s PrintfArg n
pf = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall v. PrintfArg v -> Bool
prefixed PrintfArg n
pf Bool -> Bool -> Bool
&& forall v. PrintfArg v -> v
value PrintfArg n
pf forall a. Eq a => a -> a -> Bool
/= n
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just buf
s

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

formatOne :: (Buf buf) => Value buf -> buf
formatOne :: forall buf. Buf buf => Value buf -> buf
formatOne Value{Maybe buf
PrintfArg buf
valSign :: Maybe buf
valPrefix :: Maybe buf
valArg :: PrintfArg buf
valSign :: forall buf. Value buf -> Maybe buf
valPrefix :: forall buf. Value buf -> Maybe buf
valArg :: forall buf. Value buf -> PrintfArg buf
..}
  | Maybe Int
Nothing <- forall v. PrintfArg v -> Maybe Int
width PrintfArg buf
valArg = buf
prefix' forall a. Semigroup a => a -> a -> a
<> buf
text
  | Just Int
w <- forall v. PrintfArg v -> Maybe Int
width PrintfArg buf
valArg = case forall v. PrintfArg v -> Maybe Adjustment
adjustment PrintfArg buf
valArg of
    Just Adjustment
ZeroPadded
      | Bool
isn'tDecimal Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing (forall v. PrintfArg v -> Maybe Int
prec PrintfArg buf
valArg) ->
        buf
prefix' forall a. Semigroup a => a -> a -> a
<> forall a. Buf a => Int -> Char -> a -> a
justifyRight (Int
w forall a. Num a => a -> a -> a
- forall a. Buf a => a -> Int
size buf
prefix') Char
'0' buf
text
    Just Adjustment
LeftJustified -> forall a. Buf a => Int -> Char -> a -> a
justifyLeft Int
w Char
' ' (buf
prefix' forall a. Semigroup a => a -> a -> a
<> buf
text)
    Maybe Adjustment
_ -> forall {a}. Buf a => Int -> a -> a
justify' Int
w (buf
prefix' forall a. Semigroup a => a -> a -> a
<> buf
text)
 where
  isn'tDecimal :: Bool
isn'tDecimal = forall v. PrintfArg v -> Char
fieldSpec PrintfArg buf
valArg forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
"diouxX" :: String)
  justify' :: Int -> a -> a
justify' Int
n
    | Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Buf a => Int -> Char -> a -> a
justifyLeft (forall a. Num a => a -> a
abs Int
n) Char
' '
    | Bool
otherwise = forall a. Buf a => Int -> Char -> a -> a
justifyRight Int
n Char
' '
  prefix' :: buf
prefix' = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe buf
valSign forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe buf
valPrefix
  text :: buf
text = forall v. PrintfArg v -> v
value PrintfArg buf
valArg