src/Literate/Accounting/Unit.hs

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