src/Haccounting/Unit.hs

   1 {-# LANGUAGE NoOverloadedLists #-}
   2 module Haccounting.Unit where
   3
   4 import Control.DeepSeq (NFData)
   5 --import Data.Word (Word8)
   6 import Data.Bool (Bool(..))
   7 import Data.Char (Char)
   8 import Data.Int (Int)
   9 import Data.Eq (Eq)
  10 import Data.Ord (Ord)
  11 import GHC.Stack (HasCallStack)
  12 import GHC.Generics (Generic)
  13 import Data.String (String)
  14 import Data.Functor ((<$>))
  15 import Data.Monoid (Monoid(..))
  16 import Data.Function (flip)
  17 import Data.Semigroup (Semigroup(..))
  18 import Text.Show (Show)
  19 import qualified Data.Map.Strict as Map
  20 import qualified Data.Char as Char
  21
  22 import Symantic.Compta.Utils.Error
  23
  24 errorWithStack :: HasCallStack => String -> a
  25 errorWithStack = error -- (msg <> "\n" <> prettyCallStack callStack)
  26
  27 data EUR
  28
  29 -- * Class 'Unitable'
  30 class Unitable repr where
  31   unit :: HasCallStack => Ty repr TyUnit -> repr a -> repr a
  32   --withUnit :: repr U -> repr a -> repr a
  33
  34 --withEuro :: repr a -> repr a
  35 --withEuro = withUnit euro
  36
  37 -- ** Class 'EURable'
  38 class EURable repr where
  39   eur :: repr TyQuantity -> repr TyAmount
  40 (€) :: EURable repr => repr TyQuantity -> repr TyAmount
  41 (€) = eur
  42 -- ** Class 'USDable'
  43 class USDable repr where
  44   usd :: repr TyQuantity -> repr TyAmount
  45 --($) = usd
  46
  47 -- * Type 'Unit'
  48 newtype Unit = Unit String
  49   deriving newtype (Eq, Ord, Show, NFData)
  50   deriving anyclass (Generic)
  51 instance IsString Unit where
  52   fromString = \case
  53     s@[c] | Char.CurrencySymbol <- Char.generalCategory c -> Unit s
  54     [] -> Unit ""
  55     _ -> errorWithStack "Unit"
  56
  57 -- * Type 'Quantity'
  58 newtype Quantity qty = Quantity qty
  59   deriving newtype (Eq, Show, NFData, Zeroable, Nullable, Addable, Negable, FromInteger, FromRational)
  60 instance Addable a => Semigroup (Quantity a) where
  61   Quantity x <> Quantity y = Quantity (x + y)
  62 instance (Zeroable a, Addable a) => Monoid (Quantity a) where
  63   mempty = Quantity zero
  64
  65 -- * Type 'Amounts'
  66 newtype Amounts unit qty = Amounts (Map.Map unit qty)
  67   deriving newtype (Eq, Show, NFData)
  68 {-
  69 instance Zeroable (Amounts a) where
  70   zero = Amounts Map.empty
  71 instance Nullable (Amounts a) where
  72   null (Amounts x) = Foldable.all null x
  73 -}
  74 instance (Ord unit, Semigroup qty) => Semigroup (Amounts unit qty) where
  75   Amounts x <> Amounts y = Amounts (Map.unionWith (flip (<>)) x y)
  76 instance (Ord unit, Semigroup qty) => Monoid (Amounts unit qty) where
  77   mempty = Amounts Map.empty
  78 instance Negable qty => Negable (Amounts unit qty) where
  79   negate (Amounts x) = Amounts (negate <$> x)
  80
  81 -- * Type 'AmountStyle'
  82 data AmountStyle = AmountStyle
  83   {  amountStyleFractioning :: Char
  84   ,  amountStyleGroupingIntegral :: (Char, [Int])
  85   ,  amountStyleGroupingFractional :: (Char, [Int])
  86   ,  amountStyleUnitSideLeft :: Bool
  87   ,  amountStyleUnitSpaced :: Bool
  88   -- TODO: , amountStyleSignPlus :: Bool
  89   } deriving (Eq, Show, Generic, NFData)
  90
  91 -- ** Type 'AmountStylePrecision'
  92 --type AmountStylePrecision = Natural
  93 {-
  94 amountStyles :: Map.Map Unit AmountStyle
  95 amountStyles = Map.fromList
  96   [ (scalarUnit, AmountStyle
  97      { amountStyleFractioning = '.'
  98      , amountStyleGroupingFractional = (',', [3])
  99      , amountStyleGroupingIntegral = (',', [3])
 100      , amountStyleUnitSideLeft = False
 101      , amountStyleUnitSpaced = False
 102      })
 103   , (chfUnit, AmountStyle
 104      { amountStyleFractioning = ','
 105      , amountStyleGroupingFractional = ('.', [3])
 106      , amountStyleGroupingIntegral = ('.', [3])
 107      , amountStyleUnitSideLeft = False
 108      , amountStyleUnitSpaced = False
 109      })
 110   , (cnyUnit, AmountStyle
 111      { amountStyleFractioning = ','
 112      , amountStyleGroupingFractional = ('.', [3])
 113      , amountStyleGroupingIntegral = ('.', [3])
 114      , amountStyleUnitSideLeft = False
 115      , amountStyleUnitSpaced = False
 116      })
 117   , (eurUnit, AmountStyle
 118      { amountStyleFractioning = ','
 119      , amountStyleGroupingFractional = ('.', [3])
 120      , amountStyleGroupingIntegral = ('.', [3])
 121      , amountStyleUnitSideLeft = False
 122      , amountStyleUnitSpaced = False
 123      })
 124   , (gbpUnit, AmountStyle
 125      { amountStyleFractioning = '.'
 126      , amountStyleGroupingFractional = (',', [3])
 127      , amountStyleGroupingIntegral = (',', [3])
 128      , amountStyleUnitSideLeft = True
 129      , amountStyleUnitSpaced = False
 130      })
 131   , (inrUnit, AmountStyle
 132      { amountStyleFractioning = ','
 133      , amountStyleGroupingFractional = ('.', [3])
 134      , amountStyleGroupingIntegral = ('.', [3])
 135      , amountStyleUnitSideLeft = False
 136      , amountStyleUnitSpaced = False
 137      })
 138   , (jpyUnit, AmountStyle
 139      { amountStyleFractioning = '.'
 140      , amountStyleGroupingFractional = (',', [3])
 141      , amountStyleGroupingIntegral = (',', [3])
 142      , amountStyleUnitSideLeft = True
 143      , amountStyleUnitSpaced = False
 144      })
 145   , (rubUnit, AmountStyle
 146      { amountStyleFractioning = '.'
 147      , amountStyleGroupingFractional = (',', [3])
 148      , amountStyleGroupingIntegral = (',', [3])
 149      , amountStyleUnitSideLeft = True
 150      , amountStyleUnitSpaced = False
 151      })
 152   , (usdUnit, AmountStyle
 153      { amountStyleFractioning = '.'
 154      , amountStyleGroupingFractional = (',', [3])
 155      , amountStyleGroupingIntegral = (',', [3])
 156      , amountStyleUnitSideLeft = True
 157      , amountStyleUnitSpaced = False
 158      })
 159   ]
 160 -}
 161
 162 scalarUnit :: Unit
 163 scalarUnit = Unit ""
 164
 165 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
 166 chfUnit :: Unit
 167 chfUnit = Unit "CHF"
 168
 169 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 170 cnyUnit :: Unit
 171 cnyUnit = Unit "Ұ"
 172
 173 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 174 eurUnit :: Unit
 175 eurUnit = Unit "€"
 176
 177 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 178 gbpUnit :: Unit
 179 gbpUnit = Unit "£"
 180
 181 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 182 inrUnit :: Unit
 183 inrUnit = Unit "₹"
 184
 185 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 186 jpyUnit :: Unit
 187 jpyUnit = Unit "¥"
 188
 189 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 190 rubUnit :: Unit
 191 rubUnit = Unit "₽"
 192
 193 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
 194 usdUnit :: Unit
 195 usdUnit = Unit "$"
 196
 197
 198
 199 {-
 200 import Control.DeepSeq
 201 import Data.Bool
 202 import Data.Char (Char)
 203 import Data.Data
 204 import Data.Decimal (Decimal, roundTo)
 205 import Data.Eq (Eq(..))
 206 import Data.Function (($), (.), const, flip)
 207 import Data.Map.Strict (Map)
 208 import Data.Monoid (Monoid(..))
 209 import Data.Ord (Ord(..))
 210 import Data.Semigroup (Semigroup(..))
 211 import Data.Strict.Maybe
 212 import Data.String (IsString)
 213 import Data.Text (Text)
 214 import Data.Typeable ()
 215 import Data.Word (Word8)
 216 import Prelude (Int, seq)
 217 import Text.Show (Show(..))
 218 import qualified Data.Map.Strict as Map
 219 import qualified Data.MonoTraversable as MT
 220 import qualified Data.Strict as S
 221 import qualified Data.Text as T
 222
 223 import qualified Hcompta as H
 224
 225 -- * Type 'Amount'
 226 data Amount
 227  =   Amount
 228  {   amount_unit     :: !Unit
 229  ,   amount_quantity :: !Quantity
 230  } deriving (Data, Eq, Ord, Show, Typeable)
 231
 232 -- type instance H.UnitFor     Amount = Unit
 233 -- type instance H.QuantityFor Amount = H.Polarized Quantity
 234
 235 instance NFData Amount where
 236   rnf (Amount q u) = rnf q `seq` rnf u
 237 -- instance H.Amount Amount
 238
 239 {-
 240 type instance H.Unit H.:@ Amount = Unit
 241 instance H.GetI H.Unit Amount where
 242   getI = amount_unit
 243 instance H.SetI H.Unit Amount where
 244   setI amount_unit a = a{amount_unit}
 245
 246 type instance H.Quantity H.:@ Amount = Quantity
 247 instance H.GetI H.Quantity Amount where
 248   getI = amount_quantity
 249 instance H.SetI H.Quantity Amount where
 250   setI amount_quantity a = a{amount_quantity}
 251 -}
 252
 253 instance H.Zeroable Amount where
 254   zero = Amount "" H.zero
 255 instance H.Nullable Amount where
 256   null = H.null . amount_quantity
 257    -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
 258    --       at 'Amount'’s 'amount_style'’s 'style_amount_precision'.
 259 instance H.Signable Amount where
 260   sign = H.sign . amount_quantity
 261
 262 amount :: Amount
 263 amount =
 264   Amount
 265    { amount_unit     = ""
 266    , amount_quantity = H.zero
 267    }
 268
 269 amount_style :: Style_Amounts -> Amount -> Style_Amount
 270 amount_style styles = style_amount_find styles . amount_unit
 271
 272 -- * Type 'Quantity'
 273 type Quantity = Decimal
 274
 275 quantity_round :: Word8 -> Quantity -> Quantity
 276 quantity_round = Data.Decimal.roundTo
 277
 278 -- * Type 'Unit'
 279 newtype Unit
 280  = Unit Text
 281  deriving (Data, Eq, IsString, Ord, Show, Typeable)
 282 instance H.Zeroable Unit where
 283   zero = Unit ""
 284 instance H.Nullable Unit where
 285   null (Unit x) = T.null x
 286 {-
 287 instance H.Unit Unit where
 288   noUnit = Unit ""
 289   textUnit (Unit t) = t
 290 -}
 291 instance NFData Unit where
 292   rnf (Unit t) = rnf t
 293
 294 -- ** Example 'Unit's
 295
 296
 297 -- * Type 'Style_Amount'
 298 data Style_Amount
 299  =   Style_Amount
 300  {   amountStyleFractioning         :: !(S.Maybe Style_Amount_Fractioning)
 301  ,   amountStyleGroupingIntegral   :: !(S.Maybe AmountStyleGrouping)
 302  ,   amountStyleGroupingFractional :: !(S.Maybe AmountStyleGrouping)
 303  ,   amountStyleUnitSideLeft           :: !(S.Maybe LR)
 304  ,   amountStyleUnitSpaced         :: !(S.Maybe Style_Amount_Spacing)
 305  -- TODO: , style_amount_sign_plus     :: S.Maybe Bool
 306  } deriving (Data, Eq, Ord, Show, Typeable)
 307 instance NFData Style_Amount where
 308   rnf (Style_Amount f gi gf ui up) =
 309     rnf f  `seq`
 310     rnf gi `seq`
 311     rnf gf `seq`
 312     rnf ui `seq`
 313     rnf up
 314 instance Semigroup Style_Amount where
 315   (<>) = style_amount_union
 316 instance Monoid Style_Amount where
 317   mempty  = style_amount
 318   mappend = (<>)
 319
 320 style_amount :: Style_Amount
 321 style_amount =
 322   Style_Amount
 323    { amountStyleFractioning         = Nothing
 324    , amountStyleGroupingIntegral   = Nothing
 325    , amountStyleGroupingFractional = Nothing
 326    , amountStyleUnitSideLeft           = Nothing
 327    , amountStyleUnitSpaced         = Nothing
 328    }
 329
 330 style_amount_union
 331  :: Style_Amount
 332  -> Style_Amount
 333  -> Style_Amount
 334 style_amount_union
 335  sty@Style_Amount
 336  { amountStyleFractioning=f
 337  , amountStyleGroupingIntegral=gi
 338  , amountStyleGroupingFractional=gf
 339  , amountStyleUnitSideLeft=side
 340  , amountStyleUnitSpaced=spaced
 341  }
 342  sty'@Style_Amount
 343  { amountStyleFractioning=f'
 344  , amountStyleGroupingIntegral=gi'
 345  , amountStyleGroupingFractional=gf'
 346  , amountStyleUnitSideLeft=side'
 347  , amountStyleUnitSpaced=spaced'
 348  } =
 349   if sty == sty'
 350   then sty'
 351   else
 352     Style_Amount
 353      { amountStyleFractioning        = S.maybe f'      (const f)      f
 354      , amountStyleGroupingIntegral   = S.maybe gi'     (const gi)     gi
 355      , amountStyleGroupingFractional = S.maybe gf'     (const gf)     gf
 356      , amountStyleUnitSideLeft       = S.maybe side'   (const side)   side
 357      , amountStyleUnitSpaced         = S.maybe spaced' (const spaced) spaced
 358      }
 359
 360 -- ** Type 'Style_Amount_Fractioning'
 361 type Style_Amount_Fractioning
 362  = Char
 363
 364 -- ** Type 'AmountStyleGrouping'
 365 data AmountStyleGrouping
 366  =   AmountStyleGrouping Char [Int]
 367  deriving (Data, Eq, Ord, Show, Typeable)
 368 instance NFData AmountStyleGrouping where
 369   rnf (AmountStyleGrouping s d) = rnf s `seq` rnf d
 370
 371 -- ** Type 'Style_Amount_Precision'
 372 type Style_Amount_Precision
 373  = Word8
 374
 375 -- ** Type 'Style_Amount_Spacing'
 376 type Style_Amount_Spacing
 377  = Bool
 378
 379 -- ** Type 'LR'
 380 data LR = L | R
 381  deriving (Data, Eq, Ord, Show, Typeable)
 382 instance NFData LR where
 383   rnf L = ()
 384   rnf R = ()
 385
 386 -- ** Type 'Style_Amounts'
 387 newtype Style_Amounts
 388  =      Style_Amounts (Map Unit Style_Amount)
 389  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 390
 391 -- type instance H.UnitFor     Amounts = Unit
 392 -- type instance H.QuantityFor Amounts = Quantity
 393
 394 instance Semigroup Style_Amounts where
 395   Style_Amounts x <> Style_Amounts y =
 396     Style_Amounts (Map.unionWith (flip (<>)) x y)
 397 instance Monoid Style_Amounts where
 398   mempty  = Style_Amounts mempty
 399   mappend = (<>)
 400 instance H.Zeroable Style_Amounts where
 401   zero = Style_Amounts mempty
 402 instance H.Sumable Style_Amounts (Unit, Style_Amount) where
 403   Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss
 404
 405 unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
 406 unStyle_Amounts (Style_Amounts fp) = fp
 407
 408 style_amount_find :: Style_Amounts -> Unit -> Style_Amount
 409 style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s
 410
 411 -- *** Example 'Style_Amounts'
 412 amountStyles :: Style_Amounts
 413
 414 -- ** Type 'Styled_Amount'
 415 type Styled_Amount t = (Style_Amount, t)
 416
 417 styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
 418 styled_amount styles amt = (amount_style styles amt, amt)
 419
 420 -- * Type 'Amounts'
 421 newtype Amounts = Amounts (Map Unit Quantity)
 422  deriving (Data, Eq, NFData, Ord, Show, Typeable
 423  , H.Addable, H.Negable, H.Subable)
 424 unAmounts :: Amounts -> Map Unit Quantity
 425 unAmounts (Amounts a) = a
 426
 427 type instance MT.Element Amounts = Amount
 428 -- instance H.Amounts Amounts
 429
 430 -- instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
 431 --   get (Amounts a) = a
 432 -}