ledger/Hcompta/Format/Ledger/Amount/Style.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE TupleSections #-}
   3 module Hcompta.Format.Ledger.Amount.Style where
   4
   5 import           Control.DeepSeq
   6 import           Data.Bool
   7 import           Data.Char (Char)
   8 import           Data.Data
   9 import           Data.Eq (Eq(..))
  10 import           Data.Map.Strict (Map)
  11 import qualified Data.Map.Strict as Map
  12 import           Data.Maybe (Maybe(..), maybe)
  13 import           Data.Monoid (Monoid(..))
  14 import           Data.Ord (Ord(..))
  15 import           Data.Typeable ()
  16 import           Data.Word (Word8)
  17 import           Prelude (($), Int, Show(..), const, seq)
  18
  19 import           Hcompta.Format.Ledger.Unit (Unit)
  20 import qualified Hcompta.Format.Ledger.Unit as Unit
  21
  22 -- * Type 'Style'
  23
  24 data Style
  25  =   Style
  26  { fractioning         :: Maybe Fractioning
  27  , grouping_integral   :: Maybe Grouping
  28  , grouping_fractional :: Maybe Grouping
  29  -- TODO: , sign_plus     :: Maybe Bool
  30  , unit_side           :: Maybe Side
  31  , unit_spaced         :: Maybe Spacing
  32  } deriving (Data, Eq, Ord, Show, Typeable)
  33 instance NFData Style where
  34         rnf (Style f gi gf ui up) =
  35                 rnf f  `seq`
  36                 rnf gi `seq`
  37                 rnf gf `seq`
  38                 rnf ui `seq`
  39                 rnf up
  40 instance Monoid Style where
  41         mempty  = empty
  42         mappend = union
  43
  44 type Fractioning
  45  = Char
  46
  47 data Grouping
  48  =   Grouping Char [Int]
  49  deriving (Data, Eq, Ord, Show, Typeable)
  50 instance NFData Grouping where
  51         rnf (Grouping s d) = rnf s `seq` rnf d
  52
  53 type Precision
  54  = Word8
  55
  56 type Spacing
  57  = Bool
  58
  59 data Side
  60  =   Side_Left
  61  |   Side_Right
  62  deriving (Data, Eq, Ord, Show, Typeable)
  63 instance NFData Side where
  64         rnf Side_Left  = ()
  65         rnf Side_Right = ()
  66
  67 -- * Type 'Styles'
  68
  69 newtype Styles
  70  =      Styles (Map Unit Style)
  71  deriving (Data, Eq, Show, Typeable)
  72 instance Monoid Styles where
  73         mempty = Styles mempty
  74         mappend (Styles x) (Styles y) =
  75                 Styles (Map.unionWith mappend x y)
  76
  77 -- * Type 'Styled'
  78
  79 type Styled t = (Style, t)
  80
  81 -- * Constructors
  82
  83 empty :: Style
  84 empty =
  85         Style
  86          { fractioning         = Nothing
  87          , grouping_integral   = Nothing
  88          , grouping_fractional = Nothing
  89          , unit_side           = Nothing
  90          , unit_spaced         = Nothing
  91          }
  92
  93 style :: Styles -> Unit -> Style
  94 style (Styles s) u = Map.findWithDefault empty u s
  95
  96 -- * Operators
  97
  98 cons :: (Unit, Style) -> Styles -> Styles
  99 cons (u, s) (Styles ss) =
 100         Styles $
 101         Map.insertWith mappend u s ss
 102
 103 union :: Style -> Style -> Style
 104 union
 105  sty@Style
 106  { fractioning=fractioning_
 107  , grouping_integral=grouping_integral_
 108  , grouping_fractional=grouping_fractional_
 109  , unit_side=side
 110  , unit_spaced=spaced
 111  }
 112  sty'@Style
 113  { fractioning=fractioning'
 114  , grouping_integral=grouping_integral_'
 115  , grouping_fractional=grouping_fractional_'
 116  , unit_side=side'
 117  , unit_spaced=spaced'
 118  } =
 119         if sty == sty'
 120         then sty'
 121         else
 122                 Style
 123                  { fractioning=maybe fractioning' (const fractioning_) fractioning_
 124                  , grouping_integral=maybe grouping_integral_' (const grouping_integral_) grouping_integral_
 125                  , grouping_fractional=maybe grouping_fractional_' (const grouping_fractional_) grouping_fractional_
 126                  , unit_side=maybe side' (const side) side
 127                  , unit_spaced=maybe spaced' (const spaced) spaced
 128                  }
 129
 130 -- * Example 'Style's
 131
 132 styles :: Styles
 133 styles = Styles $ Map.fromList
 134  [ (Unit.scalar,) Style
 135     { fractioning         = Just '.'
 136     , grouping_fractional = Just $ Grouping ',' [3]
 137     , grouping_integral   = Just $ Grouping ',' [3]
 138     , unit_side           = Just Side_Right
 139     , unit_spaced         = Just False
 140     }
 141  , (Unit.chf,) Style
 142     { fractioning         = Just ','
 143     , grouping_fractional = Just $ Grouping '.' [3]
 144     , grouping_integral   = Just $ Grouping '.' [3]
 145     , unit_side           = Just Side_Right
 146     , unit_spaced         = Just False
 147     }
 148  , (Unit.cny,) Style
 149     { fractioning         = Just ','
 150     , grouping_fractional = Just $ Grouping '.' [3]
 151     , grouping_integral   = Just $ Grouping '.' [3]
 152     , unit_side           = Just Side_Right
 153     , unit_spaced         = Just False
 154     }
 155  , (Unit.eur,) Style
 156     { fractioning         = Just ','
 157     , grouping_fractional = Just $ Grouping '.' [3]
 158     , grouping_integral   = Just $ Grouping '.' [3]
 159     , unit_side           = Just Side_Right
 160     , unit_spaced         = Just False
 161     }
 162  , (Unit.gbp,) Style
 163     { fractioning         = Just '.'
 164     , grouping_fractional = Just $ Grouping ',' [3]
 165     , grouping_integral   = Just $ Grouping ',' [3]
 166     , unit_side           = Just Side_Left
 167     , unit_spaced         = Just False
 168     }
 169  , (Unit.inr,) Style
 170     { fractioning         = Just ','
 171     , grouping_fractional = Just $ Grouping '.' [3]
 172     , grouping_integral   = Just $ Grouping '.' [3]
 173     , unit_side           = Just Side_Right
 174     , unit_spaced         = Just False
 175     }
 176  , (Unit.jpy,) Style
 177     { fractioning         = Just '.'
 178     , grouping_fractional = Just $ Grouping ',' [3]
 179     , grouping_integral   = Just $ Grouping ',' [3]
 180     , unit_side           = Just Side_Left
 181     , unit_spaced         = Just False
 182     }
 183  , (Unit.rub,) Style
 184     { fractioning         = Just '.'
 185     , grouping_fractional = Just $ Grouping ',' [3]
 186     , grouping_integral   = Just $ Grouping ',' [3]
 187     , unit_side           = Just Side_Left
 188     , unit_spaced         = Just False
 189     }
 190  , (Unit.usd,) Style
 191     { fractioning         = Just '.'
 192     , grouping_fractional = Just $ Grouping ',' [3]
 193     , grouping_integral   = Just $ Grouping ',' [3]
 194     , unit_side           = Just Side_Left
 195     , unit_spaced         = Just False
 196     }
 197  ]