{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Language.Haskell.Printf.Printers where

import Data.Char
import Data.Maybe (fromMaybe)
import Data.String (IsString, fromString)
import qualified Data.Text as S
import qualified Data.Text.Lazy as L
import Foreign.Ptr
import GHC.Float (FFFormat (..))
import Language.Haskell.Printf.Geometry
import Language.Haskell.PrintfArg
import Math.NumberTheory.Logarithms

import Buf
import NumUtils
import qualified Parser.Types as P

type Printer n buf = PrintfArg n -> Value buf

printfString :: (Buf buf) => Printer String buf
printfString :: forall buf. Buf buf => Printer String buf
printfString PrintfArg String
spec =
  Value
    { valArg :: PrintfArg buf
valArg = case forall v. PrintfArg v -> Maybe Int
prec PrintfArg String
spec of
        Maybe Int
Nothing -> forall a. Buf a => String -> a
str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg String
spec
        Just Int
c -> forall a. Buf a => String -> a
str forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg String
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall a. Maybe a
Nothing
    }

printfStrictText :: (Buf buf) => Printer S.Text buf
printfStrictText :: forall buf. Buf buf => Printer Text buf
printfStrictText PrintfArg Text
spec =
  Value
    { valArg :: PrintfArg buf
valArg = case forall v. PrintfArg v -> Maybe Int
prec PrintfArg Text
spec of
        Maybe Int
Nothing -> forall a. Buf a => Text -> a
sText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg Text
spec
        Just Int
c -> forall a. Buf a => Text -> a
sText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
S.take Int
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg Text
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall a. Maybe a
Nothing
    }

printfLazyText :: (Buf buf) => Printer L.Text buf
printfLazyText :: forall buf. Buf buf => Printer Text buf
printfLazyText PrintfArg Text
spec =
  Value
    { valArg :: PrintfArg buf
valArg = case forall v. PrintfArg v -> Maybe Int
prec PrintfArg Text
spec of
        Maybe Int
Nothing -> forall a. Buf a => Text -> a
lText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg Text
spec
        Just Int
c -> forall a. Buf a => Text -> a
lText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Text -> Text
L.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg Text
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall a. Maybe a
Nothing
    }

printfShow :: (Buf buf, Show a) => Printer a buf
printfShow :: forall buf a. (Buf buf, Show a) => Printer a buf
printfShow PrintfArg a
spec = forall buf. Buf buf => Printer String buf
printfString (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg a
spec)

printfChar :: (Buf buf) => Printer Char buf
printfChar :: forall buf. Buf buf => Printer Char buf
printfChar PrintfArg Char
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall a. Buf a => Char -> a
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg Char
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall a. Maybe a
Nothing
    }

{-# ANN printfPtr ("HLint: ignore Use showHex" :: String) #-}
printfPtr :: (Buf buf) => Printer (Ptr a) buf
printfPtr :: forall buf a. Buf buf => Printer (Ptr a) buf
printfPtr PrintfArg (Ptr a)
spec =
  Value
    { valArg :: PrintfArg buf
valArg =
        PrintfArg
          { width :: Maybe Int
width = forall v. PrintfArg v -> Maybe Int
width PrintfArg (Ptr a)
spec
          , prec :: Maybe Int
prec = forall a. Maybe a
Nothing
          , flagSet :: FlagSet
flagSet = FlagSet
P.emptyFlagSet{prefixed :: Bool
P.prefixed = Bool
True}
          , lengthSpec :: Maybe LengthSpecifier
lengthSpec = forall a. Maybe a
Nothing
          , fieldSpec :: Char
fieldSpec = Char
'p'
          , value :: buf
value = forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase WordPtr
16 Int -> Char
intToDigit (forall a. Ptr a -> WordPtr
ptrToWordPtr forall a b. (a -> b) -> a -> b
$ forall v. PrintfArg v -> v
value PrintfArg (Ptr a)
spec)
          }
    , valPrefix :: Maybe buf
valPrefix = forall a. a -> Maybe a
Just (forall a. Buf a => String -> a
str String
"0x")
    , valSign :: Maybe buf
valSign = forall a. Maybe a
Nothing
    }

printfDecimal :: (Buf buf, Show n, Integral n) => PrintfArg n -> Value buf
printfDecimal :: forall buf n.
(Buf buf, Show n, Integral n) =>
PrintfArg n -> Value buf
printfDecimal PrintfArg n
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall buf v. (Buf buf, Eq v, Num v) => PrintfArg v -> buf -> buf
padDecimal PrintfArg n
spec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase n
10 Int -> Char
intToDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg n
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall n buf. (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf
sign' PrintfArg n
spec
    }

fmtUnsigned ::
  (Bounded a, Integral a, Buf buf) =>
  (Integer -> buf) ->
  (PrintfArg a -> Maybe buf) ->
  Printer a buf
fmtUnsigned :: forall a buf.
(Bounded a, Integral a, Buf buf) =>
(Integer -> buf) -> (PrintfArg a -> Maybe buf) -> Printer a buf
fmtUnsigned Integer -> buf
shower PrintfArg a -> Maybe buf
p PrintfArg a
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall buf v. (Buf buf, Eq v, Num v) => PrintfArg v -> buf -> buf
padDecimal PrintfArg a
spec forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> buf
shower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Bounded a, Integral a) => a -> Integer
clampUnsigned forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg a
spec
    , valPrefix :: Maybe buf
