diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Hiromi ISHII + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hiromi ISHII nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,70 @@ +safe-printf -- Well-typed, variadic and flexible printf functions for Haskell +============================================================================= + +[![Build Status](https://travis-ci.org/konn/safe-printf.svg?branch=master)](https://travis-ci.org/konn/safe-printf) +[![loop-effin](http://img.shields.io/hackage/v/safe-printf.svg)](http://hackage.haskell.org/package/safe-printf) + +## What is this? +Haskell's standard `Text.Printf` module provides variadic `printf` function but not type-safe. +This library provides an alternative for this, more type-safe version of `printf` function, +combinators and quasiquoters. + +The current implementation is just a proof-of-concept, so it is not so efficient and provides +APIs only for `String` value generation. In future, we will support `Text` +types and improve the effiiciency. + +## Install +```sh +$ git clone https://github.com/konn/safe-printf.git +$ cd safe-printf +$ cabal install +``` + + + +## Usage +We provide two interfaces to construct format: smart constructors and quasiquoters. + +### Smart constructors +You need `OverloadedStrings` extension. + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main where +import Text.Printf.Safe (printf, (%), (><)) +import Text.Printf.Safe.Combinators (b', d, _S) +main = do + putStrLn $ printf ("1 + 2 = " %d >< " and 0 == 1 is " %_S >< "." ) (1 + 2) (0 == 1) + putStrLn $ printf ("42 is " % b' '0' 10 >< "in binary.") 42 + putStrLn $ printf ("48% of people answers that the negation of True is" %(show . not) >< ".") True +``` + +### Quasiquote interface +Quiasiquote interface provides more readable way for generating formats. + +```haskell +{-# LANGUAGE QuasiQuotes #-} +module Main where +import Text.Printf.Safe (printf, fmt) +main = do + putStrLn $ printf [fmt|1 + 2 = %d and 0 == 1 is %S.|] (1 + 2) (0 == 1) + putStrLn $ printf [fmt|42 is %010b in binary.|] 42 + putStrLn $ printf [fmt|48%% of people answers that the negation of True is %{show . not}.|] True +``` + +## TODO +* Support `Text` and perhaps `Builder`. +* Improve efficiency. +* Provide IO functions? + +## Licence + +BSD3 + +## Copyright + +(c) Hiromi ISHII 2015 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/combinator.hs b/examples/combinator.hs new file mode 100644 --- /dev/null +++ b/examples/combinator.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where +import Text.Printf.Safe +import Text.Printf.Safe.Combinators (b', d, _S) + +main :: IO () +main = do + putStrLn $ printf ("1 + 2 = " %d >< " and 0 == 1 is " %_S >< "." ) (1 + 2) (0 == 1) + putStrLn $ printf ("42 is " % b' '0' 10 >< "in binary.") 42 + putStrLn $ printf ("48% of people answers that the negation of True is " %(show . not) >< ".") True diff --git a/examples/quasi.hs b/examples/quasi.hs new file mode 100644 --- /dev/null +++ b/examples/quasi.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where +import Text.Printf.Safe (fmt, printf) + +main = do + putStrLn $ printf [fmt|1 + 2 = %d and 0 == 1 is %S.|] (1 + 2) (0 == 1) + putStrLn $ printf [fmt|42 is %010b in binary.|] 42 + putStrLn $ printf [fmt|48%% of people answers that the negation of True is %{show . not}.|] True diff --git a/safe-printf.cabal b/safe-printf.cabal new file mode 100644 --- /dev/null +++ b/safe-printf.cabal @@ -0,0 +1,55 @@ +-- Initial safe-printf.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: safe-printf +version: 0.1.0.0 +synopsis: Well-typed, flexible and variadic printf for Haskell +description: More type-safe, flexible replacement of variadic printf for Text.Printf. +homepage: https://github.com/konn/safe-printf +license: BSD3 +license-file: LICENSE +author: Hiromi ISHII +maintainer: konn.jinro_at_gmail.com +copyright: (c) Hiromi ISHII 2015 +category: Text +build-type: Simple +extra-source-files: README.md, examples/*.hs +cabal-version: >=1.10 + +source-repository head + Type: git + Location: git://github.com/konn/safe-printf.git + +library + exposed-modules: Text.Printf.Safe, + Text.Printf.Safe.QQ, + Text.Printf.Safe.Core, + Text.Printf.Safe.Combinators + other-modules: Text.Printf.Safe.QQ.Internal + build-depends: base >=4 && <5 + , haskell-src-meta >=0.6 && <0.7 + , template-haskell >=2.9 && <2.11 + , th-lift >=0.6 && <0.8 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test, src + ghc-options: -Wall + Main-is: Spec.hs + build-depends: QuickCheck + , base >=4 && <5 + , hspec + , haskell-src-meta >=0.6 && <0.7 + , template-haskell >=2.9 && <2.11 + , th-lift >=0.6 && <0.8 +test-suite doctest + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + HS-Source-Dirs: test + Ghc-Options: -threaded -Wall + Main-Is: doctests.hs + Build-Depends: base + , doctest diff --git a/src/Text/Printf/Safe.hs b/src/Text/Printf/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/Safe.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleInstances, GADTs #-} +{-# LANGUAGE OverloadedStrings, PolyKinds, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving, TypeFamilies, TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Text.Printf.Safe (module Text.Printf.Safe.Core, + module Text.Printf.Safe.QQ, + module Text.Printf.Safe.Combinators) where +import Text.Printf.Safe.Combinators ((%), (+++), (><)) +import Text.Printf.Safe.Core +import Text.Printf.Safe.QQ + diff --git a/src/Text/Printf/Safe/Combinators.hs b/src/Text/Printf/Safe/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/Safe/Combinators.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} +module Text.Printf.Safe.Combinators (-- * Smart constructors + type (<>), (><), (%), (+++), + -- * Basic formatters + s, _S, _shows, + -- ** Number Formatters + base, d, d', o, o', b, b', h, h', f) where +import Data.Char (intToDigit) +import Data.Type.Equality ((:~:) (..), gcastWith) +import Numeric (showFloat, showIntAtBase) +import Text.Printf.Safe.Core (Printf (..), Formatter) + +-- * Smart constructors +type family (<>) xs ys where + (<>) '[] xs = xs + (<>) (x ': xs) ys = x ': (xs <> ys) + +appPrf :: Printf ts -> Printf ps -> Printf (ts <> ps) +appPrf EOS ps = ps +appPrf (str :<> ts) ps = str :<> appPrf ts ps +appPrf (fm :% ts) ps = fm :% appPrf ts ps + +appNil :: Printf ts -> (ts <> '[]) :~: ts +appNil EOS = Refl +appNil (_ :<> a) = appNil a +appNil (_ :% bs) = case appNil bs of Refl -> Refl + + +-- | Append plain string to format. +(><) :: Printf ts -> String -> Printf ts +xs >< str = gcastWith (appNil xs) $ appPrf xs (str :<> EOS) + +-- | Append formatter to format. +(%) :: Printf ts -> (a -> String) -> Printf (ts <> '[a]) +(%) xs p = appPrf xs (p :% EOS) + +-- | Concatenate two prtinf formats. +(+++) :: Printf ts -> Printf ps -> Printf (ts <> ps) +(+++) = appPrf +infixr 5 +++ + +infixl 5 ><, % + +-- | Format @String@ as it is. +s :: Formatter String +s = id + +-- | Formatter for @Show@ instances. +_S :: Show a => Formatter a +_S = show + +-- | Converts @'ShowS'@ function to @'Formatter'@. +_shows :: (a -> ShowS) -> Formatter a +_shows fmt = flip fmt "" + +-- | Format @Integral@s at base. +base :: (Show a, Integral a) + => a -- ^ Base + -> Maybe (Char, Int) -- ^ Padding settings. + -> Formatter a +base adic mpd a = + let ans = showIntAtBase adic intToDigit a "" + in maybe "" (\(c,dig) -> replicate (dig - length ans) c) mpd ++ ans + +-- | Decimal formatter with padding. +d' :: (Show a, Integral a) => Char -> Int -> Formatter a +d' c i = base 10 (Just (c,i)) + +-- | No padding version of @'d''@. +d :: (Show a, Integral a) => Formatter a +d = base 10 Nothing + +-- | Octal formatter with padding. +o' :: (Show a, Integral a) => Char -> Int -> Formatter a +o' c i = base 8 (Just (c,i)) + +-- | No padding version of @'o''@. +o :: (Show a, Integral a) => Formatter a +o = base 8 Nothing + +-- | Binary formatter with padding. +b' :: (Show a, Integral a) => Char -> Int -> Formatter a +b' c i = base 2 (Just (c,i)) + +-- | No padding version of @'b''@. +b :: (Show a, Integral a) => Formatter a +b = base 2 Nothing + +-- | Binary formatter with padding. +h' :: (Show a, Integral a) => Char -> Int -> Formatter a +h' c i = base 16 (Just (c,i)) + +-- | No padding version of @'b''@. +h :: (Show a, Integral a) => Formatter a +h = base 16 Nothing + +-- | @RealFloat@ formatter. +f :: RealFloat a => Formatter a +f = _shows showFloat diff --git a/src/Text/Printf/Safe/Core.hs b/src/Text/Printf/Safe/Core.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/Safe/Core.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds, GADTs, TypeFamilies, TypeOperators #-} +module Text.Printf.Safe.Core (type (~>), Formatter, Printf(..), + HList(..), printf, printf') where +import Data.String (IsString (..)) + +-- | Variadic function types. +type family (~>) as b where + (~>) '[] a = a + (~>) (x ': xs) a = x -> xs ~> a + +-- | Formatter type. +type Formatter a = a -> String + +-- | Printf Format. +data Printf xs where + EOS :: Printf '[] + (:<>) :: String -> Printf xs -> Printf xs + (:%) :: Formatter x -> Printf xs -> Printf (x ': xs) + +instance (xs ~ '[]) => IsString (Printf xs) where + fromString str = str :<> EOS + +-- | Hetero list. +data HList ts where + HNil :: HList '[] + (:-) :: a -> HList xs -> HList (a ': xs) + +infixr 9 :-, :<>, :% + +-- | HList version. +printf' :: Printf ts -> HList ts -> String +printf' ps0 ts0 = go ps0 ts0 "" + where + go :: Printf us -> HList us -> ShowS + go EOS HNil = id + go (str :<> fs) xs = showString str . go fs xs + go (fm :% fs) (x :- ds) = showString (fm x) . go fs ds + go _ _ = error "bug in GHC!" + +-- | Variadic version. +printf :: Printf xs -> xs ~> String +printf p = go p "" + where + go :: Printf xs -> String -> xs ~> String + go EOS a = a + go (str :<> xs) a = go xs (a ++ str) + go (fmt :% xs) a = \x -> go xs (a ++ fmt x) + diff --git a/src/Text/Printf/Safe/QQ.hs b/src/Text/Printf/Safe/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/Safe/QQ.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RecordWildCards, TemplateHaskell #-} +module Text.Printf.Safe.QQ (fmt) where +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Text.Printf.Safe.Core (printf) +import Text.Printf.Safe.QQ.Internal (parse) + +-- | Quasiquoter for formatter. +-- It supprots escape sequence. +-- Formatter is prefixed by @%@ and you can use @%{hoge}@ to antiquotation. +-- +-- >>> :set -XQuasiQuotes +-- >>> printf [fmt|Answer is: %d and %S|] 42 True +-- "Answer is: 42 and True" +-- +-- >>> printf [fmt|%02d%% of people answers %{show . not}.\n|] 4 False +-- "04% of people answers True.\n" +-- +-- Predefined formatters: +-- +-- [@%%@] outputs @%@. +-- [@%d@] formats @'Integral'@ value in decimal. +-- [@%/n/d@] same as above, but padding with @' '@ (space) to /n/ digits. +-- [@%0/n/d@] same as above, but padding with @'0'@ to /n/ digits. +-- [@%b@, @%o@, @%h@, @%H@] formats @'Integral'@s in binary, octet, hex and HEX resp. +-- Padding options can be specified as @%d@. +-- [@%f@] formats @'Real'@ value with @'show'@ function. +-- [@%s@] embeds @'String'@ value. +-- [@%S@] embeds @'Show'@ instances. +-- [@%{/expr/}@, where @/expr/@ is a Haskell expression of type @a -> String@] +-- Antiquote. This formats corresponding argument by passing to @/expr/@. + +fmt :: QuasiQuoter +fmt = QuasiQuoter { quoteDec = error "not implemented" + , quoteType = error "not implemented" + , quotePat = error "not implemented" + , quoteExp = parse + } diff --git a/src/Text/Printf/Safe/QQ/Internal.hs b/src/Text/Printf/Safe/QQ/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/Safe/QQ/Internal.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE RecordWildCards, TemplateHaskell #-} +module Text.Printf.Safe.QQ.Internal where +import Control.Applicative ((<$>)) +import Data.Char (intToDigit, isDigit, isUpper, toUpper) +import Data.Char (chr) +import Data.Maybe (fromMaybe) +import Language.Haskell.Meta (parseExp) +import Language.Haskell.TH (ExpQ) +import Language.Haskell.TH.Lift (lift) +import Numeric (showIntAtBase) +import Numeric (readDec, readHex, readOct) +import Text.Printf.Safe.Core (Printf (..)) + +data Fragment = StrF String + | ResF FormatterConf + | AntiF String + deriving (Read, Show, Eq, Ord) + +data FormatterConf = Float + | Integral { base :: Integer, padding :: Maybe Char, digits :: Maybe Int, capital :: Bool} + | String + | Show + deriving (Read, Show, Eq, Ord) + +parse :: String -> ExpQ +parse = foldr cat [|EOS|] . parse' + where + cat (StrF s) r = [| $(lift s) :<> $r |] + cat (ResF Float) r = [| (show :: Real a => a -> String) :% $r |] + cat (ResF String) r = [| (id :: String -> String) :% $r |] + cat (ResF Show) r = [| (show :: Show a => a -> String) :% $r |] + cat (ResF Integral{..}) r = do + let pad = lift $ fromMaybe ' ' padding + wid = lift digits + [| ((\str -> replicate (maybe 0 (subtract (length str)) $wid) $pad ++ str) . flip $([| showIntAtBase $(lift base) ($(if capital then [|toUpper|] else [|id|]) . intToDigit) |]) "") :% $r |] + cat (AntiF code) r = [| $(return $ either error id $ parseExp code) :% $r |] + +parse' :: String -> [Fragment] +parse' = either error (foldr cat []) . parse'' + where + cat (StrF "") xs = xs + cat x [] = [x] + cat (StrF x) (StrF y : xs) = cat (StrF (x ++ y)) xs + cat x xs = x : xs + +parse'' :: String -> Either String[Fragment] +parse'' str = case break (`elem`"%\\") str of + ("", "") -> return [] + (as, "") -> return [StrF as] + (as, '\\':bs) -> case parseEscape bs of + Just (ch, rest) -> (StrF (as ++ ch) : ) <$> parse'' rest + Nothing -> Left $ "illeagual escape sequence: \\" ++ (take 1 bs) + (as, '%':'%':bs) -> (StrF as :) . (StrF "%" :) <$> parse'' bs + (as, '%':rest) -> + let (pc, bs) = parseFormat rest + in (StrF as :) . (pc:) <$> parse'' bs + (as, bs) -> (StrF as :) <$> parse'' bs + +parseEscape :: String -> Maybe (String, String) +parseEscape ('a':rest) = Just ("\a", rest) +parseEscape ('b':rest) = Just ("\b", rest) +parseEscape ('f':rest) = Just ("\f", rest) +parseEscape ('n':rest) = Just ("\n", rest) +parseEscape ('r':rest) = Just ("\r", rest) +parseEscape ('t':rest) = Just ("\t", rest) +parseEscape ('v':rest) = Just ("\v", rest) +parseEscape ('\\':rest) = Just ("\\", rest) +parseEscape (']':rest) = Just ("]", rest) +parseEscape ('&':rest) = Just ("", rest) +parseEscape ('"':rest) = Just ("\"", rest) +parseEscape ('\'':rest) = Just ("\'", rest) +parseEscape ('N':'U':'L':rest) = Just ("\NUL", rest) +parseEscape ('S':'O':'H':rest) = Just ("\SOH", rest) +parseEscape ('S':'T':'X':rest) = Just ("\STX", rest) +parseEscape ('E':'T':'X':rest) = Just ("\ETX", rest) +parseEscape ('E':'O':'T':rest) = Just ("\EOT", rest) +parseEscape ('E':'N':'Q':rest) = Just ("\ENQ", rest) +parseEscape ('A':'C':'K':rest) = Just ("\ACK", rest) +parseEscape ('B':'E':'L':rest) = Just ("\BEL", rest) +parseEscape ('B':'S':rest) = Just ("\BS", rest) +parseEscape ('H':'T':rest) = Just ("\HT", rest) +parseEscape ('L':'F':rest) = Just ("\LF", rest) +parseEscape ('V':'T':rest) = Just ("\VT", rest) +parseEscape ('F':'F':rest) = Just ("\FF", rest) +parseEscape ('C':'R':rest) = Just ("\CR", rest) +parseEscape ('S':'O':rest) = Just ("\SO", rest) +parseEscape ('S':'I':rest) = Just ("\SI", rest) +parseEscape ('D':'L':'E':rest) = Just ("\DLE", rest) +parseEscape ('D':'C':'1':rest) = Just ("\DC1", rest) +parseEscape ('D':'C':'2':rest) = Just ("\DC2", rest) +parseEscape ('D':'C':'3':rest) = Just ("\DC3", rest) +parseEscape ('D':'C':'4':rest) = Just ("\DC4", rest) +parseEscape ('N':'A':'K':rest) = Just ("\NAK", rest) +parseEscape ('S':'Y':'N':rest) = Just ("\SYN", rest) +parseEscape ('E':'T':'B':rest) = Just ("\ETB", rest) +parseEscape ('C':'A':'N':rest) = Just ("\CAN", rest) +parseEscape ('E':'M':rest) = Just ("\EM", rest) +parseEscape ('S':'U':'B':rest) = Just ("\SUB", rest) +parseEscape ('E':'S':'C':rest) = Just ("\ESC", rest) +parseEscape ('F':'S':rest) = Just ("\FS", rest) +parseEscape ('G':'S':rest) = Just ("\GS", rest) +parseEscape ('R':'S':rest) = Just ("\RS", rest) +parseEscape ('U':'S':rest) = Just ("\US", rest) +parseEscape ('S':'P':rest) = Just ("\SP", rest) +parseEscape ('D':'E':'L':rest) = Just ("\DEL", rest) +parseEscape ('^':c:rest) + | c `elem` ['A'..'Z'] ++ "@[]\\^_" = + Just ([read ("'\\^" ++ c : "'")], rest) +parseEscape ('x':bs) + | (ds, rest) : _ <- readHex bs = Just ([chr ds], rest) +parseEscape ('o':bs) + | (ds, rest) : _ <- readOct bs = Just ([chr ds], rest) +parseEscape bs + | (ds, rest) : _ <- readDec bs = Just ([chr ds], rest) +parseEscape _ = Nothing + +parseFormat :: String -> (Fragment, String) +parseFormat "" = (StrF "%", "") +parseFormat ('{':r) = go (1 :: Int) "" r + where + go 0 c k = (AntiF (init c), k) + go p c ('{':k) = go (p+1) (c ++ "{") k + go p c ('}':k) = go (p-1) (c ++ "}") k + go p c (u:k) = go p (c ++ [u]) k + go _ _ [] = (StrF "{", r) +parseFormat str = + case span isDigit str of + ("", 's':rest) -> (ResF String, rest) + ("", 'S':rest) -> (ResF Show, rest) + ("", 'f':rest) -> (ResF Float, rest) + ("", r:rest) | Just base <- getBase r -> + (ResF (Integral base Nothing Nothing (isUpper r)), rest) + ('0':ds, r:rest) | Just base <- getBase r -> + (ResF (Integral base (Just '0') (Just $ read ds) (isUpper r)), rest) + (ds, r:rest) | Just base <- getBase r -> + (ResF (Integral base (Just ' ') (Just $ read ds) (isUpper r)), rest) + _ -> (StrF "%", str) + +getBase :: Char -> Maybe Integer +getBase 'd' = Just 10 +getBase 'b' = Just 2 +getBase 'o' = Just 8 +getBase 'h' = Just 16 +getBase 'H' = Just 16 +getBase _ = Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "src/Text/Printf/Safe/QQ.hs"]