jcc/Hcompta/Format/JCC/Amount/Style.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE TupleSections #-}
   4 module Hcompta.Format.JCC.Amount.Style where
   5
   6 import           Control.DeepSeq
   7 import           Data.Bool
   8 import           Data.Char (Char)
   9 import           Data.Data
  10 import           Data.Eq (Eq(..))
  11 import           Data.Map.Strict (Map)
  12 import qualified Data.Map.Strict as Map
  13 import           Data.Maybe (Maybe(..), maybe)
  14 import           Data.Monoid (Monoid(..))
  15 import           Data.Ord (Ord(..))
  16 import           Data.Typeable ()
  17 import           Data.Word (Word8)
  18 import           Prelude (($), Int, Show(..), const, seq)
  19
  20 import           Hcompta.Format.JCC.Unit (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 (Eq, Data, NFData, 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                  }