hformat 0.2.0.0 → 0.3.0.0

raw patch · 5 files changed

+237/−75 lines, 5 filesdep +ansi-terminaldep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hformat.cabal +5/−2
• src/Text/Format.hs +113/−64
• src/Text/Format/Colored.hs +62/−0
• src/Text/Format/Flags.hs +37/−0
• tests/Test.hs +20/−9

@@ -1,5 +1,5 @@ name:                hformat
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:            Simple Haskell formatting
 description: String formatting
 homepage:            http://github.com/mvoidex/hformat
@@ -20,11 +20,14 @@   default-language: Haskell2010
   ghc-options: -Wall -fno-warn-tabs
   default-extensions: UnicodeSyntax
-  exposed-modules:     
+  exposed-modules:
     Text.Format
+    Text.Format.Flags
+    Text.Format.Colored
   build-depends:
     base >= 4.8 && < 5,
     base-unicode-symbols >= 0.2,
+    ansi-terminal >= 0.6,
     text >= 1.2.1
 
 test-suite test

@@ -13,123 +13,161 @@ -- >-- Double braces to escape them
 -- >"{} and {{}}" ~~ 10 ≡ "10 and {}"
 module Text.Format (
+	FormattedPart(..), Formatted(..), withFlags,
 	FormatArg(..), Format(..), Formatter(..),
 	prebuild, build,
-	FormatBuild(..), Hole(..), fmt, FormatResult(..),
-	format, formats, (~~), (~%)
+	Formattable(..), Hole(..), fmt, FormatResult(..),
+	format, formats, (~~), (~%),
+
+	module Text.Format.Flags
 	) where
 
 import Prelude.Unicode
 
 import Control.Applicative
-import Data.List (find)
+import Data.Char (intToDigit)
+import Data.List (find, intercalate, nub)
 import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import Data.Text.Lazy (Text, unpack)
-import Data.Text.Lazy.Builder (Builder)
-import qualified Data.Text.Lazy.Builder as B
 import Data.String
+import Numeric
 import Text.Read (readMaybe)
 import Text.ParserCombinators.ReadP
 
-data FormatArg = FormatNamed String Builder | FormatPos Builder
+import Text.Format.Flags
 
+data FormattedPart = FormattedPart {
+	formattedFlags ∷ FormatFlags,
+	formattedValue ∷ String }
+		deriving (Eq, Ord, Show)
+
+instance IsString FormattedPart where
+	fromString = FormattedPart [] ∘ fromString
+
+newtype Formatted = Formatted { formattedParts ∷ [FormattedPart] } deriving (Eq, Ord, Show)
+
+instance IsString Formatted where
+	fromString = Formatted ∘ return ∘ fromString
+
+instance Monoid Formatted where
+	mempty = Formatted []
+	Formatted l `mappend` Formatted r = Formatted $ l ++ r
+
+withFlags ∷ String → [String] → Formatted
+withFlags v fs = Formatted [FormattedPart fs v]
+
+data FormatArg = FormatNamed String ([String] → Formatted) | FormatPos ([String] → Formatted)
+
 data Format = Format {
 	formatString ∷ String,
 	formatArgs ∷ [FormatArg] }
 
 instance Show Format where
-	show = unpack ∘ prebuild
+	show = mconcat ∘ map formattedValue ∘ formattedParts ∘ prebuild
 
 instance IsString Format where
 	fromString str = Format str []
 
 data Formatter = Formatter {
 	formatter ∷ Either String Int,
-	formatterDefault ∷ Maybe String }
+	formatterDefault ∷ Maybe String,
+	formatterFlags ∷ [String] }
 
 instance Show Formatter where
-	show (Formatter f def) = "{" ++ either id show f ++ maybe "" (':':) def ++ "}"
+	show (Formatter f def cfgs) = "{" ++ concat parts ++ "}" where
+		parts = [either id show f, fromMaybe "" (fmap ('=':) def), if null cfgs then "" else (':' : intercalate "," cfgs)]
 
 instance Read Formatter where
 	readsPrec _ = readP_to_S $ between (char '{') (char '}') $ do
-		n ← munch1 (∉ ":}")
+		n ← munch (∉ "=:}")
 		v ← option Nothing $ do
-			_ ← char ':'
-			v' ← munch1 (≢ '}')
+			_ ← char '='
+			v' ← munch1 (∉ ":}")
 			return $ Just v'
