Printf-TH (empty) → 0.1.1
raw patch · 7 files changed
+563/−0 lines, 7 filesdep +basedep +haskell98dep +prettysetup-changed
Dependencies added: base, haskell98, pretty, template-haskell
Files
- Printf-TH.cabal +27/−0
- Setup.hs +3/−0
- Text/Printf/TH.lhs +53/−0
- Text/Printf/TH/Parser.lhs +143/−0
- Text/Printf/TH/Printer.lhs +201/−0
- Text/Printf/TH/Simplify.lhs +102/−0
- Text/Printf/TH/Types.lhs +34/−0
+ Printf-TH.cabal view
@@ -0,0 +1,27 @@+Name: Printf-TH+author: Ian Lynagh <igloo@earth.li> June 2003+maintainer: Marc Weber <marco-oweber@gmx.de>+version: 0.1.1+Category: Utils+Build-Type: Simple+license: LGPL+Build-Depends: haskell98+ ,base+ ,template-haskell+ , pretty+exposed-modules: Text.Printf.TH+other-modules: + Text.Printf.TH.Parser+ , Text.Printf.TH.Printer+ , Text.Printf.TH.Simplify+ , Text.Printf.TH.Types+extensions: TemplateHaskell++--Executable: foo+--Main-Is: Foo.lhs+--extensions: TemplateHaskell+++--Executable: Test+--Main-Is: Test.lhs+--extensions: TemplateHaskell
+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple+main= defaultMain
+ Text/Printf/TH.lhs view
@@ -0,0 +1,53 @@++\begin{code}+module Text.Printf.TH (printf) where++-- import Text.PrettyPrint (render)+import Language.Haskell.TH+import Text.Printf.TH.Parser (parse)+import Text.Printf.TH.Types+import Text.Printf.TH.Simplify (simplify)++{-+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+-}++{-+printf takes a (format) string and returns a function that prints as it+describes.+-}+printf :: String -> ExpQ+printf s = do -- qIO $ putStrLn $ "Doing " ++ s+ let (formats, max_x_var) = parse s+ x_vars = (map (varP . mkName . xvar) [1..max_x_var])+ dec_n0 = valD (varP $ mkName $ nvar 0) (normalB [| 0 |]) []+ -- qIO $ putStrLn $ show (formats, max_x_var)+ e <- lamE x_vars (combine [dec_n0] [| showString "" |] 1 formats)+ -- qIO $ putStrLn $ render $ pprExp e+ return $ simplify e++combine :: [DecQ] -- List of declarations we will need at the end+ -> ExpQ -- The expression we are currently building+ -> ArgNum -- The next declaration number to be used+ -> [Format] -- The list of formats left to deal with+ -> ExpQ -- The final expression to splice in+combine decls building_exp y_num []+ = letE decls (tupE (e:(map (varE . mkName . nvar) [1..y_num-1])))+ where e = appE (foldr appE building_exp (map (varE . mkName . yvar) [1..y_num-1]))+ [| "" |]+combine decls building_exp y_num (CharCount:fs)+ = combine (decl_y:decl_n:decls) [| showString "" |] (y_num + 1) fs+ where decl_y = valD (varP ( mkName $ yvar y_num)) (normalB building_exp') []+ decl_n = valD (varP ( mkName $ nvar y_num)) (normalB length_exp) []+ building_exp' = [| ($building_exp .) |]+ length_exp = [| $( varE ( mkName $ nvar (y_num - 1)))+ + length ($(varE ( mkName $ yvar y_num)) (showString "") "") |]+combine decls building_exp y_num (Literal s:fs)+ = combine decls [| $building_exp . showString s |] y_num fs+combine decls building_exp y_num (Conversion e:fs)+ = combine decls [| $building_exp . showString $e |] y_num fs+\end{code}+
+ Text/Printf/TH/Parser.lhs view
@@ -0,0 +1,143 @@++\begin{code}+module Text.Printf.TH.Parser (parse) where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Maybe (isJust, fromJust)+import Text.Printf.TH.Printer (get_conversion_func)+import Char (isDigit)+import List (nub, delete)+import Text.Printf.TH.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 (mkName "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 (mkName "e")) ++ $exp_spaces |]+ exp_right_padded = [| $exp_spaces ++ $(varE (mkName "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 ( mkName (xvar i) ), [i], x_var, s')+ _ -> (varE (mkName (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}+
+ Text/Printf/TH/Printer.lhs view
@@ -0,0 +1,201 @@++\begin{code}+module Text.Printf.TH.Printer (get_conversion_func, thousandify, octalify, hexify) where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Maybe (fromMaybe)+import Numeric (showEFloat, showFFloat)+import Char (toLower, toUpper)+import Text.Printf.TH.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}+
+ Text/Printf/TH/Simplify.lhs view
@@ -0,0 +1,102 @@++\begin{code}+module Text.Printf.TH.Simplify (simplify, Simplify) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH+import Monad (liftM)++class Simplify a where+ simplify :: a -> a++instance Simplify a => Simplify (Q a) where+ simplify = liftM simplify++instance Simplify a => Simplify [a] where+ simplify = map simplify++instance Simplify Exp where+ --simplify (VarE "GHC.Base:otherwise") = ConE ''True+ simplify (AppE e1 e2) = AppE (simplify e1) (simplify e2)++ simplify (InfixE me1 (VarE op) me2)+ = let (me1', me2') = (fmap simplify me1, fmap simplify me2)+ in f me1' op me2' + where + f (Just (LitE (IntegerL i1))) x (Just (LitE (IntegerL i2))) | x == '(>) =+ if i1 > i2 then ConE 'True else ConE 'False+ f (Just (LitE (IntegerL i1))) x (Just (LitE (IntegerL i2))) | x == '(>=) =+ if i1 >= i2 then ConE 'True+ else ConE 'False+ f (Just (LitE (IntegerL i1))) x ( Just (LitE (IntegerL i2))) | x == '(<) =+ if i1 < i2 then ConE 'True+ else ConE 'False+ f (Just (LitE (IntegerL i1))) x (Just (LitE (IntegerL i2))) | x == '(<=) =+ if i1 <= i2 then ConE 'True+ else ConE 'False+ f (Just (LitE (IntegerL 0))) x (Just y) | x == '(+) = y+ f (Just y) x (Just (LitE (IntegerL 0))) | x == '(+) = y+ f (Just (LitE (IntegerL i1))) x (Just (LitE (IntegerL i2))) | x == '(+) =+ LitE (IntegerL (i1 + i2))+ f (Just (LitE (IntegerL 0))) x (Just y) | x == '(-) = AppE (VarE 'negate) y+ f (Just y) x (Just (LitE (IntegerL 0))) | x == '(-) = y+ f (Just (LitE (IntegerL i1))) x (Just (LitE (IntegerL i2))) | x == '(-) =+ LitE (IntegerL (i1 - i2))+ f (Just (LitE (IntegerL 1))) x (Just y) | x == '(*) = y+ f (Just y) x (Just (LitE (IntegerL 1))) | x == '(*) = y+ f (Just (LitE (IntegerL i1))) x (Just (LitE (IntegerL i2))) | x == '(*) =+ LitE (IntegerL (i1 * i2))+ f me1' _ me2' = InfixE me1' (VarE op) me2'+ simplify (CondE g t f) = let x = simplify g in+ f' x where f' (ConE y) | y == 'True = simplify t+ f' (ConE y) | y == 'False = simplify f+ f' g' = CondE g' (simplify t) (simplify f)+ simplify (LamE ps e) = LamE ps (simplify e)+ simplify (TupE es) = TupE (map simplify es)+ -- Should subst literals/vars?+ simplify (LetE ds e) = LetE (simplify ds) (simplify e)+ simplify (CaseE e ms) = CaseE (simplify e) (map simplify ms)+ simplify (DoE ss) = DoE (map simplify ss)+ simplify (CompE ss) = CompE (map simplify ss)+ simplify (ArithSeqE dd) = ArithSeqE (simplify dd)+ simplify (ListE es) = ListE (map simplify es)+ simplify (SigE e t) = SigE (simplify e) t+ simplify e = e++instance Simplify Dec where+ simplify (FunD f cs) = FunD f (map simplify cs)+ simplify (ValD p rhs ds) = ValD p (simplify rhs) (simplify ds)+ simplify (ClassD ctxt tycon [] tyvars ds) -- [] added correctly ? Marc+ = ClassD ctxt tycon [] tyvars (simplify ds)+ simplify (InstanceD ctxt typ ds) = InstanceD ctxt typ (simplify ds)+ simplify d = d++instance Simplify Body where+ simplify (NormalB e) = NormalB (simplify e)+ simplify (GuardedB ges)+ = GuardedB (map (\(e1, e2) -> (simplify e1, simplify e2)) ges)++instance Simplify Guard where+ simplify (NormalG e) = NormalG $ simplify e+ simplify (PatG l) = PatG $ map simplify l ++instance Simplify Range where+ simplify (FromR e) = FromR (simplify e)+ simplify (FromThenR e1 e2) = FromThenR (simplify e1) (simplify e2)+ simplify (FromToR e1 e2) = FromToR (simplify e1) (simplify e2)+ simplify (FromThenToR e1 e2 e3)+ = FromThenToR (simplify e1) (simplify e2) (simplify e3)++instance Simplify Stmt where+ simplify (BindS p e) = BindS p (simplify e)+ simplify (LetS ds) = LetS (simplify ds)+ simplify (NoBindS e) = NoBindS (simplify e)+ simplify (ParS _) = error "simplify[Statement]: ParS"++instance Simplify Match where+ simplify (Match p rhs ds) = Match p (simplify rhs) (simplify ds)++instance Simplify Clause where+ simplify (Clause ps rhs ds) = Clause ps (simplify rhs) (simplify ds)+\end{code}+
+ Text/Printf/TH/Types.lhs view
@@ -0,0 +1,34 @@++\begin{code}+module Text.Printf.TH.Types where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH++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}+