Skip to content
Browse files

Import Format library files.

  • Loading branch information...
1 parent 4ce40d2 commit 1d1f93b25756ee6dee167bc5ee58a467cdfea06b @spl committed Jun 19, 2009
Showing with 237 additions and 0 deletions.
  1. +168 −0 Format.hs
  2. +69 −0 FormatTest.hs
View
168 Format.hs
@@ -0,0 +1,168 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- A library for printing formats to strings, reminiscent of the C sprintf
+-- function. This library uses Template Haskell to ensure the arguments are
+-- statically well-typed. Derived from work by Oleg Kiselyov.
+
+module Format (sprintf, sprintff, fmt, fmtq) where
+
+--------------------------------------------------------------------------------
+
+import Prelude hiding ((^))
+import qualified Prelude (Show, show)
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+import Generics.EMGM (Rep)
+import qualified Generics.EMGM as EMGM (Show, show)
+
+import Data.Data (Data)
+import Data.Generics.Text (gshow)
+
+import Data.Ratio (Ratio)
+
+--------------------------------------------------------------------------------
+
+-- A language of format descriptors
+data Fmt
+ = Literal String
+ | EMGMFmt
+ | SYBFmt
+ | StringFmt
+ | ShowFmt
+ | NumFmt
+ | RealFmt
+ | IntFmt
+ | IntegerFmt
+ | FloatFmt
+ | DoubleFmt
+ | RatioFmt
+ | CharFmt
+ deriving (Eq, Show)
+
+-- Parse a character code to get a format descriptor
+fmtOf :: Char -> Maybe Fmt
+fmtOf c =
+ case c of
+ 'e' -> Just EMGMFmt
+ 'y' -> Just SYBFmt
+ 's' -> Just StringFmt
+ 'S' -> Just ShowFmt
+ 'N' -> Just NumFmt
+ 'R' -> Just RealFmt
+ 'i' -> Just IntFmt
+ 'n' -> Just IntegerFmt
+ 'f' -> Just FloatFmt
+ 'd' -> Just DoubleFmt
+ 'r' -> Just RatioFmt
+ 'c' -> Just CharFmt
+ _ -> Nothing
+
+--------------------------------------------------------------------------------
+
+-- Interpret a literal or a format descriptor into generated code.
+expOf :: Fmt -> ExpQ
+expOf (Literal s) = [| literal s |]
+expOf EMGMFmt = [| emgmFmt |]
+expOf SYBFmt = [| sybFmt |]
+expOf StringFmt = [| stringFmt |]
+expOf ShowFmt = [| showFmt |]
+expOf NumFmt = [| showFmt :: Num a => Formatter a w |]
+expOf RealFmt = [| showFmt :: Real a => Formatter a w |]
+expOf IntFmt = [| showFmt :: Formatter Int w |]
+expOf IntegerFmt = [| showFmt :: Formatter Integer w |]
+expOf FloatFmt = [| showFmt :: Formatter Float w |]
+expOf DoubleFmt = [| showFmt :: Formatter Double w |]
+expOf RatioFmt = [| showFmt :: Integral a => Formatter (Ratio a) w |]
+expOf CharFmt = [| showFmt :: Formatter Char w |]
+
+literal :: String -> (String -> w) -> w
+literal str k = k str
+
+type Formatter a w = (String -> w) -> (a -> w)
+
+stringFmt :: Formatter String w
+stringFmt k x = k x
+
+printFmt :: (a -> String) -> (String -> w) -> a -> w
+printFmt f k x = k (f x)
+
+emgmFmt :: (Rep EMGM.Show a) => Formatter a w
+emgmFmt = printFmt EMGM.show
+
+sybFmt :: (Data a) => Formatter a w
+sybFmt = printFmt gshow
+
+showFmt :: (Prelude.Show a) => Formatter a w
+showFmt = printFmt Prelude.show
+
+-- Composition of formatters
+infixr 8 ^
+(^) :: ((String -> w1) -> w1') -> ((String -> w2) -> w1) -> ((String -> w2) -> w1')
+f1 ^ f2 = \k -> f1 (\s1 -> f2 (\s2 -> k (s1 ++ s2)))
+
+-- Interpret a list of format descriptors to generate code.
+interpret :: [Fmt] -> ExpQ
+interpret [f] = expOf f
+interpret (f:fs) = [| $(expOf f) ^ $(interpret fs)|]
+
+-- Parse the string into a list of literal strings and format descriptors.
+parse :: String -> [Fmt]
+parse input = result
+ where
+ (first,last) = break (=='%') input
+ next =
+ case last of
+ "" -> []
+ '%':'%':rest -> Literal "%" : parse rest
+ '%':c:rest ->
+ case fmtOf c of
+ Nothing -> error $ showString "Bad format: %" . showChar c $ ""
+ Just f -> f : parse rest
+ result = if null first then next else Literal first : next
+
+--------------------------------------------------------------------------------
+
+-- Exported functions
+
+-- For use inside the spicing, e.g. @$(fmt "Hi!")@ generates @lit "Hi!@. Only
+-- really useful if combined with 'sprintf'.
+fmt :: String -> ExpQ
+fmt = interpret . parse
+
+-- For use as a quasi-quoter, e.g. @[$fmtq|Hi!|]@ generates @lit "Hi!@. Only
+-- really useful if combined with 'sprintf'.
+fmtq :: QuasiQuoter
+fmtq = QuasiQuoter fmt (const $ error "A fmt cannot be used in a pattern.")
+
+-- Print a formatted string with a variable number of arguments to a string. The
+-- first argument is a Template Haskell spliced value using either 'fmt' or
+-- 'fmtq'.
+sprintf :: ((String -> String) -> a) -> a
+sprintf f = f id
+
+-- Same as 'sprintf' but used inside the splice with an extra parameter. Thus:
+-- @$(sprintff "Hi!")@. Warning: The errors reported for this function may be
+-- less comprehensible than those for 'sprintf'.
+sprintff :: String -> ExpQ
+sprintff s = [| $(fmt s) id |]
+
+--------------------------------------------------------------------------------
+
+-- Testing
+
+showCode cde = runQ cde >>= putStrLn . pprint
+
+tc1 = showCode (fmt "abc")
+tc2 = showCode (fmt "Hello %e!")
+
+test_lexFmt = and
+ [ parse "Simple lit" == [Literal "Simple lit"]
+ , parse "%s insert" == [StringFmt, Literal " insert"]
+ , parse "insert %s here" == [Literal "insert ", StringFmt, Literal " here"]
+ , parse "The value of %s is %i" == [Literal "The value of ", StringFmt, Literal " is ", IntFmt]
+ , parse "A %e prints generically!" == [Literal "A ", EMGMFmt, Literal " prints generically!"]
+ ]
+
View
69 FormatTest.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module FormatTest where
+
+import Format
+
+t1 = sprintf $(fmt "Hello, there!")
+-- "Hello, there!"
+
+t2 = sprintf $(fmt "Hello, %s!") "there"
+-- "Hello, there!"
+
+t3 = sprintf $(fmt "The value of %s is %d") "x" 3
+-- "The value of x is 3"
+
+t3q = sprintf [$fmtq|The value of %s is %i|] "x" 3
+-- "The value of x is 3"
+
+-- Mismatch between the formatting string and the printf arguments
+-- is a type error.
+
+{-
+t4 = sprintf $(fmt "The value of %s is %d") "x" True
+-- Couldn't match expected type `Bool' against inferred type `Double'
+-}
+
+{-
+t5 = $(sprintff "The value of %s is %d") "x" True
+-- Couldn't match expected type `Double' against inferred type `Bool'
+-}
+
+-- Notice the difference between the errors in t4 and t5. I think the latter
+-- makes more sense.
+
+{-
+t6 = sprintf $(fmt "The value of %s is %d") "x" 3 10
+-- Couldn't match expected type `t1 -> t'
+-- against inferred type `[Char]'
+-- Probable cause: `sprintf' is applied to too many arguments
+-}
+
+{-
+t7 = $(sprintff "The value of %s is %d") "x" 3 10
+-- Couldn't match expected type `t1 -> t'
+-- against inferred type `String'
+-- In the first argument of `(Format.literal ['T', 'h', 'e', ' ', ....]
+-- ...
+-}
+
+-- Notice the difference between the errors in t6 and t7. The latter is less
+-- comprehensible.
+
+t8 = let x = [9,16,25]
+ i = 2
+ in sprintf $(fmt "The element number %i of %e is %f") i x (x !! i)
+-- "The element number 2 of [9,16,25] is 25"
+
+t9 = let x = [9,16,25]
+ i = 2
+ in $(sprintff "The element number %N of %S is %N") i x (x !! i)
+-- "The element number 2 of [9,16,25] is 25"
+
+t10 = sprintf $(fmt "The EMGM output of %s is %e") "3" (3 :: Int)
+-- "The value in EMGM of x is 3"
+
+t11 = sprintf $(fmt "The SYB output of %s is %y") "3" (3 :: Int)
+-- "The value in SYB of x is 3"
+

0 comments on commit 1d1f93b

Please sign in to comment.
Something went wrong with that request. Please try again.