valPrefix = PrintfArg a -> Maybe buf
p PrintfArg a
spec
    , valSign :: Maybe buf
valSign = forall a. Maybe a
Nothing
    }

printfHex :: (Bounded a, Integral a, Buf buf, IsString buf) => Bool -> Printer a buf
printfHex :: forall a buf.
(Bounded a, Integral a, Buf buf, IsString buf) =>
Bool -> Printer a buf
printfHex Bool
b = forall a buf.
(Bounded a, Integral a, Buf buf) =>
(Integer -> buf) -> (PrintfArg a -> Maybe buf) -> Printer a buf
fmtUnsigned forall {buf} {a}. (Buf buf, Show a, Integral a) => a -> buf
showHex (forall n buf.
(Num n, Eq n, Buf buf) =>
buf -> PrintfArg n -> Maybe buf
prefix (if Bool
b then buf
"0X" else buf
"0x"))
 where
  showHex :: a -> buf
showHex = forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase a
16 ((if Bool
b then Char -> Char
toUpper else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
intToDigit)

printfUnsigned :: (Bounded a, Integral a, Buf buf) => Printer a buf
printfUnsigned :: forall a buf. (Bounded a, Integral a, Buf buf) => Printer a buf
printfUnsigned = forall a buf.
(Bounded a, Integral a, Buf buf) =>
(Integer -> buf) -> (PrintfArg a -> Maybe buf) -> Printer a buf
fmtUnsigned (forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase Integer
10 Int -> Char
intToDigit) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)

-- printing octal is really annoying.  consider
--
-- printf "%#-8.5x" 1234
--
-- "0x004d2 "
--  ^~~~~~~^ width (8)
--    ^~~~^  precision (5)
--  ^^       prefix (2)
--    ^^     padding (2)
--
-- printf "%#-8.5o" 1234
--
-- "02322   "
--  ^~~~~~~^ width (8)
--  ^~~~^    precision (5)
--  ^        prefix (1)
--  ^        padding (1, same character)
--
-- in octal, when combining prefix and padding, the prefix
-- must eat the first padding char
{-# ANN printfOctal ("HLint: ignore Use showOct" :: String) #-}
printfOctal :: (Buf buf, IsString buf, Bounded n, Integral n) => PrintfArg n -> Value buf
printfOctal :: forall buf n.
(Buf buf, IsString buf, Bounded n, Integral n) =>
PrintfArg n -> Value buf
printfOctal PrintfArg n
spec =
  forall a buf.
(Bounded a, Integral a, Buf buf) =>
(Integer -> buf) -> (PrintfArg a -> Maybe buf) -> Printer a buf
fmtUnsigned
    (forall buf a.
(Buf buf, Show a, Integral a) =>
a -> (Int -> Char) -> a -> buf
showIntAtBase Integer
8 Int -> Char
intToDigit)
    (\PrintfArg n
y -> if Bool
shouldUnpad then forall a. Maybe a
Nothing else forall n buf.
(Num n, Eq n, Buf buf) =>
buf -> PrintfArg n -> Maybe buf
prefix buf
"0" PrintfArg n
y)
    PrintfArg n
spec
 where
  expectedWidth :: Int
expectedWidth = Integer -> Integer -> Int
integerLogBase Integer
8 (forall a. Ord a => a -> a -> a
max Integer
1 forall a b. (a -> b) -> a -> b
$ forall a. (Bounded a, Integral a) => a -> Integer
clampUnsigned forall a b. (a -> b) -> a -> b
$ forall v. PrintfArg v -> v
value PrintfArg n
spec) forall a. Num a => a -> a -> a
+ Int
1
  shouldUnpad :: Bool
shouldUnpad = forall v. PrintfArg v -> Bool
prefixed PrintfArg n
spec Bool -> Bool -> Bool
&& forall a. a -> Maybe a -> a
fromMaybe Int
0 (forall v. PrintfArg v -> Maybe Int
prec PrintfArg n
spec) forall a. Ord a => a -> a -> Bool
> Int
expectedWidth

printfFloating :: (Buf buf, RealFloat n) => Bool -> PrintfArg n -> Value buf
printfFloating :: forall buf n.
(Buf buf, RealFloat n) =>
Bool -> PrintfArg n -> Value buf
printfFloating Bool
upperFlag PrintfArg n
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall {buf} {a}. (Buf buf, RealFloat a) => a -> buf
showFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg n
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall n buf. (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf
sign' PrintfArg n
spec
    }
 where
  precision :: Maybe a
precision = case forall v. PrintfArg v -> Maybe Int
prec PrintfArg n
spec of
    Just Int
n -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    Maybe Int
Nothing | Just Adjustment
P.ZeroPadded <- forall v. PrintfArg v -> Maybe Adjustment
adjustment PrintfArg n
spec -> forall a. a -> Maybe a
Just a
6
    Maybe Int
_ -> forall a. Maybe a
Nothing
  showFloat :: a -> buf
showFloat = forall buf a.
(Buf buf, RealFloat a) =>
FFFormat -> Maybe Int -> Bool -> Bool -> a -> buf
formatRealFloatAlt FFFormat
FFFixed forall {a}. Num a => Maybe a
precision (forall v. PrintfArg v -> Bool
prefixed PrintfArg n
spec) Bool
upperFlag

printfScientific :: (Buf buf, RealFloat n) => Bool -> PrintfArg n -> Value buf
printfScientific :: forall buf n.
(Buf buf, RealFloat n) =>
Bool -> PrintfArg n -> Value buf
printfScientific Bool
upperFlag PrintfArg n
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall {buf} {a}. (Buf buf, RealFloat a) => a -> buf
showSci forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg n
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall n buf. (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf
sign' PrintfArg n
spec
    }
 where
  showSci :: a -> buf
showSci =
    forall buf a.
(Buf buf, RealFloat a) =>
FFFormat -> Maybe Int -> Bool -> Bool -> a -> buf
formatRealFloatAlt
      FFFormat
FFExponent
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. PrintfArg v -> Maybe Int
prec PrintfArg n
spec)
      (forall v. PrintfArg v -> Bool
prefixed PrintfArg n
spec)
      Bool