-		return $ Formatter (maybe (Left n) Right $ readMaybe n) v
+		cs ← option [] $ do
+			_ ← char ':'
+			flip sepBy (char ',') (munch1 (∉ ",}"))
+		return $ Formatter (maybe (Left n) Right $ readMaybe n) v cs
 
-prebuild ∷ Format → Text
+prebuild ∷ Format → Formatted
 prebuild = buildFormat True
 
-build ∷ Format → Text
+build ∷ Format → Formatted
 build = buildFormat False
 
-buildFormat ∷ Bool → Format → Text
-buildFormat pre fstr = B.toLazyText $ mconcat $ build' 0 fstr where
-	build' ∷ Int → Format → [Builder]
-	build' _ (Format "" _) = []
-	build' i (Format ('{':'{':fstr') args) = B.singleton '{' : build' i (Format fstr' args)
-	build' i (Format ('}':'}':fstr') args) = B.singleton '}' : build' i (Format fstr' args)
-	build' i (Format ('{':'}':fstr') args) = formatArg' (Formatter (Right i) Nothing) args : build' (succ i) (Format fstr' args)
+buildFormat ∷ Bool → Format → Formatted
+buildFormat pre fstr = build' 0 fstr where
+	build' ∷ Int → Format → Formatted
+	build' _ (Format "" _) = mempty
+	build' i (Format ('{':'{':fstr') args) = fromString "{" `mappend` build' i (Format fstr' args)
+	build' i (Format ('}':'}':fstr') args) = fromString "}" `mappend` build' i (Format fstr' args)
+	build' i (Format ('{':'}':fstr') args) = formatArg' (Formatter (Right i) Nothing []) args `mappend` build' (succ i) (Format fstr' args)
 	build' i (Format ('{':fstr') args) = case reads ('{':fstr') of
 		[] → error $ "Can't parse formatter at " ++ fstr'
-		(f, fstr''):_ → formatArg' f args : build' i (Format fstr'' args)
-	build' i (Format fstr' args) = fromString s : build' i (Format fstr'' args) where
+		(f, fstr''):_ → formatArg' f args `mappend` build' i (Format fstr'' args)
+	build' i (Format fstr' args) = fromString s `mappend` build' i (Format fstr'' args) where
 		(s, fstr'') = break (∈ "{}") fstr'
-	formatArg' ∷ Formatter → [FormatArg] → Builder
-	formatArg' f@(Formatter (Left name) defVal) args
-		| pre = fromMaybe (formatBuild f) lookArg
-		| otherwise = fromMaybe (error $ "Argument " ++ name ++ " not set") (lookArg <|> fmap formatBuild defVal)
+	formatArg' ∷ Formatter → [FormatArg] → Formatted
+	formatArg' f@(Formatter (Left name) defVal fmtCfgs) args
+		| pre = fromMaybe (formatted f fmtCfgs) lookArg
+		| otherwise = fromMaybe (error $ "Argument " ++ name ++ " not set") (lookArg <|> fmap (flip formatted fmtCfgs) defVal)
 		where
 			lookArg = do
 				FormatNamed _ fval ← find byName args
-				return fval
+				return $ fval fmtCfgs
 			byName (FormatNamed n _) = n ≡ name
 			byName _ = False
-	formatArg' f@(Formatter (Right i) defVal) args
-		| pre = fromMaybe (formatBuild f) lookIdx
-		| otherwise = fromMaybe (error $ "Argument at index " ++ show i ++ " not set") (lookIdx <|> fmap formatBuild defVal)
+	formatArg' f@(Formatter (Right i) defVal fmtCfgs) args
+		| pre = fromMaybe (formatted f fmtCfgs) lookIdx
+		| otherwise = fromMaybe (error $ "Argument at index " ++ show i ++ " not set") (lookIdx <|> fmap (flip formatted fmtCfgs) defVal)
 		where
 			lookIdx = do
 				FormatPos fval ← listToMaybe $ drop i $ filter isPos args
-				return fval
+				return $ fval fmtCfgs
 			isPos (FormatPos _) = True
 			isPos _ = False
 
--- | FormatBuild class, by default using @show@
-class FormatBuild a where
-	formatBuild ∷ a → Builder
-	default formatBuild ∷ Show a ⇒ a → Builder
-	formatBuild = B.fromString ∘ show
+-- | Formattable class, by default using @show@
+class Formattable a where
+	formattable ∷ a → FormatFlags → Formatted
+	default formattable ∷ Show a ⇒ a → FormatFlags → Formatted
+	formattable x _ = fromString ∘ show $ x
 
