diff --git a/Printf-TH.cabal b/Printf-TH.cabal new file mode 100644 --- /dev/null +++ b/Printf-TH.cabal @@ -0,0 +1,27 @@ +Name: Printf-TH +author: Ian Lynagh June 2003 +maintainer: Marc Weber +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +module Main where +import Distribution.Simple +main= defaultMain diff --git a/Text/Printf/TH.lhs b/Text/Printf/TH.lhs new file mode 100644 --- /dev/null +++ b/Text/Printf/TH.lhs @@ -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} + diff --git a/Text/Printf/TH/Parser.lhs b/Text/Printf/TH/Parser.lhs new file mode 100644 --- /dev/null +++ b/Text/Printf/TH/Parser.lhs @@ -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} + diff --git a/Text/Printf/TH/Printer.lhs b/Text/Printf/TH/Printer.lhs new file mode 100644 --- /dev/null +++ b/Text/Printf/TH/Printer.lhs @@ -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} + diff --git a/Text/Printf/TH/Simplify.lhs b/Text/Printf/TH/Simplify.lhs new file mode 100644 --- /dev/null +++ b/Text/Printf/TH/Simplify.lhs @@ -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} + diff --git a/Text/Printf/TH/Types.lhs b/Text/Printf/TH/Types.lhs new file mode 100644 --- /dev/null +++ b/Text/Printf/TH/Types.lhs @@ -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} +