diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2014, Soostone Inc + +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 Ozgun Ataman 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/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/formattable.cabal b/formattable.cabal new file mode 100644 --- /dev/null +++ b/formattable.cabal @@ -0,0 +1,65 @@ +Name: formattable +Version: 0.1 +Synopsis: Business-quality formatting of numbers, dates, and other things +Description: This package defines data structures for describing + business-quality formatting for numbers, dates, etc in a + way that can be serialized and transported. Comes with + excellent built-in support for formatting numbers. It + also provides a generic interface for formatting other + types as well. +License: BSD3 +License-file: LICENSE +Author: Ozgun Ataman, Doug Beardsley +Maintainer: oz@soostone.com +Homepage: https://github.com/Soostone/formattable +Bug-reports: https://github.com/Soostone/formattable/issues +Category: Text +Build-type: Simple +Cabal-version: >= 1.10 + + +Library + Exposed-modules: + Formattable + Formattable.NumFormat + + hs-source-dirs: src + Build-depends: + base >= 4 && < 5 + , bytestring >= 0.9 && < 0.11 + , data-default-class < 0.1 + , double-conversion >= 0.2 && < 2.1 + , lens >= 4 && < 4.13 + , old-locale >= 1.0 && < 1.1 + , text >= 0.11 && < 1.3 + , time >= 1.4 && < 1.6 + + ghc-options: -Wall -fwarn-tabs + default-language: Haskell2010 + + +Test-Suite testsuite + type: exitcode-stdio-1.0 + hs-Source-Dirs: src test + ghc-Options: -Wall -fhpc -threaded -fbreak-on-exception + main-Is: Spec.hs + + other-modules: + Formattable + Formattable.NumFormat + + build-depends: + HUnit >= 1.2 && < 1.3 + , base + , bytestring + , data-default-class + , double-conversion + , hspec >= 1.10 && < 2.2 + , lens + , old-locale + , text + , time + +source-repository head + type: git + location: https://github.com/Soostone/formattable.git diff --git a/src/Formattable.hs b/src/Formattable.hs new file mode 100644 --- /dev/null +++ b/src/Formattable.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Formattable +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : libs@soostone.com +-- Stability : experimental +-- +-- Practical formatting interface for output values intended for human +-- consumption. We try to support several variants often required by +-- real-world applications. +---------------------------------------------------------------------------- + +module Formattable + ( module Formattable + , module Formattable.NumFormat + ) where + +------------------------------------------------------------------------------- +import Data.Int +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word +#if MIN_VERSION_time(1,5,0) +import Data.Time +#else +import Data.Time +import System.Locale (TimeLocale, defaultTimeLocale) +#endif +------------------------------------------------------------------------------- +import Formattable.NumFormat +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------ +-- | Provides a uniform interface for formatting all kinds of types. +class Format a where + + -- | A format settings type specific to the object type. + type TheFormat a + + -- | Render into text using format settings + runFormat :: TheFormat a -> a -> Text + + +instance Format Integer where + type TheFormat Integer = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Int where + type TheFormat Int = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Int8 where + type TheFormat Int8 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Int16 where + type TheFormat Int16 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Int32 where + type TheFormat Int32 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Int64 where + type TheFormat Int64 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Word where + type TheFormat Word = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Word8 where + type TheFormat Word8 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Word16 where + type TheFormat Word16 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Word32 where + type TheFormat Word32 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Word64 where + type TheFormat Word64 = NumFormat + runFormat set a = formatIntegral set a + + +instance Format Double where + type TheFormat Double = NumFormat + runFormat set a = formatNum set a + + +instance Format Float where + type TheFormat Float = NumFormat + runFormat set a = formatNum set a + + +instance Format Day where + type TheFormat Day = String + runFormat set a = T.pack $ formatTime defaultTimeLocale set a + + +instance Format UTCTime where + type TheFormat UTCTime = String + runFormat set a = T.pack $ formatTime defaultTimeLocale set a + + +instance Format Text where + type TheFormat Text = () + runFormat _ a = a + + +instance Format Bool where + type TheFormat Bool = () + runFormat _ a = T.pack (show a) diff --git a/src/Formattable/NumFormat.hs b/src/Formattable/NumFormat.hs new file mode 100644 --- /dev/null +++ b/src/Formattable/NumFormat.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Formattable.NumFormat +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : libs@soostone.com +-- Stability : experimental +-- +-- Formatting for numeric values. +---------------------------------------------------------------------------- + +module Formattable.NumFormat + ( NumFormat(..) + , NumStyle(..) + , autoStyle + , PrecisionType(..) + , NegativeStyle(..) + + -- * Lenses + , nfUnits + , nfPrefix + , nfSuffix + , nfThouSep + , nfDecSep + , nfStyle + , nfPrec + , nfNegStyle + + -- * Common formats + , rawIntFmt + , intFmt + , percentFmt + , numFmt + , usdFmt + + -- * Formatting functions + , formatPct + , formatNum + , formatIntegral + ) where + + +------------------------------------------------------------------------------- +import Control.Lens +import Data.Char +import Data.Default.Class +import Data.Double.Conversion.Text +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | Data structure describing available styles of number formatting. +data NumStyle + = Exponent + -- ^ Format with scientific notation + | Fixed + -- ^ Format with standard decimal notation + | SmartExponent Int Int + -- ^ The aruments a and b define bounds. If the absolute value of the + -- number is in the interval [10 ^ a, 10 ^ b], then it uses the Fixed + -- style. If the number is outside this interval, then use the Exponent + -- style. + | SIStyle + -- ^ Adds the symbol for the closest smaller SI prefix as the suffix to + -- the formatted number. This suffix appears before any other suffix + -- you designate. + | SmartSI Double Double + -- ^ Like SIStyle but only applies the SI prefix if the number to be + -- formatted falls within the range [a,b] given by the SmartSI + -- arguments. + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- | A reasonable default value for NumStyle. +autoStyle :: NumStyle +autoStyle = SmartExponent (-2) 10 + + +------------------------------------------------------------------------------ +-- | Data structure for different methods of specifying precision. +data PrecisionType + = SigFigs + -- ^ Specifies precision as a fixed number of significant digits + | Decimals + -- ^ Specifies precision with a fixed number of digits after the decimal + -- place. + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- | Different styles for representing negative numbers. +data NegativeStyle + = NegMinusSign + -- ^ Shows negative numbers as -123.000 + | NegParens + -- ^ Shows negative numbers as (123.000) + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- The main data structure with all the necessary information for formatting +-- numbers. +data NumFormat = NumFormat + { _nfUnits :: Double + -- ^ Units of measure to use in formatting the number. This is useful + -- for things like percentages where you would use (units of 0.01) or + -- financial statements (units of 1000 for example). + , _nfPrefix :: Text + -- ^ A prefix to add to the number, commonly used for currency + -- designation. + , _nfSuffix :: Text + -- ^ A suffix for the number. Percent, for example. + , _nfThouSep :: Text + -- ^ The character to use as thousands separator if applicable. + , _nfDecSep :: Text + -- ^ Character to use for the decimal separator. + , _nfStyle :: NumStyle + -- ^ The formatting style + , _nfPrec :: Maybe (Int, PrecisionType) + -- ^ Amount of precision to display + , _nfNegStyle :: NegativeStyle + -- ^ Styles for negative numbers + } deriving (Eq,Show,Typeable) +makeLenses ''NumFormat + + +------------------------------------------------------------------------------ +instance Default NumFormat where + def = NumFormat 1 "" "" "" "." autoStyle + (Just $ (3, Decimals)) NegMinusSign + + +------------------------------------------------------------------------------ +-- | A type wrapper to make it easier to handle the pipeline of +-- transformations that happen after we have split the number at the decimal +-- place. +data RawNum a = RawNum a Text Text Text +-- { rawNumX :: a +-- -- ^ The original number so we can check for zero +-- , rawNumN :: Text +-- -- ^ Integral part (left of the decimal place) +-- , rawNumD :: Text +-- -- ^ Decimal part (right of the decimal place) +-- , rawNumE :: Text +-- -- ^ Exponent part if there is one +-- } + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- | Take the raw output from the double-precision conversion functions and +-- split into individual components. +-- +-- We need to split on dot because that's what double-conversion uses as the +-- decimal separator. +mkRawNum :: Real a => a -> Text -> RawNum a +mkRawNum x t = + case (T.findIndex (== '.') t, T.findIndex (== 'e') t) of + (Nothing, Nothing) -> mk t "" "" + (Just i, Nothing) -> let (n,d) = T.splitAt i t + in mk n (T.drop 1 d) "" + (Nothing, Just i) -> let (n,e) = T.splitAt i t + in mk n "" (T.drop 1 e) + (Just i, Just j) -> let (n,rest) = T.splitAt i t + (d,e) = T.splitAt (j-i-1) (T.drop 1 rest) + in mk n d (T.drop 1 e) + where + mk = RawNum x + + +------------------------------------------------------------------------------- +-- | Int format with no thousands separator. +rawIntFmt :: NumFormat +rawIntFmt = def & nfPrec .~ Just (0, Decimals) + + +------------------------------------------------------------------------------- +-- | Int format with comma as the thousands separator. +intFmt :: NumFormat +intFmt = def & nfPrec .~ Just (0, Decimals) + & nfThouSep .~ "," + + +------------------------------------------------------------------------------ +-- | Common format for percentages. Example: 75.000% +percentFmt :: NumFormat +percentFmt = def & nfSuffix .~ "%" + & nfUnits .~ 0.01 + + +------------------------------------------------------------------------------ +-- | Common format for generic numeric quantities of the form 123,456.99. +numFmt :: NumFormat +numFmt = def & nfThouSep .~ "," + & nfPrec .~ Just (2, Decimals) + + +------------------------------------------------------------------------------ +-- | Common format for US dollar quantities of the form $123,456.99. +usdFmt :: NumFormat +usdFmt = def & nfPrefix .~ "$" + & nfThouSep .~ "," + & nfPrec .~ Just (2, Decimals) + & nfStyle .~ Fixed + + +------------------------------------------------------------------------------- +-- | Convenience wrapper for percentages that lets you easily control the +-- number of decimal places. +formatPct :: Real a => Int -> a -> Text +formatPct p = formatNum (percentFmt & nfPrec .~ Just (p, Decimals)) + + +------------------------------------------------------------------------------- +-- | This function checks to see if the number is smaller than the number of +-- digits of precision being displayed and if so, switches to scientific +-- notation. +formatIntegral :: Integral a => NumFormat -> a -> Text +formatIntegral NumFormat{..} noUnits = + whenNegative noUnits (addSign _nfNegStyle) $ + addPrefix $ + addSuffix $ + addDecimal _nfDecSep $ + addThousands _nfThouSep $ + maybe id limitPrecision _nfPrec $ + formatted siUnitized + where + a = abs $ noUnits `div` round _nfUnits + formatted = case _nfStyle of + Exponent -> exponentialInt precArg + Fixed -> fixedInt precArg + SmartExponent lo hi -> smartStyleIntegral lo hi + (fixedInt precArg) + (exponentialInt precArg) + SIStyle -> fixedInt precArg + SmartSI _ _ -> fixedInt precArg + addPrefix x = _nfPrefix <> x + addSuffix x1 = let x2 = x1 <> siSuffix in x2 <> _nfSuffix + precArg = maybe (-1) fst _nfPrec + (e, siSuffix) = case _nfStyle of + SIStyle -> siPrefixIntegral a + SmartSI lo hi -> if fromIntegral a > lo && fromIntegral a < hi then siPrefixIntegral a else (0, "") + _ -> (0, "") + siUnitized = a `div` 10^e + + +-- The following two functions skip the double-conversion library and let us +-- go straight to RawNum when we're working with Integrals. This avoids a C +-- dependency and hopefully should also be faster. + + +fixedInt :: Integral a => Int -> a -> RawNum a +fixedInt (-1) n = + RawNum n (T.pack $ showIntegralBase 10 n) "" "" +fixedInt decimals n = + RawNum n (T.pack $ showIntegralBase 10 n) (T.replicate decimals "0") "" + + +exponentialInt :: Integral a => Int -> a -> RawNum a +exponentialInt (-1) n = RawNum n (T.pack a) (T.pack b) (T.pack $ show (len-1)) + where + str = showIntegralBase 10 n + len = length str + (a,b) = splitAt 1 str +exponentialInt numDecimals n = + RawNum n (T.pack a) (T.pack b) (T.pack $ show e) + where + str = showIntegralBase 10 n + len = length str + (keep,junk) = splitAt (numDecimals+1) (str ++ repeat '0') + rounded = if head junk >= '5' + then reverse $ roundStr $ reverse keep + else keep + e = if length rounded > length keep then len else len-1 + (a,b) = splitAt 1 rounded + + roundStr [] = "1" + roundStr (x:xs) = if x == '9' then '0' : roundStr xs else succ x : xs + + +------------------------------------------------------------------------------- +-- | This function checks to see if the number is smaller than the number of +-- digits of precision being displayed and if so, switches to scientific +-- notation. +formatNum :: Real a => NumFormat -> a -> Text +formatNum NumFormat{..} noUnits = + whenNegative noUnits (addSign _nfNegStyle) $ + addPrefix $ + addSuffix $ + addDecimal _nfDecSep $ + addThousands _nfThouSep $ + maybe id limitPrecision _nfPrec $ + mkRawNum noUnits $ + formatted siUnitized + + where + a = abs $ realToFrac noUnits / _nfUnits + formatted = case _nfStyle of + Exponent -> toExponential precArg + Fixed -> toFixed precArg + SmartExponent lo hi -> smartStyle lo hi (toFixed precArg) (toExponential precArg) + SIStyle -> toFixed precArg + SmartSI _ _ -> toFixed precArg + addPrefix x = _nfPrefix <> x + addSuffix x1 = let x2 = x1 <> siSuffix in x2 <> _nfSuffix + precArg = maybe (-1) fst _nfPrec + (e, siSuffix) = case _nfStyle of + SIStyle -> siPrefix a + SmartSI lo hi -> if a > lo && a < hi then siPrefix a else (0, "") + _ -> (0, "") + siUnitized = a / 10**(fromIntegral e) + + +siPrefixIntegral :: Integral a => a -> (Int, Text) +siPrefixIntegral x + | abs x > 10^(24::Int) = (24, "Y") + | abs x > 10^(21::Int) = (21, "Z") + | abs x > 10^(18::Int) = (18, "E") + | abs x > 10^(15::Int) = (15, "P") + | abs x > 10^(12::Int) = (12, "T") + | abs x > 10^(9::Int) = (9, "G") + | abs x > 10^(6::Int) = (6, "M") + | abs x > 10^(3::Int) = (3, "k") + | otherwise = (0, "") + + +siPrefix :: Double -> (Int, Text) +siPrefix x + | abs x > 1e24 = (24, "Y") + | abs x > 1e21 = (21, "Z") + | abs x > 1e18 = (18, "E") + | abs x > 1e15 = (15, "P") + | abs x > 1e12 = (12, "T") + | abs x > 1e9 = (9, "G") + | abs x > 1e6 = (6, "M") + | abs x > 1e3 = (3, "k") + | abs x > 1 = (0, "") + | abs x > (1.0 / 1e3) = (-3, "m") + | abs x > (1.0 / 1e6) = (-6, "μ") + | abs x > (1.0 / 1e9) = (-9, "n") + | abs x > (1.0 / 1e12) = (-12, "p") + | abs x > (1.0 / 1e15) = (-15, "f") + | abs x > (1.0 / 1e18) = (-18, "a") + | abs x > (1.0 / 1e21) = (-21, "z") + | otherwise = (-24, "y") + + +------------------------------------------------------------------------------ +-- | A "pre-format" function that intelligently chooses between fixed and +-- exponential format +smartStyleIntegral + :: (Num a, Ord a) + => Int + -- ^ Lower bound exponent + -> Int + -- ^ Upper bound exponent + -> (a -> b) + -- ^ Function to call if within range + -> (a -> b) + -- ^ Function to call if out of range + -> a + -> b +smartStyleIntegral l h f g x = + if lo < x' && x' < hi + then f x + else g x + where + x' = abs x + lo = 10 ^ (max l 0) + hi = 10 ^ (max h 0) + + +------------------------------------------------------------------------------ +-- | A "pre-format" function that intelligently chooses between fixed and +-- exponential format +smartStyle + :: (Floating a, Ord a) + => Int + -- ^ Lower bound exponent + -> Int + -- ^ Upper bound exponent + -> (a -> b) + -- ^ Function to call if within range + -> (a -> b) + -- ^ Function to call if out of range + -> a + -> b +smartStyle l h f g x = + if lo < x' && x' < hi + then f x + else g x + where + x' = abs x + lo = 10 ** fromIntegral l + hi = 10 ** fromIntegral h + + +------------------------------------------------------------------------------ +limitPrecision :: (Int, PrecisionType) -> RawNum a -> RawNum a +limitPrecision (c,p) r@(RawNum x n d e) = + case p of + SigFigs -> + if c < T.length n + then RawNum x (T.take c n <> T.replicate (T.length n - c) "0") "" e + else RawNum x n (T.take (c - T.length n) d) e + Decimals -> if c == (-1) then r else RawNum x n (T.take c d) e + + +------------------------------------------------------------------------------ +whenNegative :: (Num n, Ord n) => n -> (a -> a) -> a -> a +whenNegative n f = if n < 0 then f else id + + +------------------------------------------------------------------------------ +addSign :: NegativeStyle -> Text -> Text +addSign NegMinusSign t = T.cons '-' t +addSign NegParens t = T.concat ["(", t, ")"] + + +------------------------------------------------------------------------------- +addThousands :: Text -> RawNum a -> RawNum a +addThousands "" raw = raw +addThousands sep (RawNum x n d e) = RawNum x n' d e + where + n' = T.reverse . T.intercalate sep . T.chunksOf 3 . T.reverse $ n + + +------------------------------------------------------------------------------ +addDecimal :: (Eq a, Num a) => Text -> RawNum a -> Text +addDecimal t (RawNum x n d e) = T.concat [n, d', e'] + where + d' = if T.null d then "" else T.append t d + e' = if T.null e || x == 0 then "" else T.cons 'e' e + + +------------------------------------------------------------------------------ +-- | An integral show function without the Show constraint. It works for +-- bases in the range [0,36]. +showIntegralBase + :: Integral a + => a + -- ^ The base + -> a + -- ^ The number to convert to string + -> String +showIntegralBase b n + -- It's ok to negate b because we only support bases in the range [0,36] + | n < b && n > negate b = go n "" + -- We unroll the go loop once because you can't negate minBound + | otherwise = + let (q,r) = n `quotRem` b in go q (go (abs r) "") + where + go m str + | m < 0 = '-' : go (-m) str + | m < b = integralDigit m : str + | otherwise = let (q,r) = m `quotRem` b + in go q (integralDigit r : str) + + +------------------------------------------------------------------------------ +integralDigit :: Integral a => a -> Char +integralDigit n + | n < 10 = chr $ ord '0' + fromIntegral n + | n < 36 = chr $ ord 'a' + fromIntegral n - 10 + | otherwise = error "integralDigit: not a digit" + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +module Spec where + test = 1