-instance FormatBuild String where
-	formatBuild = B.fromString
+formatted ∷ Formattable a ⇒ a → FormatFlags → Formatted
+formatted v fmts = Formatted ∘ map addFmts ∘ formattedParts ∘ formattable v $ fmts where
+	addFmts (FormattedPart flags' v') = FormattedPart (nub $ fmts ++ flags') v'
 
-instance FormatBuild Char where
-	formatBuild = B.singleton
+instance Formattable String where
+	formattable s _ = fromString s
 
-instance FormatBuild Int
-instance FormatBuild Integer
-instance FormatBuild Double
-instance FormatBuild Float
-instance FormatBuild Bool
+instance Formattable Char where
+	formattable ch _ = fromString [ch]
 
-instance FormatBuild Text where
-	formatBuild = B.fromLazyText
+instance Formattable Int where
+	formattable i fmts = fromString ∘ formatInt (baseFlag fmts) $ i
+instance Formattable Integer where
+	formattable i fmts = fromString ∘ formatInt (baseFlag fmts) $ i
+instance Formattable Double where
+	formattable d fmts = fromString ∘ formatDouble (preciseFlag fmts) $ d
+instance Formattable Float where
+	formattable f fmts = fromString ∘ formatDouble (preciseFlag fmts) $ f
+instance Formattable Bool
 
-instance FormatBuild T.Text where
-	formatBuild = B.fromText
+instance Formattable Text where
+	formattable s _ = fromString ∘ unpack $ s
 
-instance FormatBuild Formatter where
-	formatBuild = formatBuild ∘ show
+instance Formattable T.Text where
+	formattable s _ = fromString ∘ T.unpack $ s
 
+instance Formattable Formatter where
+	formattable s _ = fromString ∘ show $ s
+
 class Hole a where
 	hole ∷ a → [FormatArg]
 
-instance Hole Builder where
-	hole = return ∘ FormatPos
+instance Hole Formatted where
+	hole v = [FormatPos $ const v]
 
 instance {-# OVERLAPPING #-} Hole FormatArg where
 	hole = return
@@ -140,11 +178,11 @@ instance {-# OVERLAPPING #-} Hole [[FormatArg]] where
 	hole = concat
 
-instance {-# OVERLAPPABLE #-} FormatBuild a ⇒ Hole a where
-	hole = return ∘ FormatPos ∘ formatBuild
+instance {-# OVERLAPPABLE #-} Formattable a ⇒ Hole a where
+	hole v = [FormatPos $ formatted v]
 
-fmt ∷ FormatBuild a ⇒ a → FormatArg
-fmt = FormatPos ∘ formatBuild
+fmt ∷ Formattable a ⇒ a → FormatArg
+fmt v = FormatPos $ formatted v
 
 class FormatResult r where
 	formatResult ∷ Format → r
@@ -152,12 +190,15 @@ instance FormatResult Format where
 	formatResult = id
 
-instance {-# OVERLAPPING #-} FormatResult Text where
-	formatResult = build
+instance {-# OVERLAPPING #-} FormatResult String where
+	formatResult = mconcat ∘ map formattedValue ∘ formattedParts ∘ build
 
 instance {-# OVERLAPPABLE #-} IsString s ⇒ FormatResult s where
-	formatResult = fromString ∘ unpack ∘ formatResult
+	formatResult = fromString ∘ formatResult
 
+instance {-# OVERLAPPABLE #-} FormatResult Formatted where
+	formatResult = build
+
 format ∷ FormatResult r ⇒ String → r
 format = formatResult ∘ fromString
 
@@ -171,5 +212,13 @@ 
 infixr 8 ~%
 
-(~%) ∷ FormatBuild a ⇒ String → a → FormatArg
-name ~% value = FormatNamed name (formatBuild value)
+(~%) ∷ Formattable a ⇒ String → a → FormatArg
+name ~% value = FormatNamed name (formatted value)
+
+-- * Util
+
+formatInt ∷ (Show a, Integral a) ⇒ a → a → String
+formatInt base v = showIntAtBase base intToDigit v ""
+
+formatDouble ∷ RealFloat a ⇒ Maybe Int → a → String
+formatDouble p v = showGFloat p v ""

@@ -0,0 +1,62 @@+module Text.Format.Colored (
+	colored, coloredLine,
+	hColored, hColoredLine
+	) where
+
+import Prelude.Unicode
+
+import Data.Maybe (mapMaybe)
+import System.Console.ANSI
+import System.IO
+
+import Text.Format
+
+colored ∷ Formatted → IO ()
+colored = hColored stdout
+
+coloredLine ∷ Formatted → IO ()
+coloredLine = hColoredLine stdout
+
+hColored ∷ Handle → Formatted → IO ()
+hColored h (Formatted fs) = mapM_ go fs >> setSGR [] where
+	go (FormattedPart flags v) = setFlags flags >> hPutStr h v >> setSGR []
+	setFlags = setSGR ∘ mapMaybe toSGR
+	toSGR "bold" = Just $ SetConsoleIntensity BoldIntensity
+	toSGR "italic" = Just $ SetItalicized True
+	toSGR "undelined" = Just $ SetUnderlining SingleUnderline
+	toSGR "black" = Just $ SetColor Foreground Vivid Black
+	toSGR "red" = Just $ SetColor Foreground Vivid Red
+	toSGR "green" = Just $ SetColor Foreground Vivid Green
+	toSGR "yellow" = Just $ SetColor Foreground Vivid Yellow
+	toSGR "blue" = Just $ SetColor Foreground Vivid Blue
+	toSGR "magenta" = Just $ SetColor Foreground Vivid Magenta
+	toSGR "cyan" = Just $ SetColor Foreground Vivid Cyan
+	toSGR "white" = Just $ SetColor Foreground Vivid White
+	toSGR "darkgray" = Just $ SetColor Foreground Dull Black
+	toSGR "darkred" = Just $ SetColor Foreground Dull Red
+	toSGR "darkgreen" = Just $ SetColor Foreground Dull Green
+	toSGR "darkyellow" = Just $ SetColor Foreground Dull Yellow
+	toSGR "darkblue" = Just $ SetColor Foreground Dull Blue
+	toSGR "darkmagenta" = Just $ SetColor Foreground Dull Magenta
+	toSGR "darkcyan" = Just $ SetColor Foreground Dull Cyan
+	toSGR "gray" = Just $ SetColor Foreground Dull White
+	toSGR "bg/black" = Just $ SetColor Background Vivid Black
+	toSGR "bg/red" = Just $ SetColor Background Vivid Red
+	toSGR "bg/green" = Just $ SetColor Background Vivid Green
+	toSGR "bg/yellow" = Just $ SetColor Background Vivid Yellow
+	toSGR "bg/blue" = Just $ SetColor Background Vivid Blue
+	toSGR "bg/magenta" = Just $ SetColor Background Vivid Magenta
+	toSGR "bg/cyan" = Just $ SetColor Background Vivid Cyan
+	toSGR "bg/white" = Just $ SetColor Background Vivid White
+	toSGR "bg/darkgray" = Just $ SetColor Background Dull Black
+	toSGR "bg/darkred" = Just $ SetColor Background Dull Red
+	toSGR "bg/darkgreen" = Just $ SetColor Background Dull Green
+	toSGR "bg/darkyellow" = Just $ SetColor Background Dull Yellow
+	toSGR "bg/darkblue" = Just $ SetColor Background Dull Blue
+	toSGR "bg/darkmagenta" = Just $ SetColor Background Dull Magenta
+	toSGR "bg/darkcyan" = Just $ SetColor Background Dull Cyan
+	toSGR "bg/gray" = Just $ SetColor Background Dull White
+	toSGR _ = Nothing
+
+hColoredLine ∷ Handle → Formatted → IO ()
+hColoredLine h f = hColored h f >> hPutStrLn h ""

@@ -0,0 +1,37 @@+module Text.Format.Flags (
+	FormatFlags,
+	getFlag, hasFlag,
+	baseFlag, preciseFlag
+	) where
+
+import Prelude.Unicode
+
+import Control.Applicative
+import Data.List (stripPrefix)
+import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
+import Text.Read
+
+type FormatFlags = [String]
+
+getFlag ∷ (String → Maybe a) → [String] → Maybe a
+getFlag fn = listToMaybe ∘ mapMaybe fn
+
+hasFlag ∷ String → [String] → Bool
+hasFlag = (∈)
+
+getFlagValue ∷ Read a ⇒ String → [String] → Maybe a
+getFlagValue nm fmts = do
+	f ← getFlag (stripPrefix (nm ++ "=")) fmts
+	readMaybe f
+
+baseFlag ∷ (Read a, Integral a) ⇒ [String] → a
+baseFlag fmts
+	| hasFlag "bin" fmts ∨ hasFlag "b" fmts = 2
+	| hasFlag "octal" fmts ∨ hasFlag "o" fmts = 8
+	| hasFlag "hex" fmts ∨ hasFlag "h" fmts = 16
+	| otherwise = fromMaybe 10 (getFlagValue "base" fmts <|> getFlagValue "b" fmts)
+
+preciseFlag ∷ [String] → Maybe Int
+preciseFlag fmts = read <$> listToMaybe (mapMaybe preciseFlag' fmts) where
+	preciseFlag' ('d':d) = Just d
+	preciseFlag' _ = Nothing

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}
+
 module Main (
 	main
 	) where
@@ -12,26 +14,35 @@ main = hspec $ do
 	describe "positional arguments" $ do
 		it "should format unnamed arguments"
-			(format "{} + {} = {}" ~~ (10 ∷ Int) ~~ (12 ∷ Int) ~~ (22 ∷ Int) ≡ "10 + 12 = 22")
+			(format "{} + {} = {}" ~~ (10 ∷ Int) ~~ (12 ∷ Int) ~~ (22 ∷ Int) ≡ str "10 + 12 = 22")
 		it "should format positional arguments"
-			(format "{0} + {0} = {1}" ~~ (10 ∷ Int) ~~ (20 ∷ Int) ≡ "10 + 10 = 20")
+			(format "{0} + {0} = {1}" ~~ (10 ∷ Int) ~~ (20 ∷ Int) ≡ str "10 + 10 = 20")
 	describe "named arguments" $
 		it "should format named arguments"
-			(format "{x} + {y} = {z}" ~~ "x" ~% (1 ∷ Int) ~~ "y" ~% (2 ∷ Int) ~~ "z" ~% (3 ∷ Int) ≡ "1 + 2 = 3")
+			(format "{x} + {y} = {z}" ~~ "x" ~% (1 ∷ Int) ~~ "y" ~% (2 ∷ Int) ~~ "z" ~% (3 ∷ Int) ≡ str "1 + 2 = 3")
 	describe "default values" $ do
 		it "should accept default values for positional arguments"
-			(format "{0:foo} is {1:bar}" ~~ "blah" ≡ "blah is bar")
+			(format "{0=foo} is {1=bar}" ~~ str "blah" ≡ str "blah is bar")
 		it "should accept default values for named arguments"
-			(format "{x:12} + {y:13}" ~~ "y" ~% (10 ∷ Int) ≡ "12 + 10")
+			(format "{x=12} + {y=13}" ~~ "y" ~% (10 ∷ Int) ≡ str "12 + 10")
+	describe "format options" $ do
+		it "should accept format options"
+			(format "x is {0=foo:octal}" ~~ (10 ∷ Int) ≡ str "x is 12")
+	describe "colorized output" $ do
+		it "should accept colors"
+			(format "x is {0:red}" ~~ (10 ∷ Int) ≡ Formatted [FormattedPart [] "x is ", FormattedPart ["red"] "10"])
 	describe "lists" $
 		it "should accept list of values"
-			(format "{0} + {x:10} = {1}" ~~ [fmt (3 ∷ Int), "x" ~% (5 ∷ Int), fmt (8 ∷ Int)] ≡ "3 + 5 = 8")
+			(format "{0} + {x:10} = {1}" ~~ [fmt (3 ∷ Int), "x" ~% (5 ∷ Int), fmt (8 ∷ Int)] ≡ str "3 + 5 = 8")
 	describe "escape" $
 		it "should escape curly braces"
-			(format "{} is not {{}}" ~~ "{}" ≡ "{} is not {}")
+			(format "{} is not {{}}" ~~ str "{}" ≡ str "{} is not {}")
 	describe "mix" $
 		it "should process mixed arguments"
-			(format "{1:foo} and {} are {what:args}" ~~ "what" ~% "quux" ~~ (10 ∷ Int) ~~ (20 ∷ Int) ≡ "20 and 10 are quux")
+			(format "{1=foo} and {} are {what=args}" ~~ str "what" ~% str "quux" ~~ (10 ∷ Int) ~~ (20 ∷ Int) ≡ str "20 and 10 are quux")
 	describe "prebuild" $
 		it "should show partially formatted" $
-			show (format "{0} ≡ {1}" ~~ "foo" ∷ Format) ≡ "foo ≡ {1}"
+			show (format "{0} ≡ {1}" ~~ str "foo" ∷ Format) ≡ str "foo ≡ {1}"
+
+str ∷ String → String
+str = id