[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:46:31 UTC 2010
The following commit has been merged in the master branch:
commit daaac742420cea4dc090499124a2360e2891a363
Author: John Goerzen <jgoerzen at complete.org>
Date: Sun Nov 14 12:22:45 2004 +0100
Imported Parser,Printer,Types from Ian Lynagh's Printf
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.5--patch-36)
diff --git a/ChangeLog b/ChangeLog
index 1ca5e16..05103ca 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,27 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
#
+2004-11-14 05:22:45 GMT John Goerzen <jgoerzen at complete.org> patch-36
+
+ Summary:
+ Imported Parser,Printer,Types from Ian Lynagh's Printf
+ Revision:
+ missingh--head--0.5--patch-36
+
+
+ new files:
+ libsrc/MissingH/Printf/.arch-ids/=id
+ libsrc/MissingH/Printf/Parser.lhs
+ libsrc/MissingH/Printf/Printer.lhs
+ libsrc/MissingH/Printf/Types.lhs
+
+ modified files:
+ ChangeLog
+
+ new directories:
+ libsrc/MissingH/Printf libsrc/MissingH/Printf/.arch-ids
+
+
2004-11-14 01:13:14 GMT John Goerzen <jgoerzen at complete.org> patch-35
Summary:
diff --git a/libsrc/MissingH/Printf/Parser.lhs b/libsrc/MissingH/Printf/Parser.lhs
new file mode 100644
index 0000000..0a1565e
--- /dev/null
+++ b/libsrc/MissingH/Printf/Parser.lhs
@@ -0,0 +1,143 @@
+arch-tag: Printf parser declarations
+
+\begin{code}
+module Parser (parse) where
+
+import Language.Haskell.THSyntax
+import Maybe (isJust, fromJust)
+import Printer (get_conversion_func)
+import Char (isDigit)
+import List (nub, delete)
+import Types
+
+{-
+xn where n is an integer refers to an argument to the function
+y*, n* is reserved for %n
+fw* is reserved for field width intermediates
+Everything else can be used by the conversion functions
+-}
+
+-- parse takes a format string and returns a list of Formats with which
+-- to build the output and the number of arguments to take
+parse :: String -> ([Format], ArgNum)
+parse = parse' 1 0
+
+parse' :: ArgNum -- The next argument number
+ -> ArgNum -- The maximum numbered argument number used so far
+ -> String -- The format string
+ -> ([Format], -- The bits of output
+ ArgNum) -- The number of arguments to take
+-- When we are at the end of the input there are no more bits of input
+-- remaining. The number of arguments is the largest argument used.
+parse' x_var max_x_var "" = ([], (x_var - 1) `max` max_x_var)
+parse' x_var max_x_var xs
+ = case parse_format x_var xs of
+ (f, x_var', used, xs') ->
+ case parse' x_var' (maximum (max_x_var:used)) xs' of
+ (fs, final_max_x_var) -> (f:fs, final_max_x_var)
+
+parse_format :: ArgNum -- The next argument to use
+ -> String -- The format string
+ -> (Format, -- The Format we put together
+ ArgNum, -- The new next argument to use
+ [ArgNum], -- The argument numbers we've used
+ String) -- The remainder of the format string
+parse_format x_var ('%':xs)
+ = case conv_spec of
+ 'n' -> (CharCount, x_var, [], xs5)
+ '%' -> (Literal "%", x_var, [], xs5)
+ _ -> (Conversion converted', x_var0, used, xs5)
+ where (arg, used0, x_var0, xs0) = get_arg x_var3 xs
+ (flags, xs1) = get_flags xs0
+ flags' = if isJust mprec then delete ZeroPadded flags else flags
+ (mfw, used2, x_var2, xs2) = get_min_field_width x_var xs1
+ (mprec, used3, x_var3, xs3) = get_precision x_var2 xs2
+ (_length_mod, xs4) = get_length_modifier xs3
+ (conv_spec, xs5) = get_conversion_specifier xs4
+ conv_func = get_conversion_func conv_spec
+ used = used0 ++ used2 ++ used3
+ converted = conv_func arg flags' mfw mprec
+ converted' = fix_width flags' mfw converted
+parse_format x_var xs = case break ('%' ==) xs of
+ (ys, zs) -> (Literal ys, x_var, [], zs)
+
+fix_width :: [Flag] -> Maybe Width -> ExpQ -> ExpQ
+fix_width _ Nothing e = e
+fix_width flags (Just w) e = letE [dec_e] exp_spaced
+ where
+ dec_e = valD (varP "e") (normalB e) []
+ exp_num_spaces = [| abs $w - length $e |]
+ exp_num_spaces' = [| 0 `max` $exp_num_spaces |]
+ exp_spaces = [| replicate $exp_num_spaces' ' ' |]
+ exp_left_padded = [| $(varE "e") ++ $exp_spaces |]
+ exp_right_padded = [| $exp_spaces ++ $(varE "e") |]
+ exp_spaced = if LeftAdjust `elem` flags
+ then exp_left_padded
+ else [| if $w < 0 then $exp_left_padded
+ else $exp_right_padded |]
+
+get_flags :: String -> ([Flag], String)
+get_flags s = (flags'', s')
+ where (cs, s') = span (`elem` "#0- +'I") s
+ unique_cs = nub cs
+ flags = map (fromJust . (`lookup` flag_mapping)) unique_cs
+ flags' = if LeftAdjust `elem` flags then filter (/= ZeroPadded) flags
+ else flags
+ flags'' = if Plus `elem` flags then filter (/= BlankPlus) flags
+ else flags'
+ flag_mapping = [('#', AlternateForm),
+ ('0', ZeroPadded),
+ ('-', LeftAdjust),
+ (' ', BlankPlus),
+ ('+', Plus),
+ ('\'', Thousands),
+ ('I', AlternativeDigits)]
+
+get_min_field_width :: ArgNum
+ -> String
+ -> (Maybe Width, [ArgNum], ArgNum, String)
+get_min_field_width x_var s
+ = case get_num s of
+ Just (n, s') -> (Just [| n |], [], x_var, s')
+ Nothing -> case get_star_arg x_var s of
+ Just (a, used, x_var', s') -> (Just a, used, x_var', s')
+ Nothing -> (Nothing, [], x_var, s)
+
+-- Need to check prec >= 0 at some point?
+
+get_precision :: ArgNum
+ -> String
+ -> (Maybe Precision, [ArgNum], ArgNum, String)
+get_precision x_var ('.':s)
+ = case get_num s of
+ Just (n, s') -> (Just [| n |], [], x_var, s')
+ Nothing -> case get_star_arg x_var s of
+ Just (a, used, x_var', s') -> (Just a, used, x_var', s')
+ Nothing -> (Just [| 0 |], [], x_var, s)
+get_precision x_var s = (Nothing, [], x_var, s)
+
+get_star_arg :: ArgNum -> String -> Maybe (Arg, [ArgNum], ArgNum, String)
+get_star_arg x_var ('*':s) = Just (get_arg x_var s)
+get_star_arg _ _ = Nothing
+
+get_arg :: ArgNum -> String -> (Arg, [ArgNum], ArgNum, String)
+get_arg x_var s = case get_num s of
+ Just (i, '$':s') -> (varE (xvar i), [i], x_var, s')
+ _ -> (varE (xvar x_var), [], x_var + 1, s)
+
+get_num :: String -> Maybe (Integer, String)
+get_num s = case span isDigit s of
+ ("", _) -> Nothing
+ (xs, s') -> Just ((read xs), s')
+
+get_length_modifier :: String -> (String, String)
+get_length_modifier s
+ | take 2 s `elem` ["hh", "ll"] = splitAt 2 s
+ | take 1 s `elem` ["h", "l", "L", "q", "j", "z", "t"] = splitAt 1 s
+ | otherwise = ("", s)
+
+get_conversion_specifier :: String -> (Char, String)
+get_conversion_specifier (x:xs) = (x, xs) -- XXX errors
+get_conversion_specifier "" = error "Printf: get_conversion_specifier \"\""
+\end{code}
+
diff --git a/libsrc/MissingH/Printf/Printer.lhs b/libsrc/MissingH/Printf/Printer.lhs
new file mode 100644
index 0000000..ceb28a4
--- /dev/null
+++ b/libsrc/MissingH/Printf/Printer.lhs
@@ -0,0 +1,201 @@
+arch-tag: Printf printer declarations
+
+\begin{code}
+module Printer (get_conversion_func, thousandify, octalify, hexify) where
+
+import Language.Haskell.THSyntax
+import Maybe (fromMaybe)
+import Numeric (showEFloat, showFFloat)
+import Char (toLower, toUpper)
+import Types
+
+{-
+xn where n is an integer refers to an argument to the function
+y*, n* is reserved for %n
+fw* is reserved for field width intermediates
+Everything else can be used by the conversion functions
+-}
+
+type ConversionFunc = Arg
+ -> [Flag]
+ -> Maybe Width
+ -> Maybe Precision
+ -> ExpQ
+
+get_conversion_func :: Char -> ConversionFunc
+get_conversion_func c = fromMaybe (error (c:": CF unknown")) $ lookup c cfs
+ where cfs = [
+ ('d', print_signed_int),
+ ('i', print_signed_int),
+ ('o', print_unsigned_int 'o'),
+ ('u', print_unsigned_int 'u'),
+ ('x', print_unsigned_int 'x'),
+ ('X', print_unsigned_int 'X'),
+ ('e', print_exponent_double 'e'),
+ ('E', print_exponent_double 'E'),
+ ('f', print_fixed_double 'f'),
+ ('F', print_fixed_double 'F'),
+ -- 'g' not handled
+ -- 'G' not handled
+ -- 'a' not handled
+ -- 'A' not handled
+ ('c', print_char),
+ ('s', print_string),
+ ('C', print_char),
+ ('S', print_string),
+ -- 'p' makes no sense
+ -- 'n' handled elsewhere
+ -- '%' handled elsewhere
+ ('H', show_arg) -- Haskell extension
+ ]
+
+-- %d, %i
+print_signed_int :: ConversionFunc
+print_signed_int arg flags mw mp = res
+ where preci = fromMaybe [| 1 |] mp
+ width = fromMaybe [| 0 |] mw
+ disp | Thousands `elem` flags = [| thousandify . show |]
+ | otherwise = [| show |]
+ plus_sign = if Plus `elem` flags
+ then "+"
+ else if BlankPlus `elem` flags
+ then " "
+ else ""
+ res = [| let to_show = toInteger $arg
+ shown = $disp $ abs to_show
+ w = $( if ZeroPadded `elem` flags
+ then [| $preci `max` $width - length sign |]
+ else preci )
+ sign = if to_show < 0 then "-" else plus_sign
+ num_zeroes = (w - length shown) `max` 0
+ in sign ++ replicate num_zeroes '0' ++ shown
+ |]
+
+-- %o, u, x, X
+print_unsigned_int :: Char -> ConversionFunc
+print_unsigned_int base arg flags mw mp = res
+ where preci = fromMaybe [| 1 |] mp
+ width = fromMaybe [| 0 |] mw
+ w = if ZeroPadded `elem` flags then [| $preci `max` $width |]
+ else preci
+ disp = case base of
+ 'o' -> [| octalify |]
+ 'x' -> [| hexify $(lift lower_hex) |]
+ 'X' -> [| hexify $(lift upper_hex) |]
+ 'u' | Thousands `elem` flags -> [| thousandify . show |]
+ | otherwise -> [| show |]
+ _ -> err_letter
+ prefix = if AlternateForm `elem` flags then case base of
+ 'o' -> "0"
+ 'u' -> ""
+ 'x' -> "0x"
+ 'X' -> "0X"
+ _ -> err_letter
+ else ""
+ res = [| let to_show = toInteger $arg `max` 0
+ shown = $disp to_show
+ pref = if to_show == 0 then "" else prefix
+ num_zeroes = ($w - length shown - length pref) `max` 0
+ in pref ++ replicate num_zeroes '0' ++ shown
+ |]
+ err_letter = error "print_unsigned_int: Bad letter"
+
+-- %e, E
+print_exponent_double :: Char -> ConversionFunc
+print_exponent_double e arg flags mw mp = res
+ where preci = fromMaybe [| 6 |] mp
+ width = fromMaybe [| 0 |] mw
+ plus_sign = if Plus `elem` flags
+ then "+"
+ else if BlankPlus `elem` flags
+ then " "
+ else ""
+ keep_dot = AlternateForm `elem` flags
+ res = [| let to_show = (fromRational $ toRational $arg) :: Double
+ shown = showEFloat (Just $preci) (abs to_show) ""
+ sign = if to_show < 0 then "-" else plus_sign
+ fix_prec0 = if $preci == 0
+ then case break (== '.') shown of
+ (xs, _:_:ys)
+ | keep_dot -> xs ++ '.':ys
+ | otherwise -> xs ++ ys
+ _ -> shown
+ else shown
+ fix_exp_sign = case break (== 'e') fix_prec0 of
+ (xs, 'e':'-':ys) -> xs ++ 'e':'-':ys
+ (xs, 'e':ys) -> xs ++ 'e':'+':ys
+ fix_exp = case break (== 'e') fix_exp_sign of
+ (xs, [_,s,y]) -> xs ++ [e,s,'0',y]
+ (xs, _:ys) -> xs ++ e:ys
+ num_zeroes = ($width - length fix_exp - length sign)
+ `max` 0
+ in sign ++ replicate num_zeroes '0' ++ fix_exp
+ |]
+
+-- %f, F
+print_fixed_double :: Char -> ConversionFunc
+print_fixed_double f arg flags mw mp = res
+ where preci = fromMaybe [| 6 |] mp
+ width = fromMaybe [| 0 |] mw
+ plus_sign = if Plus `elem` flags
+ then "+"
+ else if BlankPlus `elem` flags
+ then " "
+ else ""
+ add_dot = AlternateForm `elem` flags
+ fix_case | f == 'f' = [| map toLower |]
+ | otherwise = [| map toUpper |]
+ res = [| let to_show = (fromRational $ toRational $arg) :: Double
+ shown = showFFloat (Just $preci) (abs to_show) ""
+ shown' = if add_dot && $preci == 0 then shown ++ "."
+ else shown
+ sign = if to_show < 0 then "-" else plus_sign
+ num_zeroes = ($width - length shown' - length sign)
+ `max` 0
+ in sign ++ replicate num_zeroes '0' ++ $fix_case shown'
+ |]
+
+-- %c, C
+print_char :: ConversionFunc
+print_char arg _ _ _ = [| [$arg] |]
+
+-- %s, S
+print_string :: ConversionFunc
+print_string arg _ _ mp
+ = case mp of
+ Just preci -> [| if $preci < 0 then $arg else take $preci $arg |]
+ Nothing -> arg
+
+-- Corresponds to %H (Haskell extension)
+show_arg :: ConversionFunc
+show_arg arg flags mw mp = print_string [| show $arg |] flags mw mp
+
+lower_hex, upper_hex :: Bool
+lower_hex = False
+upper_hex = True
+
+hexify :: Bool -> Integer -> String
+hexify _ 0 = "0"
+hexify upper i = to_base 16 ((digits !!) . fromInteger) i
+ where digits | upper = ['0'..'9'] ++ ['A'..'F']
+ | otherwise = ['0'..'9'] ++ ['a'..'f']
+
+octalify :: Integer -> String
+octalify 0 = "0"
+octalify i = to_base 8 ((['0'..'7'] !!) . fromInteger) i
+
+to_base :: Integer -- Base
+ -> (Integer -> Char) -- Digit maker
+ -> Integer -- Number to convert, > 0
+ -> String
+to_base = f ""
+ where f s _ _ 0 = s
+ f s base mkDigit i = case i `divMod` base of
+ (i', d) -> f (mkDigit d:s) base mkDigit i'
+
+thousandify :: String -> String
+thousandify = reverse . t . reverse
+ where t (x1:x2:x3:xs@(_:_)) = x1:x2:x3:',':t xs
+ t xs = xs
+\end{code}
+
diff --git a/libsrc/MissingH/Printf/Types.lhs b/libsrc/MissingH/Printf/Types.lhs
new file mode 100644
index 0000000..8db2f63
--- /dev/null
+++ b/libsrc/MissingH/Printf/Types.lhs
@@ -0,0 +1,34 @@
+arch-tag: Printf type declarations
+
+\begin{code}
+module Types where
+
+import Language.Haskell.THSyntax
+
+data Format = Literal String
+ | Conversion ExpQ
+ | CharCount
+
+type ArgNum = Integer
+type Arg = ExpQ
+type Width = ExpQ
+type Precision = ExpQ
+data Flag = AlternateForm -- "#"
+ | ZeroPadded -- "0"
+ | LeftAdjust -- "-"
+ | BlankPlus -- " "
+ | Plus -- "+"
+ | Thousands -- "'"
+ | AlternativeDigits -- "I" (ignored)
+ deriving (Eq, Show)
+
+xvar :: ArgNum -> String
+xvar i = 'x':show i
+
+yvar :: ArgNum -> String
+yvar i = 'y':show i
+
+nvar :: ArgNum -> String
+nvar i = 'n':show i
+\end{code}
+
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list