hformat (empty) → 0.1.0.0

raw patch · 4 files changed

+223/−0 lines, 4 filesdep +basedep +base-unicode-symbolsdep +hformatsetup-changed

Dependencies added: base, base-unicode-symbols, hformat, hspec, text

Files

• Setup.hs +2/−0
• hformat.cabal +36/−0
• src/Text/Format.hs +151/−0
• tests/Test.hs +34/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,36 @@+name:                hformat
+version:             0.1.0.0
+synopsis:            Simple Haskell formatting
+homepage:            http://github.com/mvoidex/hformat
+license:             BSD3
+author:              Alexandr Ruchkin
+maintainer:          voidex@live.com
+category:            Text
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -threaded -Wall -fno-warn-tabs
+  default-extensions: UnicodeSyntax
+  exposed-modules:     
+    Text.Format
+  build-depends:
+    base >= 4.8 && < 4.9,
+    base-unicode-symbols >= 0.2,
+    text >= 1.2.1
+
+test-suite test
+  type: exitcode-stdio-1.0
+  main-is: Test.hs
+  hs-source-dirs: tests
+  ghc-options: -threaded -Wall -fno-warn-tabs
+  default-language: Haskell2010
+  default-extensions: UnicodeSyntax
+  build-depends:
+    base >= 4.8 && < 4.9,
+    base-unicode-symbols >= 0.2,
+    text >= 1.2.1,
+    hspec,
+    hformat

@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, DefaultSignatures #-}
+
+-- | Format string with named args
+--
+-- >-- Named args
+-- >"My name is {name}, I am {age} years old" ~~ ("name" %= "Joe") ~~ ("age" %= 24) ≡ "My name is Joe, I am 24 years old"
+-- >-- Arg can have default value
+-- >"{var:x} = {val:10}" ~~ ("var" %= y) ≡ "y = 10"
+-- >-- Numeric position can be used
+-- >"{0} {1} {0}" ~~ "foo" ~~ "bar" ≡ "foo bar foo"
+-- >-- Positions can be omitted
+-- >"{} {}" ~~ "foo" ~~ 10 ≡ "foo 10"
+-- >-- Double braces to escape them
+-- >"{} and {{}}" ~~ 10 ≡ "10 and {}"
+module Text.Format (
+	FormatArg(..), Format(..), Formatter(..),
+	build,
+	FormatBuild(..), Hole(..), fmt, FormatResult(..),
+	format, (~~), (%=)
+	) where
+
+import Prelude.Unicode
+
+import Control.Applicative
+import Data.List (find)
+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 Text.Read (readMaybe)
+import Text.ParserCombinators.ReadP
+
+data FormatArg = FormatNamed String Builder | FormatPos Builder
+
+data Format = Format {
+	formatString ∷ String,
+	formatArgs ∷ [FormatArg] }
+
+instance IsString Format where
+	fromString str = Format str []
+
+data Formatter = Formatter {
+	formatter ∷ Either String Int,
+	formatterDefault ∷ Maybe String }
+
+instance Show Formatter where
+	show (Formatter f def) = "{" ++ either id show f ++ maybe "" (':':) def ++ "}"
+
+instance Read Formatter where
+	readsPrec _ = readP_to_S $ between (char '{') (char '}') $ do
+		n ← munch1 (∉ ":}")
+		v ← option Nothing $ do
+			_ ← char ':'
+			v' ← munch1 (≢ '}')
+			return $ Just v'
+		return $ Formatter (maybe (Left n) Right $ readMaybe n) v
+
+build ∷ Format → Text
+build 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)
+	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
+		(s, fstr'') = break (∈ "{}") fstr'
+	formatArg' ∷ Formatter → [FormatArg] → Builder
+	formatArg' (Formatter (Left name) defVal) args = fromMaybe (error $ "Argument " ++ name ++ " not set") (lookArg <|> fmap B.fromString defVal) where
+		lookArg = do
+			FormatNamed _ fval ← find byName args
+			return fval
+		byName (FormatNamed n _) = n ≡ name
+		byName _ = False
+	formatArg' (Formatter (Right i) defVal) args = fromMaybe (error $ "Argument at index " ++ show i ++ " not set") (lookIdx <|> fmap B.fromString defVal) where
+		lookIdx = do
+			FormatPos fval ← listToMaybe $ drop i $ filter isPos args
+			return fval
+		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
+
+instance FormatBuild String where
+	formatBuild = B.fromString
+
+instance FormatBuild Char where
+	formatBuild = B.singleton
+
+instance FormatBuild Int
+instance FormatBuild Integer
+instance FormatBuild Double
+instance FormatBuild Float
+instance FormatBuild Bool
+
+instance FormatBuild Text where
+	formatBuild = B.fromLazyText
+
+instance FormatBuild T.Text where
+	formatBuild = B.fromText
+
+class Hole a where
+	hole ∷ a → [FormatArg]
+
+instance Hole Builder where
+	hole = return ∘ FormatPos
+
+instance {-# OVERLAPPING #-} Hole [FormatArg] where
+	hole = id
+
+instance {-# OVERLAPPING #-} Hole [[FormatArg]] where
+	hole = concat
+
+instance {-# OVERLAPPABLE #-} FormatBuild a ⇒ Hole a where
+	hole = return ∘ FormatPos ∘ formatBuild
+
+fmt ∷ Hole a ⇒ a → [FormatArg]
+fmt = hole
+
+class FormatResult r where
+	formatResult ∷ Format → r
+
+instance FormatResult Format where
+	formatResult = id
+
+instance {-# OVERLAPPING #-} FormatResult Text where
+	formatResult = build
+
+instance {-# OVERLAPPABLE #-} IsString s ⇒ FormatResult s where
+	formatResult = fromString ∘ unpack ∘ formatResult
+
+format ∷ FormatResult r ⇒ String → r
+format = formatResult ∘ fromString
+
+infixl 7 ~~
+
+(~~) ∷ (Hole a, FormatResult r) ⇒ Format → a → r
+fstr ~~ arg = formatResult $ fstr { formatArgs = formatArgs fstr ++ hole arg }
+
+infixr 8 %=
+
+(%=) ∷ FormatBuild a ⇒ String → a → [FormatArg]
+name %= value = [FormatNamed name (formatBuild value)]

@@ -0,0 +1,34 @@+module Main (
+	main
+	) where
+
+import Prelude.Unicode
+
+import Text.Format
+
+import Test.Hspec
+
+main ∷ IO ()
+main = hspec $ do
+	describe "positional arguments" $ do
+		it "should format unnamed arguments" $
+			(format "{} + {} = {}" ~~ (10 ∷ Int) ~~ (12 ∷ Int) ~~ (22 ∷ Int) ≡ "10 + 12 = 22")
+		it "should format positional arguments" $
+			(format "{0} + {0} = {1}" ~~ (10 ∷ Int) ~~ (20 ∷ Int) ≡ "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")
+	describe "default values" $ do
+		it "should accept default values for positional arguments" $
+			(format "{0:foo} is {1:bar}" ~~ "blah" ≡ "blah is bar")
+		it "should accept default values for named arguments" $
+			(format "{x:12} + {y:13}" ~~ "y" %= (10 ∷ Int) ≡ "12 + 10")
+	describe "lists" $ do
+		it "should accept list of values" $
+			(format "{0} + {x:10} = {1}" ~~ [fmt (3 ∷ Int), "x" %= (5 ∷ Int), fmt (8 ∷ Int)] ≡ "3 + 5 = 8")
+	describe "escape" $
+		it "should escape curly braces" $
+			(format "{} is not {{}}" ~~ "{}" ≡ "{} 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")