diff --git a/formattable.cabal b/formattable.cabal --- a/formattable.cabal +++ b/formattable.cabal @@ -1,5 +1,5 @@ Name: formattable -Version: 0.1 +Version: 0.1.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 @@ -28,8 +28,6 @@ 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 @@ -50,12 +48,13 @@ build-depends: HUnit >= 1.2 && < 1.3 + , QuickCheck >= 2.0 && < 2.9 , base , bytestring , data-default-class - , double-conversion + , double-conversion >= 0.2 && < 2.1 , hspec >= 1.10 && < 2.2 - , lens + , lens >= 4 && < 4.13 , old-locale , text , time diff --git a/src/Formattable.hs b/src/Formattable.hs --- a/src/Formattable.hs +++ b/src/Formattable.hs @@ -50,86 +50,120 @@ runFormat :: TheFormat a -> a -> Text +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Integer where type TheFormat Integer = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Int where type TheFormat Int = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Int8 where type TheFormat Int8 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Int16 where type TheFormat Int16 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Int32 where type TheFormat Int32 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Int64 where type TheFormat Int64 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Word where type TheFormat Word = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Word8 where type TheFormat Word8 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Word16 where type TheFormat Word16 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Word32 where type TheFormat Word32 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Word64 where type TheFormat Word64 = NumFormat runFormat set a = formatIntegral set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Double where type TheFormat Double = NumFormat runFormat set a = formatNum set a +------------------------------------------------------------------------------ +-- | TheFormat = NumFormat instance Format Float where type TheFormat Float = NumFormat runFormat set a = formatNum set a +------------------------------------------------------------------------------ +-- | TheFormat = String instance Format Day where type TheFormat Day = String runFormat set a = T.pack $ formatTime defaultTimeLocale set a +------------------------------------------------------------------------------ +-- | TheFormat = String instance Format UTCTime where type TheFormat UTCTime = String runFormat set a = T.pack $ formatTime defaultTimeLocale set a +------------------------------------------------------------------------------ +-- | TheFormat = () instance Format Text where type TheFormat Text = () runFormat _ a = a +------------------------------------------------------------------------------ +-- | TheFormat = () 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 --- a/src/Formattable/NumFormat.hs +++ b/src/Formattable/NumFormat.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -17,12 +18,24 @@ ---------------------------------------------------------------------------- module Formattable.NumFormat - ( NumFormat(..) + ( + -- * Main number formatting functions and data types + formatNum + , formatIntegral + , formatPct + , NumFormat(..) , NumStyle(..) , autoStyle , PrecisionType(..) , NegativeStyle(..) + -- * Common formats + , rawIntFmt + , intFmt + , percentFmt + , numFmt + , usdFmt + -- * Lenses , nfUnits , nfPrefix @@ -33,32 +46,30 @@ , nfPrec , nfNegStyle - -- * Common formats - , rawIntFmt - , intFmt - , percentFmt - , numFmt - , usdFmt - - -- * Formatting functions - , formatPct - , formatNum - , formatIntegral + -- * Other formatting functions + , formatNumGeneric ) where ------------------------------------------------------------------------------- -import Control.Lens +import Control.Applicative import Data.Char import Data.Default.Class -import Data.Double.Conversion.Text +import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Typeable +import Numeric ------------------------------------------------------------------------------- +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens sa sbt afb s = sbt s <$> afb (sa s) + + + ------------------------------------------------------------------------------- -- | Data structure describing available styles of number formatting. data NumStyle @@ -110,7 +121,7 @@ ------------------------------------------------------------------------------ --- The main data structure with all the necessary information for formatting +-- | The main data structure with all the necessary information for formatting -- numbers. data NumFormat = NumFormat { _nfUnits :: Double @@ -133,9 +144,48 @@ , _nfNegStyle :: NegativeStyle -- ^ Styles for negative numbers } deriving (Eq,Show,Typeable) -makeLenses ''NumFormat +nfUnits :: Lens NumFormat NumFormat Double Double +nfUnits = lens _nfUnits setter + where + setter sc v = sc { _nfUnits = v } +nfPrefix :: Lens NumFormat NumFormat Text Text +nfPrefix = lens _nfPrefix setter + where + setter sc v = sc { _nfPrefix = v } + +nfSuffix :: Lens NumFormat NumFormat Text Text +nfSuffix = lens _nfSuffix setter + where + setter sc v = sc { _nfSuffix = v } + +nfThouSep :: Lens NumFormat NumFormat Text Text +nfThouSep = lens _nfThouSep setter + where + setter sc v = sc { _nfThouSep = v } + +nfDecSep :: Lens NumFormat NumFormat Text Text +nfDecSep = lens _nfDecSep setter + where + setter sc v = sc { _nfDecSep = v } + +nfStyle :: Lens NumFormat NumFormat NumStyle NumStyle +nfStyle = lens _nfStyle setter + where + setter sc v = sc { _nfStyle = v } + +nfPrec :: Lens NumFormat NumFormat (Maybe (Int, PrecisionType)) (Maybe (Int, PrecisionType)) +nfPrec = lens _nfPrec setter + where + setter sc v = sc { _nfPrec = v } + +nfNegStyle :: Lens NumFormat NumFormat NegativeStyle NegativeStyle +nfNegStyle = lens _nfNegStyle setter + where + setter sc v = sc { _nfNegStyle = v } + + ------------------------------------------------------------------------------ instance Default NumFormat where def = NumFormat 1 "" "" "" "." autoStyle @@ -183,50 +233,56 @@ ------------------------------------------------------------------------------- -- | Int format with no thousands separator. rawIntFmt :: NumFormat -rawIntFmt = def & nfPrec .~ Just (0, Decimals) +rawIntFmt = def { _nfPrec = Just (0, Decimals) } ------------------------------------------------------------------------------- -- | Int format with comma as the thousands separator. intFmt :: NumFormat -intFmt = def & nfPrec .~ Just (0, Decimals) - & nfThouSep .~ "," +intFmt = def { _nfPrec = Just (0, Decimals) + , _nfThouSep = "," + } ------------------------------------------------------------------------------ -- | Common format for percentages. Example: 75.000% percentFmt :: NumFormat -percentFmt = def & nfSuffix .~ "%" - & nfUnits .~ 0.01 +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) +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 +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)) +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. +-- | Primary function for formatting integrals. This was originally created to +-- avoid depending on the double-conversion package which uses a C library and +-- is therefore less portable. We're keeping this as a separate function +-- because it should have the potential to be more efficient than the floating +-- point version. formatIntegral :: Integral a => NumFormat -> a -> Text formatIntegral NumFormat{..} noUnits = whenNegative noUnits (addSign _nfNegStyle) $ @@ -291,36 +347,62 @@ ------------------------------------------------------------------------------- --- | 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. +-- | Primary function for formatting floating point numbers. formatNum :: Real a => NumFormat -> a -> Text -formatNum NumFormat{..} noUnits = +formatNum = formatNumGeneric (\p x -> T.pack $ showEFloat p x "") + (\p x -> T.pack $ showFFloat p x "") + + +------------------------------------------------------------------------------- +-- | Generic floating point formatting function that allows you to specify your +-- own underlying functions for formatting exponential and fixed formats. This +-- can allow you to use more efficient versions if available. We also use it +-- the test suite to check behavior against the old double-conversion +-- implementation. +formatNumGeneric + :: Real a + => (Maybe Int -> Double -> Text) + -- ^ Exponential formatter + -> (Maybe Int -> Double -> Text) + -- ^ Fixed formatter + -> NumFormat + -- ^ Format specification + -> a + -- ^ The number to format + -> Text +formatNumGeneric fmtExp fmtFixed NumFormat{..} noUnits = whenNegative noUnits (addSign _nfNegStyle) $ addPrefix $ addSuffix $ addDecimal _nfDecSep $ addThousands _nfThouSep $ maybe id limitPrecision _nfPrec $ + stripZeros precArg $ 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 + Exponent -> fmtExp precArg + Fixed -> fmtFixed precArg + SmartExponent lo hi -> smartStyle lo hi (fmtFixed precArg) (fmtExp precArg) + SIStyle -> fmtFixed precArg + SmartSI _ _ -> fmtFixed precArg addPrefix x = _nfPrefix <> x addSuffix x1 = let x2 = x1 <> siSuffix in x2 <> _nfSuffix - precArg = maybe (-1) fst _nfPrec + precArg = 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) + + +stripZeros :: Maybe Int -> RawNum a -> RawNum a +stripZeros precArg rn@(RawNum x a b c) = + if isNothing precArg && T.all (=='0') b + then RawNum x a "" c + else rn siPrefixIntegral :: Integral a => a -> (Int, Text)