upperFlag

printfGeneric :: (Buf buf, RealFloat n) => Bool -> PrintfArg n -> Value buf
printfGeneric :: forall buf n.
(Buf buf, RealFloat n) =>
Bool -> PrintfArg n -> Value buf
printfGeneric Bool
upperFlag PrintfArg n
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall {buf} {a}. (Buf buf, RealFloat a) => a -> buf
showSci forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg n
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. Maybe a
Nothing
    , valSign :: Maybe buf
valSign = forall n buf. (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf
sign' PrintfArg n
spec
    }
 where
  showSci :: a -> buf
showSci =
    forall buf a.
(Buf buf, RealFloat a) =>
FFFormat -> Maybe Int -> Bool -> Bool -> a -> buf
formatRealFloatAlt
      FFFormat
FFGeneric
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. PrintfArg v -> Maybe Int
prec PrintfArg n
spec)
      (forall v. PrintfArg v -> Bool
prefixed PrintfArg n
spec)
      Bool
upperFlag

printfFloatHex :: (Buf buf, RealFloat n, IsString buf) => Bool -> PrintfArg n -> Value buf
printfFloatHex :: forall buf n.
(Buf buf, RealFloat n, IsString buf) =>
Bool -> PrintfArg n -> Value buf
printfFloatHex Bool
upperFlag PrintfArg n
spec =
  Value
    { valArg :: PrintfArg buf
valArg = forall {buf} {a}. (Buf buf, RealFloat a) => a -> buf
showHexFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintfArg n
spec
    , valPrefix :: Maybe buf
valPrefix = forall a. a -> Maybe a
Just (if Bool
upperFlag then buf
"0X" else buf
"0x")
    , valSign :: Maybe buf
valSign = forall n buf. (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf
sign' PrintfArg n
spec
    }
 where
  showHexFloat :: a -> buf
showHexFloat =
    forall buf a.
(Buf buf, RealFloat a) =>
Maybe Int -> Bool -> Bool -> a -> buf
formatHexFloat (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. PrintfArg v -> Maybe Int
prec PrintfArg n
spec) (forall v. PrintfArg v -> Bool
prefixed PrintfArg n
spec) Bool
upperFlag

clampUnsigned :: (Bounded a, Integral a) => a -> Integer
clampUnsigned :: forall a. (Bounded a, Integral a) => a -> Integer
clampUnsigned a
x
  | a
x forall a. Ord a => a -> a -> Bool
< a
0 = forall a. Integral a => a -> Integer
toInteger a
x forall a. Num a => a -> a -> a
+ (-Integer
2 forall a. Num a => a -> a -> a
* forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound forall a. a -> a -> a
`asTypeOf` a
x))
  | Bool
otherwise = forall a. Integral a => a -> Integer
toInteger a
x