module Text.Printf.Mauke (
printf,
hPrintf,
FromChar(..),
ToChar(..),
PrintfType,
HPrintfType,
PrintfArg
) where
import Prelude hiding (putStr)
import Control.Monad
import Data.Char
import Data.Default
import Data.List
import Data.Maybe
import Data.Ratio
import qualified Data.Set as Set
import Data.Set (Set)
import Numeric
import System.IO hiding (putStr, hPutStr)
import System.IO.UTF8
thisModule :: String
thisModule = "Text.Printf.Mauke"
die :: String -> String -> a
die f s = error $ concat [thisModule, ".", f, ": ", s]
class FromChar a where
fromChar :: Char -> a
instance FromChar Char where
fromChar = id
class ToChar a where
toChar :: a -> Char
instance ToChar Char where
toChar = id
pdie :: String -> a
pdie = die "printf"
printf :: (PrintfType r) => String -> r
printf = collect id
class PrintfType a where
collect :: ([Arg] -> [Arg]) -> String -> a
instance (FromChar a) => PrintfType [a] where
collect arg fmt = map fromChar $ format fmt (arg [])
instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
collect arg fmt x = collect (arg . (embed x :)) fmt
instance (Default a) => PrintfType (IO a) where
collect arg fmt = putStr (collect arg fmt) >> def
hPrintf :: (HPrintfType r) => Handle -> String -> r
hPrintf h = hcollect h id
class HPrintfType a where
hcollect :: Handle -> ([Arg] -> [Arg]) -> String -> a
instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
hcollect h arg fmt x = hcollect h (arg . (embed x :)) fmt
instance (Default a) => HPrintfType (IO a) where
hcollect h arg fmt = hPutStr h (format fmt (arg [])) >> def
data Arg
= AInt Integer
| AChar Char
| AStr String
| AFloat Double
deriving (Eq, Ord, Show, Read)
ashow :: Arg -> String
ashow (AInt i) = show i
ashow (AChar c) = show c
ashow (AStr s) = show s
ashow (AFloat d) = show d
class PrintfArg a where
embed :: a -> Arg
instance PrintfArg Char where
embed = AChar
instance (ToChar a) => PrintfArg [a] where
embed = AStr . map toChar
instance PrintfArg Float where
embed = AFloat . realToFrac
instance PrintfArg Double where
embed = AFloat
instance (Integral a) => PrintfArg (Ratio a) where
embed = AFloat . realToFrac
instance PrintfArg Int where
embed = AInt . fromIntegral
instance PrintfArg Integer where
embed = AInt
format :: String -> [Arg] -> String
format "" [] = ""
format "" (x : _) = die "printf" $ "excess argument: " ++ ashow x
format ('%' : fmt) args =
let
(spec, fmt', args') = parse fmt args
(args'', ss) = apply spec args'
in
ss $ format fmt' args''
format (c : fmt) args = c : format fmt args
data Spec = Spec{
flags :: !(Set Flag),
vector :: !(Maybe String),
width :: !Integer,
precision :: !(Maybe Integer),
ftype :: !Type
} deriving (Eq, Ord, Show, Read)
instance Default Spec where
def = Spec def def def def def
data Flag = FSpace | FPlus | FZero | FAlt
deriving (Eq, Ord, Show, Read)
ch2flag :: Char -> Flag
ch2flag c = case c of
' ' -> FSpace
'+' -> FPlus
'0' -> FZero
'#' -> FAlt
_ -> die "ch2flag" $ "internal error: " ++ show c
data Type
= Tpercent
| Tc | Ts | Td | Tu | To | Tx | Te | Tf | Tg
| TO | TX | TE | TG | Tb | TB
| Tany
deriving (Eq, Ord, Show, Read)
instance Default Type where
def = Tany
ch2type :: Char -> Type
ch2type c = case c of
'%' -> Tpercent
'c' -> Tc
's' -> Ts
'd' -> Td
'u' -> Tu
'o' -> To
'O' -> TO
'x' -> Tx
'X' -> TX
'e' -> Te
'f' -> Tf
'g' -> Tg
'E' -> TE
'G' -> TG
'b' -> Tb
'B' -> TB
'_' -> Tany
_ -> pdie $ "invalid format specifier: " ++ show c
enoarg :: a
enoarg = pdie "missing argument"
auncons :: [Arg] -> (Arg, [Arg])
auncons [] = enoarg
auncons (x : xs) = (x, xs)
arg2int :: Arg -> Integer
arg2int (AInt i) = i
arg2int x = pdie $ "invalid argument: expected int, got " ++ ashow x
arg2int' :: Arg -> Integer
arg2int' (AInt i) = i
arg2int' (AChar c) = fromIntegral $ ord c
arg2int' x = pdie $ "invalid argument: expected int, got " ++ ashow x
arg2str :: Arg -> String
arg2str (AStr s) = s
arg2str x = pdie $ "invalid argument: expected string, got " ++ ashow x
arg2float :: Arg -> Double
arg2float (AFloat f) = f
arg2float x = pdie $ "invalid argument: expected float, got " ++ ashow x
parseInt :: String -> [Arg] -> (Maybe Integer, String, [Arg])
parseInt str args = case str of
'*' : str' ->
let (arg, args') = auncons args in
(Just $ arg2int arg, str', args')
_ ->
let (d, str') = span (\c -> c >= '0' && c <= '9') str in
(if null d then Nothing else Just $ read d, str', args)
parseVec :: String -> [Arg] -> (Maybe String, String, [Arg])
parseVec str args = case str of
'v' : str' -> (Just ".", str', args)
'*' : 'v' : str' -> (Just sa, str', args')
_ -> (Nothing, str, args)
where
(arg, args') = auncons args
sa = arg2str arg
parse :: String -> [Arg] -> (Spec, String, [Arg])
parse s args =
let
(fch, s1) = span (`elem` " +-0#") s
fl = Set.fromList . map ch2flag . filter ('-' /=) $ fch
(vc, s2, args1) = parseVec s1 args
(wd, s3, args2) = parseInt s2 args1
(pr, s4, args3) = case s3 of
'.' : t ->
let (mi, str, ar) = parseInt t args2 in
(mi `mplus` Just 0, str, ar)
_ -> (Nothing, s3, args2)
(tp, s5) = case s4 of
"" -> pdie $ "unterminated formatting directive"
c : cs -> (ch2type c, cs)
in (
def{
flags = fl,
vector = vc,
width = (if '-' `elem` fch then negate else id) . fromMaybe 0 $ wd,
precision = pr,
ftype = tp
},
s5,
args3
)
padWith :: a -> Integer -> [a] -> [a]
padWith c w s
| w <= 0 = lgo (negate w) s
| otherwise = genericReplicate (missingFrom w s) c ++ s
where
lgo n xs | n <= 0 = xs
lgo n [] = genericReplicate n c
lgo n (x : xs) = x : lgo (pred n) xs
missingFrom n _ | n <= 0 = 0
missingFrom n [] = n
missingFrom n (_ : xs) = missingFrom (pred n) xs
padChar :: Spec -> Char
padChar spc
| FZero `Set.member` flags spc
&& width spc > 0
&& (
isNothing (precision spc) ||
ftype spc `notElem` [Td, Tu, To, Tx, TX, Tb, TB]
) = '0'
| otherwise = ' '
int2char :: Integer -> Char
int2char i
| i < lo || i > hi = '\xfffd'
| otherwise = chr (fromInteger i)
where
lo = fromIntegral $ ord minBound
hi = fromIntegral $ ord maxBound
apply :: Spec -> [Arg] -> ([Arg], String -> String)
apply spc args
| isJust (vector spc) =
let Just d = vector spc in
args' <&>
($ "") . foldr (.) id . intersperse (d ++) . map (snd . apply spc{ vector = Nothing } . return . embed) $ arg2str arg
| otherwise = case ftype spc of
Tpercent -> args <&> "%"
Tc -> args' <&> [int2char argi]
Ts -> args' <&> maybe id genericTake (precision spc) . arg2str $ arg
Tu -> args' <&>
maybe id (padWith '0' . max 0) (precision spc) $ show argu
Td -> ifmt show
To -> ifmt $ showBase 8
TO -> ifmt $ showBase 8
Tx -> ifmt $ showBase 16
TX -> ifmt $ uc . showBase 16
Tb -> ifmt $ showBase 2
TB -> ifmt $ showBase 2
Tf -> ffmt . dF $ showFFloat fprec
Te -> ffmt . dF $ showEFloat fprec
TE -> ffmt . (uc .) . dF $ showEFloat fprec
Tg -> ffmt . dF $ showGFloat (fmap fromIntegral $ precision spc)
TG -> ffmt . (uc .) . dF $ showGFloat (fmap fromIntegral $ precision spc)
Tany ->
spc{
ftype = case arg of
AInt{} -> Td
AChar{} -> Tc
AStr{} -> Ts
AFloat{} -> Tg
} `apply` args
where
uc = map toUpper
showBase b n = showIntAtBase b intToDigit n ""
dF f = flip f ""
infixr 0 <&>
x <&> y = (x, (pad y ++))
pC = padChar spc
pad = padWith pC (width spc)
(arg, args') = auncons args
argf = arg2float arg
fprec = Just $ maybe 6 fromIntegral (precision spc)
fprefix
| argf < 0 = "-"
| FPlus `Set.member` flags spc = "+"
| FSpace `Set.member` flags spc = " "
| otherwise = ""
argi = arg2int' arg
argu
| argi < 0 = pdie $ "invalid argument: expected unsigned int, got " ++ show argi
| otherwise = argi
arga = abs argi
iprefix =
case () of
_
| argi < 0 -> "-"
| FPlus `Set.member` flags spc -> "+"
| FSpace `Set.member` flags spc -> " "
| otherwise -> ""
++
if FAlt `Set.notMember` flags spc then ""
else case ftype spc of
To -> "0o"
TO -> "0O"
Tx -> "0x"
TX -> "0X"
Tb -> "0b"
TB -> "0B"
_ -> ""
ifmt pp = (,) args' . (++) $
(if pC /= '0' then pad else id) $
iprefix ++
maybe
(
if pC == '0'
then padWith '0' (max 0 $ width spc fromIntegral (length iprefix))
else id
)
(padWith '0' . max 0)
(precision spc)
(pp arga)
ffmt pp = (,) args' . (++) $
case () of
_
| isNaN argf -> padWith ' ' (width spc) $ fprefix ++ "nan"
| isInfinite argf -> padWith ' ' (width spc) $ fprefix ++ "inf"
| otherwise ->
fprefix ++
(
if pC == '0'
then padWith '0' (max 0 $ width spc fromIntegral (length fprefix))
else id
) (pp $ abs argf)