diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Renzo Carbonara + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Renzo Carbonara nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +The Haskell `safe-money` library offers type-safe and lossless encoding and +operations for monetary values in all world currencies, including fiat +currencies, precious metals and crypto-currencies. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# Version 0.1 + +* Initial release. diff --git a/safe-money.cabal b/safe-money.cabal new file mode 100644 --- /dev/null +++ b/safe-money.cabal @@ -0,0 +1,84 @@ +name: safe-money +version: 0.1 +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) Renzo Carbonara 2016 +author: Renzo Carbonara +maintainer: renλren!zone +stability: Experimental +tested-with: GHC==8.0.1 +homepage: https://github.com/k0001/safe-money +bug-reports: https://github.com/k0001/safe-money/issues +category: Money +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md changelog.md +synopsis: Type-safe and lossless encoding and manipulation of money, world currencies and precious metals. +description: Type-safe and lossless encoding and manipulation of money, world currencies and precious metals. + +source-repository head + type: git + location: https://github.com/k0001/safe-money + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -O2 + exposed-modules: + Data.Money + Data.Money.Internal + build-depends: + base (>=4.5 && <5.0) + , constraints + + if flag(aeson) + build-depends: aeson + if flag(binary) + build-depends: binary + if flag(cereal) + build-depends: cereal + if flag(deepseq) + build-depends: deepseq + if flag(hashable) + build-depends: hashable + if flag(store) + build-depends: store + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests src + main-is: Main.hs + build-depends: + aeson + , base + , binary + , bytestring + , cereal + , constraints + , deepseq + , hashable + , store + , tasty + , tasty-hunit + , tasty-quickcheck + +-- Provide instances for @aeson@ +flag aeson + default: True +-- Provide instances for @binary@ +flag binary + default: True +-- Provide instances for @cereal@ +flag cereal + default: True +-- Provide instances for @store@ +flag store + default: True +-- Provide instances for @hashable@ +flag hashable + default: True +-- Provide instances for @deepseq@ +flag deepseq + default: True + diff --git a/src/Data/Money.hs b/src/Data/Money.hs new file mode 100644 --- /dev/null +++ b/src/Data/Money.hs @@ -0,0 +1,769 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Import this module qualified: +-- +-- @ +-- import qualified Data.Money as Money +-- @ +module Data.Money + ( -- * Dense monetary values + I.Dense + , I.dense + -- * Discrete monetary values + , I.Discrete + , I.Discrete' + , I.fromDiscrete + , I.round + , I.ceiling + , I.floor + , I.truncate + -- * Currency scales + , I.Scale + , I.GoodScale + , I.scale + -- * Currency exchange + , I.ExchangeRate + , I.exchangeRate + , I.fromExchangeRate + , I.flipExchangeRate + , I.exchange + -- * Serializable representations + , I.DenseRep + , I.denseRep + , I.fromDenseRep + , I.withDenseRep + , I.DiscreteRep + , I.discreteRep + , I.fromDiscreteRep + , I.withDiscreteRep + , I.ExchangeRateRep + , I.exchangeRateRep + , I.fromExchangeRateRep + , I.withExchangeRateRep + ) where + +import qualified Data.Money.Internal as I + +-------------------------------------------------------------------------------- +-- Currency scales + +-- | United Arab Emirates dirham +type instance I.Scale "AED" "AED" = '(100, 1) +type instance I.Scale "AED" "dirham" = '(1, 1) +type instance I.Scale "AED" "fils" = '(100, 1) +-- | Afghan afghani +type instance I.Scale "AFN" "AFN" = '(100, 1) +type instance I.Scale "AFN" "afghani" = '(1, 1) +type instance I.Scale "AFN" "pul" = '(100, 1) +-- | Albanian lek +type instance I.Scale "ALL" "ALL" = '(100, 1) +type instance I.Scale "ALL" "lek" = '(1, 1) +type instance I.Scale "ALL" "qindarke" = '(100, 1) +-- | Armenian dram +type instance I.Scale "AMD" "AMD" = '(100, 1) +type instance I.Scale "AMD" "dram" = '(1, 1) +type instance I.Scale "AMD" "luma" = '(100, 1) +-- | Netherlands Antillean guilder +type instance I.Scale "ANG" "ANG" = '(100, 1) +type instance I.Scale "ANG" "guilder" = '(1, 1) +type instance I.Scale "ANG" "cent" = '(100, 1) +-- | Angolan kwanza +type instance I.Scale "AOA" "AOA" = '(100, 1) +type instance I.Scale "AOA" "kwanza" = '(1, 1) +type instance I.Scale "AOA" "centimo" = '(100, 1) +-- | Argentine peso +type instance I.Scale "ARS" "ARS" = '(100, 1) +type instance I.Scale "ARS" "peso" = '(1, 1) +type instance I.Scale "ARS" "centavo" = '(100, 1) +-- | Australian dollar +type instance I.Scale "AUD" "AUD" = '(100, 1) +type instance I.Scale "AUD" "dollar" = '(1, 1) +type instance I.Scale "AUD" "cent" = '(100, 1) +-- | Aruban florin +type instance I.Scale "AWG" "AWG" = '(100, 1) +type instance I.Scale "AWG" "florin" = '(1, 1) +type instance I.Scale "AWG" "cent" = '(100, 1) +-- | Azerbaijani manat +type instance I.Scale "AZN" "AZN" = '(100, 1) +type instance I.Scale "AZN" "manat" = '(1, 1) +type instance I.Scale "AZN" "qapik" = '(100, 1) +-- | Bosnia and Herzegovina convertible mark +type instance I.Scale "BAM" "BAM" = '(100, 1) +type instance I.Scale "BAM" "mark" = '(1, 1) +type instance I.Scale "BAM" "fening" = '(100, 1) +-- | Barbadian dollar +type instance I.Scale "BBD" "BBD" = '(100, 1) +type instance I.Scale "BBD" "dollar" = '(1, 1) +type instance I.Scale "BBD" "cent" = '(100, 1) +-- | Bangladeshi taka +type instance I.Scale "BDT" "BDT" = '(100, 1) +type instance I.Scale "BDT" "taka" = '(1, 1) +type instance I.Scale "BDT" "paisa" = '(100, 1) +-- | Bulgarian lev +type instance I.Scale "BGN" "BGN" = '(100, 1) +type instance I.Scale "BGN" "lev" = '(1, 1) +type instance I.Scale "BGN" "stotinka" = '(100, 1) +-- | Bahraini dinar +type instance I.Scale "BHD" "BHD" = '(1000, 1) +type instance I.Scale "BHD" "dinar" = '(1, 1) +type instance I.Scale "BHD" "fils" = '(1000, 1) +-- | Burundi franc +type instance I.Scale "BIF" "BIF" = '(100, 1) +type instance I.Scale "BIF" "franc" = '(1, 1) +type instance I.Scale "BIF" "centime" = '(100, 1) +-- | Bermudian dollar +type instance I.Scale "BMD" "BMD" = '(100, 1) +type instance I.Scale "BMD" "dollar" = '(1, 1) +type instance I.Scale "BMD" "cent" = '(100, 1) +-- | Brunei dollar +type instance I.Scale "BND" "BND" = '(100, 1) +type instance I.Scale "BND" "dollar" = '(1, 1) +type instance I.Scale "BND" "sen" = '(100, 1) +-- | Bolivian boliviano +type instance I.Scale "BOB" "BOB" = '(100, 1) +type instance I.Scale "BOB" "boliviano" = '(1, 1) +type instance I.Scale "BOB" "centavo" = '(100, 1) +-- | Bolivian Mvdol +type instance I.Scale "BOV" "BOV" = '(100, 1) +-- | Brazilian real +type instance I.Scale "BRL" "BRL" = '(100, 1) +type instance I.Scale "BRL" "real" = '(1, 1) +type instance I.Scale "BRL" "centavo" = '(100, 1) +-- | Bahamian dollar +type instance I.Scale "BSD" "BSD" = '(100, 1) +type instance I.Scale "BSD" "dollar" = '(1, 1) +type instance I.Scale "BSD" "cent" = '(1, 1) +-- | Bhutanese ngultrum +type instance I.Scale "BTN" "BTN" = '(100, 1) +type instance I.Scale "BTN" "ngultrum" = '(1, 1) +type instance I.Scale "BTN" "chetrum" = '(100, 1) +-- | Botswana pula +type instance I.Scale "BWP" "BWP" = '(100, 1) +type instance I.Scale "BWP" "pula" = '(1, 1) +type instance I.Scale "BWP" "thebe" = '(100, 1) +-- | Belarusian ruble +type instance I.Scale "BYN" "BYN" = '(100, 1) +-- | Belarusian ruble +type instance I.Scale "BYR" "BYR" = '(100, 1) +type instance I.Scale "BYR" "ruble" = '(1, 1) +type instance I.Scale "BYR" "kapyeyka" = '(100, 1) +-- | Belize dollar +type instance I.Scale "BZD" "BZD" = '(100, 1) +type instance I.Scale "BZD" "dollar" = '(1, 1) +type instance I.Scale "BZD" "cent" = '(100, 1) +-- | Canadian dollar +type instance I.Scale "CAD" "CAD" = '(100, 1) +type instance I.Scale "CAD" "dollar" = '(1, 1) +type instance I.Scale "CAD" "cent" = '(100, 1) +-- | Congolese franc +type instance I.Scale "CDF" "CDF" = '(100, 1) +type instance I.Scale "CDF" "franc" = '(1, 1) +type instance I.Scale "CDF" "centime" = '(100, 1) +-- | WIR euro +type instance I.Scale "CHE" "CHE" = '(100, 1) +-- | Swiss franc +type instance I.Scale "CHF" "CHF" = '(100, 1) +type instance I.Scale "CHF" "franc" = '(1, 1) +type instance I.Scale "CHF" "rappen" = '(100, 1) +-- | WIR franc +type instance I.Scale "CHW" "CHW" = '(100, 1) +-- | Chilean unidad de fomento +type instance I.Scale "CLF" "CLF" = '(100, 1) +-- | Chilean peso +type instance I.Scale "CLP" "CLP" = '(100, 1) +type instance I.Scale "CLP" "peso" = '(1, 1) +type instance I.Scale "CLP" "centavo" = '(100, 1) +-- | Chinese Renminbi +type instance I.Scale "CNY" "CNY" = '(100, 1) +type instance I.Scale "CNY" "yuan" = '(1, 1) +type instance I.Scale "CNY" "fen" = '(100, 1) +-- | Colombian peso +type instance I.Scale "COP" "COP" = '(100, 1) +type instance I.Scale "COP" "peso" = '(1, 1) +type instance I.Scale "COP" "centavo" = '(100, 1) +-- | Colombian unidad de valor real +type instance I.Scale "COU" "COU" = '(100, 1) +-- | Costa Rican colon +type instance I.Scale "CRC" "CRC" = '(100, 1) +type instance I.Scale "CRC" "colon" = '(1, 1) +type instance I.Scale "CRC" "centimo" = '(100, 1) +-- | Cuban peso convertible +type instance I.Scale "CUC" "CUC" = '(100, 1) +type instance I.Scale "CUC" "peso" = '(1, 1) +type instance I.Scale "CUC" "centavo" = '(100, 1) +-- | Cuban peso +type instance I.Scale "CUP" "CUP" = '(100, 1) +type instance I.Scale "CUP" "peso" = '(1, 1) +type instance I.Scale "CUP" "centavo" = '(100, 1) +-- | Cape Verdean escudo +type instance I.Scale "CVE" "CVE" = '(100, 1) +type instance I.Scale "CVE" "escudo" = '(1, 1) +type instance I.Scale "CVE" "centavo" = '(100, 1) +-- | Czech koruna +type instance I.Scale "CZK" "CZK" = '(100, 1) +type instance I.Scale "CZK" "koruna" = '(1, 1) +type instance I.Scale "CZK" "haler" = '(100, 1) +-- | Djiboutian franc +type instance I.Scale "DJF" "DJF" = '(100, 1) +type instance I.Scale "DJF" "franc" = '(1, 1) +type instance I.Scale "DJF" "centime" = '(100, 1) +-- | Danish krone +type instance I.Scale "DKK" "DKK" = '(100, 1) +type instance I.Scale "DKK" "krone" = '(1, 1) +type instance I.Scale "DKK" "ore" = '(100, 1) +-- | Dominican peso +type instance I.Scale "DOP" "DOP" = '(100, 1) +type instance I.Scale "DOP" "peso" = '(1, 1) +type instance I.Scale "DOP" "centavo" = '(100, 1) +-- | Algerian dinar +type instance I.Scale "DZD" "DZD" = '(100, 1) +type instance I.Scale "DZD" "dinar" = '(1, 1) +type instance I.Scale "DZD" "santeem" = '(100, 1) +-- | Egyptian pound +type instance I.Scale "EGP" "EGP" = '(100, 1) +type instance I.Scale "EGP" "pound" = '(1, 1) +type instance I.Scale "EGP" "piastre" = '(100, 1) +-- | Eritrean nakfa +type instance I.Scale "ERN" "ERN" = '(100, 1) +type instance I.Scale "ERN" "nafka" = '(1, 1) +type instance I.Scale "ERN" "cent" = '(100, 1) +-- | Ethiopian birr +type instance I.Scale "ETB" "ETB" = '(100, 1) +type instance I.Scale "ETB" "birr" = '(1, 1) +type instance I.Scale "ETB" "santim" = '(100, 1) +-- | European euro +type instance I.Scale "EUR" "EUR" = '(100, 1) +type instance I.Scale "EUR" "euro" = '(1, 1) +type instance I.Scale "EUR" "cent" = '(100, 1) +-- | Fijian dollar +type instance I.Scale "FJD" "FJD" = '(100, 1) +-- | Falkland Islands pound +type instance I.Scale "FKP" "FKP" = '(100, 1) +type instance I.Scale "FKP" "pound" = '(1, 1) +type instance I.Scale "FKP" "penny" = '(100, 1) +-- | Pound sterling +type instance I.Scale "GBP" "GBP" = '(100, 1) +type instance I.Scale "GBP" "pound" = '(1, 1) +type instance I.Scale "GBP" "penny" = '(100, 1) +-- | Georgian lari +type instance I.Scale "GEL" "GEL" = '(100, 1) +type instance I.Scale "GEL" "lari" = '(1, 1) +type instance I.Scale "GEL" "tetri" = '(100, 1) +-- | Ghanaian cedi +type instance I.Scale "GHS" "GHS" = '(100, 1) +type instance I.Scale "GHS" "cedi" = '(1, 1) +type instance I.Scale "GHS" "pesewa" = '(100, 1) +-- | Gibraltar pound +type instance I.Scale "GIP" "GIP" = '(100, 1) +type instance I.Scale "GIP" "pound" = '(1, 1) +type instance I.Scale "GIP" "penny" = '(100, 1) +-- | Gambian dalasi +type instance I.Scale "GMD" "GMD" = '(100, 1) +type instance I.Scale "GMD" "dalasi" = '(1, 1) +type instance I.Scale "GMD" "butut" = '(100, 1) +-- | Guinean franc +type instance I.Scale "GNF" "GNF" = '(100, 1) +type instance I.Scale "GNF" "franc" = '(1, 1) +type instance I.Scale "GNF" "centime" = '(100, 1) +-- | Guatemalan quetzal +type instance I.Scale "GTQ" "GTQ" = '(100, 1) +type instance I.Scale "GTQ" "quetzal" = '(1, 1) +type instance I.Scale "GTQ" "centavo" = '(100, 1) +-- | Guyanese dollar +type instance I.Scale "GYD" "GYD" = '(100, 1) +type instance I.Scale "GYD" "dollar" = '(1, 1) +type instance I.Scale "GYD" "cent" = '(100, 1) +-- | Hong Kong dollar +type instance I.Scale "HKD" "HKD" = '(100, 1) +type instance I.Scale "HKD" "dollar" = '(1, 1) +type instance I.Scale "HKD" "cent" = '(100, 1) +-- | Honduran lempira +type instance I.Scale "HNL" "HNL" = '(100, 1) +type instance I.Scale "HNL" "lempira" = '(1, 1) +type instance I.Scale "HNL" "centavo" = '(100, 1) +-- | Croatian kuna +type instance I.Scale "HRK" "HRK" = '(100, 1) +type instance I.Scale "HRK" "kuna" = '(1, 1) +type instance I.Scale "HRK" "lipa" = '(100, 1) +-- | Haitian gourde +type instance I.Scale "HTG" "HTG" = '(100, 1) +type instance I.Scale "HTG" "gourde" = '(1, 1) +type instance I.Scale "HTG" "centime" = '(1, 1) +-- | Hungarian forint +type instance I.Scale "HUF" "HUF" = '(100, 1) +type instance I.Scale "HUF" "forint" = '(1, 1) +type instance I.Scale "HUF" "filler" = '(100, 1) +-- | Indonesian rupiah +type instance I.Scale "IDR" "IDR" = '(100, 1) +type instance I.Scale "IDR" "rupiah" = '(1, 1) +type instance I.Scale "IDR" "sen" = '(100, 1) +-- | Israeli new shekel +type instance I.Scale "ILS" "ILS" = '(100, 1) +type instance I.Scale "ILS" "shekel" = '(1, 1) +type instance I.Scale "ILS" "agora" = '(100, 1) +-- | Indian rupee +type instance I.Scale "INR" "INR" = '(100, 1) +type instance I.Scale "INR" "rupee" = '(1, 1) +type instance I.Scale "INR" "paisa" = '(100, 1) +-- | Iraqi dinar +type instance I.Scale "IQD" "IQD" = '(1000, 1) +type instance I.Scale "IQD" "dinar" = '(1, 1) +type instance I.Scale "IQD" "fils" = '(1000, 1) +-- | Iranian rial +type instance I.Scale "IRR" "IRR" = '(100, 1) +type instance I.Scale "IRR" "rial" = '(1, 1) +type instance I.Scale "IRR" "dinar" = '(100, 1) +-- | Icelandic króna +type instance I.Scale "ISK" "ISK" = '(100, 1) +type instance I.Scale "ISK" "krona" = '(1, 1) +type instance I.Scale "ISK" "eyir" = '(100, 1) +-- | Jamaican dollar +type instance I.Scale "JMD" "JMD" = '(100, 1) +type instance I.Scale "JMD" "dollar" = '(1, 1) +type instance I.Scale "JMD" "cent" = '(100, 1) +-- | Jordanian dinar +type instance I.Scale "JOD" "JOD" = '(100, 1) +type instance I.Scale "JOD" "dinar" = '(1, 1) +type instance I.Scale "JOD" "piastre" = '(100, 1) +-- | Japanese yen +type instance I.Scale "JPY" "JPY" = '(100, 1) +type instance I.Scale "JPY" "yen" = '(1, 1) +type instance I.Scale "JPY" "sen" = '(100, 1) +-- | Kenyan shilling +type instance I.Scale "KES" "KES" = '(100, 1) +type instance I.Scale "KES" "shilling" = '(1, 1) +type instance I.Scale "KES" "cent" = '(100, 1) +-- | Kyrgyzstani som +type instance I.Scale "KGS" "KGS" = '(100, 1) +type instance I.Scale "KGS" "som" = '(1, 1) +type instance I.Scale "KGS" "tyiyn" = '(100, 1) +-- | Cambodian riel +type instance I.Scale "KHR" "KHR" = '(100, 1) +type instance I.Scale "KHR" "riel" = '(1, 1) +type instance I.Scale "KHR" "sen" = '(100, 1) +-- | Comorian franc +type instance I.Scale "KMF" "KMF" = '(100, 1) +type instance I.Scale "KMF" "franc" = '(1, 1) +type instance I.Scale "KMF" "centime" = '(100, 1) +-- | North Korean won +type instance I.Scale "KPW" "KPW" = '(100, 1) +type instance I.Scale "KPW" "won" = '(1, 1) +type instance I.Scale "KPW" "chon" = '(100, 1) +-- | South Korean won +type instance I.Scale "KRW" "KRW" = '(100, 1) +type instance I.Scale "KRW" "won" = '(1, 1) +type instance I.Scale "KRW" "jeon" = '(100, 1) +-- | Kuwaiti dinar +type instance I.Scale "KWD" "KWD" = '(1000, 1) +type instance I.Scale "KWD" "dinar" = '(1, 1) +type instance I.Scale "KWD" "fils" = '(1000, 1) +-- | Cayman Islands dollar +type instance I.Scale "KYD" "KYD" = '(100, 1) +type instance I.Scale "KYD" "dollar" = '(1, 1) +type instance I.Scale "KYD" "cent" = '(100, 1) +-- | Kazakhstani tenge +type instance I.Scale "KZT" "KZT" = '(100, 1) +type instance I.Scale "KZT" "tenge" = '(1, 1) +type instance I.Scale "KZT" "tiyin" = '(100, 1) +-- | Lao kip +type instance I.Scale "LAK" "LAK" = '(100, 1) +type instance I.Scale "LAK" "kip" = '(1, 1) +type instance I.Scale "LAK" "att" = '(100, 1) +-- | Lebanese pound +type instance I.Scale "LBP" "LBP" = '(100, 1) +type instance I.Scale "LBP" "pound" = '(1, 1) +type instance I.Scale "LBP" "piastre" = '(100, 1) +-- | Sri Lankan rupee +type instance I.Scale "LKR" "LKR" = '(100, 1) +type instance I.Scale "LKR" "rupee" = '(1, 1) +type instance I.Scale "LKR" "cent" = '(100, 1) +-- | Liberian dollar +type instance I.Scale "LRD" "LRD" = '(100, 1) +type instance I.Scale "LRD" "dollar" = '(1, 1) +type instance I.Scale "LRD" "cent" = '(100, 1) +-- | Lesotho loti +type instance I.Scale "LSL" "LSL" = '(100, 1) +type instance I.Scale "LSL" "loti" = '(1, 1) +type instance I.Scale "LSL" "sente" = '(100, 1) +-- | Libyan dinar +type instance I.Scale "LYD" "LYD" = '(100, 1) +type instance I.Scale "LYD" "dinar" = '(1, 1) +type instance I.Scale "LYD" "dirham" = '(1000, 1) +-- | Moroccan dirham +type instance I.Scale "MAD" "MAD" = '(100, 1) +type instance I.Scale "MAD" "dirham" = '(1, 1) +type instance I.Scale "MAD" "centime" = '(100, 1) +-- | Moldovan leu +type instance I.Scale "MDL" "MDL" = '(100, 1) +type instance I.Scale "MDL" "leu" = '(100, 1) +type instance I.Scale "MDL" "ban" = '(100, 1) +-- | Malagasy ariary +type instance I.Scale "MGA" "MGA" = '(5, 1) +type instance I.Scale "MGA" "ariary" = '(1, 1) +type instance I.Scale "MGA" "iraimbilanja" = '(5, 1) +-- | Macedonian denar +type instance I.Scale "MKD" "MKD" = '(100, 1) +type instance I.Scale "MKD" "denar" = '(1, 1) +type instance I.Scale "MKD" "deni" = '(100, 1) +-- | Myanmar kyat +type instance I.Scale "MMK" "MMK" = '(100, 1) +type instance I.Scale "MMK" "kyat" = '(1, 1) +type instance I.Scale "MMK" "pya" = '(100, 1) +-- | Mongolian tugrik +type instance I.Scale "MNT" "MNT" = '(100, 1) +type instance I.Scale "MNT" "tugrik" = '(1, 1) +type instance I.Scale "MNT" "mongo" = '(100, 1) +-- | Macanese pataca +type instance I.Scale "MOP" "MOP" = '(100, 1) +type instance I.Scale "MOP" "pataca" = '(1, 1) +type instance I.Scale "MOP" "avo" = '(100, 1) +-- | Mauritanian ouguiya +type instance I.Scale "MRO" "MRO" = '(5, 1) +type instance I.Scale "MRO" "ouguiya" = '(1, 1) +type instance I.Scale "MRO" "khoums" = '(5, 1) +-- | Mauritian rupee +type instance I.Scale "MUR" "MUR" = '(100, 1) +type instance I.Scale "MUR" "rupee" = '(1, 1) +type instance I.Scale "MUR" "cent" = '(100, 1) +-- | Maldivian rufiyaa +type instance I.Scale "MVR" "MVR" = '(100, 1) +type instance I.Scale "MVR" "rufiyaa" = '(1, 1) +type instance I.Scale "MVR" "laari" = '(100, 1) +-- | Malawian kwacha +type instance I.Scale "MWK" "MWK" = '(100, 1) +type instance I.Scale "MWK" "kwacha" = '(1, 1) +type instance I.Scale "MWK" "tambala" = '(100, 1) +-- | Mexican peso +type instance I.Scale "MXN" "MXN" = '(100, 1) +type instance I.Scale "MXN" "peso" = '(1, 1) +type instance I.Scale "MXN" "centavo" = '(100, 1) +-- | Mexican unidad de inversion +type instance I.Scale "MXV" "MXV" = '(100, 1) +-- | Malaysian ringgit +type instance I.Scale "MYR" "MYR" = '(100, 1) +type instance I.Scale "MYR" "ringgit" = '(1, 1) +type instance I.Scale "MYR" "sen" = '(100, 1) +-- | Mozambican metical +type instance I.Scale "MZN" "MZN" = '(100, 1) +type instance I.Scale "MZN" "metical" = '(1, 1) +type instance I.Scale "MZN" "centavo" = '(100, 1) +-- | Namibian dollar +type instance I.Scale "NAD" "NAD" = '(100, 1) +type instance I.Scale "NAD" "dollar" = '(1, 1) +type instance I.Scale "NAD" "cent" = '(100, 1) +-- | Nigerian naira +type instance I.Scale "NGN" "NGN" = '(100, 1) +type instance I.Scale "NGN" "naira" = '(1, 1) +type instance I.Scale "NGN" "kobo" = '(100, 1) +-- | Nicaraguan cordoba +type instance I.Scale "NIO" "NIO" = '(100, 1) +type instance I.Scale "NIO" "cordoba" = '(1, 1) +type instance I.Scale "NIO" "centavo" = '(100, 1) +-- | Norwegian krone +type instance I.Scale "NOK" "NOK" = '(100, 1) +type instance I.Scale "NOK" "krone" = '(1, 1) +type instance I.Scale "NOK" "ore" = '(100, 1) +-- | Nepalese rupee +type instance I.Scale "NPR" "NPR" = '(100, 1) +type instance I.Scale "NPR" "rupee" = '(1, 1) +type instance I.Scale "NPR" "paisa" = '(100, 1) +-- | New Zealand dollar +type instance I.Scale "NZD" "NZD" = '(100, 1) +type instance I.Scale "NZD" "dollar" = '(1, 1) +type instance I.Scale "NZD" "cent" = '(100, 1) +-- | Omani rial +type instance I.Scale "OMR" "OMR" = '(1000, 1) +type instance I.Scale "OMR" "rial" = '(1, 1) +type instance I.Scale "OMR" "baisa" = '(1000, 1) +-- | Panamenian balboa +type instance I.Scale "PAB" "PAB" = '(100, 1) +type instance I.Scale "PAB" "balboa" = '(1, 1) +type instance I.Scale "PAB" "centesimo" = '(100, 1) +-- | Peruvian sol +type instance I.Scale "PEN" "PEN" = '(100, 1) +type instance I.Scale "PEN" "sol" = '(1, 1) +type instance I.Scale "PEN" "centimo" = '(100, 1) +-- | Papua New Guinean kina +type instance I.Scale "PGK" "PGK" = '(100, 1) +type instance I.Scale "PGK" "kina" = '(1, 1) +type instance I.Scale "PGK" "toea" = '(100, 1) +-- | Philippine peso +type instance I.Scale "PHP" "PHP" = '(100, 1) +type instance I.Scale "PHP" "peso" = '(1, 1) +type instance I.Scale "PHP" "centavo" = '(100, 1) +-- | Pakistani rupee +type instance I.Scale "PKR" "PKR" = '(100, 1) +type instance I.Scale "PKR" "rupee" = '(1, 1) +type instance I.Scale "PKR" "paisa" = '(100, 1) +-- | Polish zloty +type instance I.Scale "PLN" "PLN" = '(100, 1) +type instance I.Scale "PLN" "zloty" = '(1, 1) +type instance I.Scale "PLN" "grosz" = '(100, 1) +-- | Paraguayan guarani +type instance I.Scale "PYG" "PYG" = '(100, 1) +type instance I.Scale "PYG" "guarani" = '(1, 1) +type instance I.Scale "PYG" "centimo" = '(100, 1) +-- | Qatari riyal +type instance I.Scale "QAR" "QAR" = '(100, 1) +type instance I.Scale "QAR" "riyal" = '(1, 1) +type instance I.Scale "QAR" "dirham" = '(100, 1) +-- | Romanian leu +type instance I.Scale "RON" "RON" = '(100, 1) +type instance I.Scale "RON" "leu" = '(1, 1) +type instance I.Scale "RON" "ban" = '(100, 1) +-- | Serbian dinar +type instance I.Scale "RSD" "RSD" = '(100, 1) +type instance I.Scale "RSD" "dinar" = '(1, 1) +type instance I.Scale "RSD" "para" = '(100, 1) +-- | Russian ruble +type instance I.Scale "RUB" "RUB" = '(100, 1) +type instance I.Scale "RUB" "ruble" = '(1, 1) +type instance I.Scale "RUB" "kopek" = '(100, 1) +-- | Rwandan franc +type instance I.Scale "RWF" "RWF" = '(100, 1) +type instance I.Scale "RWF" "franc" = '(1, 1) +type instance I.Scale "RWF" "centime" = '(100, 1) +-- | Saudi Arabian riyal +type instance I.Scale "SAR" "SAR" = '(100, 1) +type instance I.Scale "SAR" "riyal" = '(1, 1) +type instance I.Scale "SAR" "halala" = '(100, 1) +-- | Solomon Islands dollar +type instance I.Scale "SBD" "SBD" = '(100, 1) +type instance I.Scale "SBD" "dollar" = '(100, 1) +type instance I.Scale "SBD" "cent" = '(100, 1) +-- | Seychellois rupee +type instance I.Scale "SCR" "SCR" = '(100, 1) +type instance I.Scale "SCR" "rupee" = '(1, 1) +type instance I.Scale "SCR" "cent" = '(100, 1) +-- | Sudanese pound +type instance I.Scale "SDG" "SDG" = '(100, 1) +type instance I.Scale "SDG" "pound" = '(1, 1) +type instance I.Scale "SDG" "piastre" = '(100, 1) +-- | Swedish krona +type instance I.Scale "SEK" "SEK" = '(100, 1) +type instance I.Scale "SEK" "krona" = '(1, 1) +type instance I.Scale "SEK" "ore" = '(100, 1) +-- | Singapore dollar +type instance I.Scale "SGD" "SGD" = '(100, 1) +type instance I.Scale "SGD" "dollar" = '(1, 1) +type instance I.Scale "SGD" "cent" = '(100, 1) +-- | Saint Helena pound +type instance I.Scale "SHP" "SHP" = '(100, 1) +type instance I.Scale "SHP" "pound" = '(1, 1) +type instance I.Scale "SHP" "penny" = '(100, 1) +-- | Sierra Leonean leone +type instance I.Scale "SLL" "SLL" = '(100, 1) +type instance I.Scale "SLL" "leone" = '(1, 1) +type instance I.Scale "SLL" "cent" = '(100, 1) +-- | Somali shilling +type instance I.Scale "SOS" "SOS" = '(100, 1) +type instance I.Scale "SOS" "shilling" = '(1, 1) +type instance I.Scale "SOS" "cent" = '(100, 1) +-- | Surinamese dollar +type instance I.Scale "SRD" "SRD" = '(100, 1) +type instance I.Scale "SRD" "dollar" = '(1, 1) +type instance I.Scale "SRD" "cent" = '(100, 1) +-- | South Sudanese pound +type instance I.Scale "SSP" "SSP" = '(100, 1) +type instance I.Scale "SSP" "pound" = '(1, 1) +type instance I.Scale "SSP" "piastre" = '(100, 1) +-- | Sao Tome and Principe dobra +type instance I.Scale "STD" "STD" = '(100, 1) +type instance I.Scale "STD" "dobra" = '(1, 1) +type instance I.Scale "STD" "centimo" = '(100, 1) +-- | Salvadoran colon +type instance I.Scale "SVC" "SVC" = '(100, 1) +type instance I.Scale "SVC" "colon" = '(1, 1) +type instance I.Scale "SVC" "centavo" = '(100, 1) +-- | Syrian pound +type instance I.Scale "SYP" "SYP" = '(100, 1) +type instance I.Scale "SYP" "pound" = '(1, 1) +type instance I.Scale "SYP" "piastre" = '(100, 1) +-- | Swazi lilangeni +type instance I.Scale "SZL" "SZL" = '(100, 1) +type instance I.Scale "SZL" "lilangeni" = '(1, 1) +type instance I.Scale "SZL" "cent" = '(100, 1) +-- | Thai baht +type instance I.Scale "THB" "THB" = '(100, 1) +type instance I.Scale "THB" "baht" = '(1, 1) +type instance I.Scale "THB" "satang" = '(100, 1) +-- | Tajikistani somoni +type instance I.Scale "TJS" "TJS" = '(100, 1) +type instance I.Scale "TJS" "somoni" = '(1, 1) +type instance I.Scale "TJS" "diram" = '(100, 1) +-- | Turkmen manat +type instance I.Scale "TMT" "TMT" = '(100, 1) +type instance I.Scale "TMT" "manat" = '(1, 1) +type instance I.Scale "TMT" "tennesi" = '(100, 1) +-- | Tunisian dinar +type instance I.Scale "TND" "TND" = '(1000, 1) +type instance I.Scale "TND" "dinar" = '(1, 1) +type instance I.Scale "TND" "millime" = '(1000, 1) +-- | Tongan pa’anga +type instance I.Scale "TOP" "TOP" = '(100, 1) +type instance I.Scale "TOP" "pa'anga" = '(1, 1) +type instance I.Scale "TOP" "seniti" = '(100, 1) +-- | Turkish lira +type instance I.Scale "TRY" "TRY" = '(100, 1) +type instance I.Scale "TRY" "lira" = '(1, 1) +type instance I.Scale "TRY" "kurus" = '(100, 1) +-- | Tobago Trinidad and Tobago dollar +type instance I.Scale "TTD" "TTD" = '(100, 1) +type instance I.Scale "TTD" "dollar" = '(1, 1) +type instance I.Scale "TTD" "cent" = '(100, 1) +-- | New Taiwan dollar +type instance I.Scale "TWD" "TWD" = '(100, 1) +type instance I.Scale "TWD" "dollar" = '(1, 1) +type instance I.Scale "TWD" "cent" = '(100, 1) +-- | Tanzanian shilling +type instance I.Scale "TZS" "TZS" = '(100, 1) +type instance I.Scale "TZS" "shilling" = '(1, 1) +type instance I.Scale "TZS" "cent" = '(100, 1) +-- | Ukrainian hryvnia +type instance I.Scale "UAH" "UAH" = '(100, 1) +type instance I.Scale "UAH" "hryvnia" = '(1, 1) +type instance I.Scale "UAH" "kopiyka" = '(100, 1) +-- | Ugandan shilling +type instance I.Scale "UGX" "UGX" = '(100, 1) +type instance I.Scale "UGX" "shilling" = '(1, 1) +type instance I.Scale "UGX" "cent" = '(100, 1) +-- | United States dollar +type instance I.Scale "USD" "USD" = '(100, 1) +type instance I.Scale "USD" "dollar" = '(1, 1) +type instance I.Scale "USD" "cent" = '(100, 1) +-- | United States dollar (next day) +type instance I.Scale "USN" "USN" = '(100, 1) +-- | Uruguayan peso en unidades +type instance I.Scale "UYI" "UYI" = '(100, 1) +-- | Uruguayan peso +type instance I.Scale "UYU" "UYU" = '(100, 1) +type instance I.Scale "UYU" "peso" = '(1, 1) +type instance I.Scale "UYU" "centesimo" = '(100, 1) +-- | Uzbekistani som +type instance I.Scale "UZS" "UZS" = '(100, 1) +type instance I.Scale "UZS" "som" = '(1, 1) +type instance I.Scale "UZS" "tiyin" = '(100, 1) +-- | Venezuelan bolivar +type instance I.Scale "VEF" "VEF" = '(100, 1) +type instance I.Scale "VEF" "bolivar" = '(1, 1) +type instance I.Scale "VEF" "centimo" = '(100, 1) +-- | Vietnamese dong +type instance I.Scale "VND" "VND" = '(10, 1) +type instance I.Scale "VND" "dong" = '(1, 1) +type instance I.Scale "VND" "hao" = '(10, 1) +-- | Vanuatu vatu +type instance I.Scale "VUV" "VUV" = '(1, 1) +type instance I.Scale "VUV" "vatu" = '(1, 1) +-- | Samoan tālā +type instance I.Scale "WST" "WST" = '(100, 1) +type instance I.Scale "WST" "tala" = '(1, 1) +type instance I.Scale "WST" "sene" = '(100, 1) +-- | Central African CFA franc +type instance I.Scale "XAF" "XAF" = '(100, 1) +type instance I.Scale "XAF" "franc" = '(1, 1) +type instance I.Scale "XAF" "centime" = '(100, 1) +-- | East Caribbean dollar +type instance I.Scale "XCD" "XCD" = '(100, 1) +type instance I.Scale "XCD" "dollar" = '(1, 1) +type instance I.Scale "XCD" "cent" = '(100, 1) +-- | International Monetary Fund Special Drawing Right +type instance I.Scale "XDR" "XDR" = '(100, 1) +-- | West African CFA franc +type instance I.Scale "XOF" "XOF" = '(100, 1) +type instance I.Scale "XOF" "franc" = '(1, 1) +type instance I.Scale "XOF" "centime" = '(100, 1) +-- | CFP franc +type instance I.Scale "XPF" "XPF" = '(100, 1) +type instance I.Scale "XPF" "franc" = '(1, 1) +type instance I.Scale "XPF" "centime" = '(100, 1) +-- | Sucre +type instance I.Scale "XSU" "XSU" = '(100, 1) +-- | African Development Bank unit of account +type instance I.Scale "XUA" "XUA" = '(100, 1) +-- | Yemeni rial +type instance I.Scale "YER" "YER" = '(100, 1) +type instance I.Scale "YER" "rial" = '(1, 1) +type instance I.Scale "YER" "fils" = '(100, 1) +-- | South African rand +type instance I.Scale "ZAR" "ZAR" = '(100, 1) +type instance I.Scale "ZAR" "rand" = '(1, 1) +type instance I.Scale "ZAR" "cent" = '(100, 1) +-- | Zambian kwacha +type instance I.Scale "ZMW" "ZMW" = '(100, 1) +type instance I.Scale "ZMW" "kwacha" = '(1, 1) +type instance I.Scale "ZMW" "ngwee" = '(100, 1) +-- | Zimbawe dollar +type instance I.Scale "ZWL" "ZWL" = '(100, 1) +type instance I.Scale "ZWL" "dollar" = '(1, 1) +type instance I.Scale "ZWL" "cent" = '(100, 1) + +-- | Gold +type instance I.Scale "XAU" "XAU" = I.ErrScaleNonCanonical "XAU" +type instance I.Scale "XAU" "troy-ounce" = '(1, 1) +type instance I.Scale "XAU" "grain" = '(480, 1) +type instance I.Scale "XAU" "milligrain" = '(480000, 1) +type instance I.Scale "XAU" "micrograin" = '(480000000, 1) +type instance I.Scale "XAU" "kilogram" = '(31103477, 1000000000) +type instance I.Scale "XAU" "gram" = '(31103477, 1000000) +type instance I.Scale "XAU" "milligram" = '(31103477, 1000) +type instance I.Scale "XAU" "microgram" = '(31103477, 1) + +-- | Silver +type instance I.Scale "XAG" "XAG" = I.ErrScaleNonCanonical "XAG" +type instance I.Scale "XAG" "troy-ounce" = '(1, 1) +type instance I.Scale "XAG" "grain" = '(480, 1) +type instance I.Scale "XAG" "milligrain" = '(480000, 1) +type instance I.Scale "XAG" "micrograin" = '(480000000, 1) +type instance I.Scale "XAG" "kilogram" = '(31103477, 1000000000) +type instance I.Scale "XAG" "gram" = '(31103477, 1000000) +type instance I.Scale "XAG" "milligram" = '(31103477, 1000) +type instance I.Scale "XAG" "microgram" = '(31103477, 1) + +-- | Palladium +type instance I.Scale "XPD" "XPD" = I.ErrScaleNonCanonical "XPD" +type instance I.Scale "XPD" "troy-ounce" = '(1, 1) +type instance I.Scale "XPD" "grain" = '(480, 1) +type instance I.Scale "XPD" "milligrain" = '(480000, 1) +type instance I.Scale "XPD" "micrograin" = '(480000000, 1) +type instance I.Scale "XPD" "kilogram" = '(31103477, 1000000000) +type instance I.Scale "XPD" "gram" = '(31103477, 1000000) +type instance I.Scale "XPD" "milligram" = '(31103477, 1000) +type instance I.Scale "XPD" "microgram" = '(31103477, 1) + +-- | Platinum +type instance I.Scale "XPT" "XPT" = I.ErrScaleNonCanonical "XPT" +type instance I.Scale "XPT" "troy-ounce" = '(1, 1) +type instance I.Scale "XPT" "grain" = '(480, 1) +type instance I.Scale "XPT" "milligrain" = '(480000, 1) +type instance I.Scale "XPT" "micrograin" = '(480000000, 1) +type instance I.Scale "XPT" "kilogram" = '(31103477, 1000000000) +type instance I.Scale "XPT" "gram" = '(31103477, 1000000) +type instance I.Scale "XPT" "milligram" = '(31103477, 1000) +type instance I.Scale "XPT" "microgram" = '(31103477, 1) + +-- | Bitcoin +type instance I.Scale "BTC" "BTC" = '(100000000, 1) +type instance I.Scale "BTC" "bitcoin" = '(1, 1) +type instance I.Scale "BTC" "satoshi" = '(100000000, 1) + +-- | Bitcoin +type instance I.Scale "XBT" "XBT" = '(100000000, 1) +type instance I.Scale "XBT" "bitcoin" = '(1, 1) +type instance I.Scale "XBT" "satoshi" = '(100000000, 1) + +-- | Ether +type instance I.Scale "ETH" "ETH" = '(1000000000000000000, 1) +type instance I.Scale "ETH" "ether" = '(1, 1) +type instance I.Scale "ETH" "kwei" = '(1000, 1) +type instance I.Scale "ETH" "babbage" = '(1000, 1) +type instance I.Scale "ETH" "mwei" = '(1000000, 1) +type instance I.Scale "ETH" "lovelace" = '(1000000, 1) +type instance I.Scale "ETH" "gwei" = '(1000000000, 1) +type instance I.Scale "ETH" "shannon" = '(1000000000, 1) +type instance I.Scale "ETH" "microether" = '(1000000000000, 1) +type instance I.Scale "ETH" "szabo" = '(1000000000000, 1) +type instance I.Scale "ETH" "finney" = '(1000000000000000, 1) +type instance I.Scale "ETH" "milliether" = '(1000000000000000, 1) +type instance I.Scale "ETH" "wei" = '(1000000000000000000, 1) diff --git a/src/Data/Money/Internal.hs b/src/Data/Money/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Money/Internal.hs @@ -0,0 +1,1100 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | This is an internal module. Import "Data.Money" instead. +module Data.Money.Internal + ( -- * Dense monetary values + Dense + , dense + -- * Discrete monetary values + , Discrete + , Discrete' + , fromDiscrete + , round + , ceiling + , floor + , truncate + -- * Currency scales + , Scale + , GoodScale + , ErrScaleNonCanonical + , scale + -- * Currency exchange + , ExchangeRate + , exchangeRate + , fromExchangeRate + , flipExchangeRate + , exchange + -- * Serializable representations + , DenseRep + , denseRep + , denseRepCurrency + , denseRepAmount + , denseRepAmountNumerator + , denseRepAmountDenominator + , mkDenseRep + , fromDenseRep + , withDenseRep + , DiscreteRep + , discreteRep + , discreteRepCurrency + , discreteRepScale + , discreteRepScaleNumerator + , discreteRepScaleDenominator + , discreteRepAmount + , mkDiscreteRep + , fromDiscreteRep + , withDiscreteRep + , ExchangeRateRep + , exchangeRateRep + , exchangeRateRepSrcCurrency + , exchangeRateRepDstCurrency + , exchangeRateRepRate + , exchangeRateRepRateNumerator + , exchangeRateRepRateDenominator + , mkExchangeRateRep + , fromExchangeRateRep + , withExchangeRateRep + ) where + +import Control.Applicative (empty) +import Control.Monad ((<=<)) +import Data.Constraint (Dict(Dict)) +import Data.Proxy (Proxy(..)) +import Data.Ratio ((%), numerator, denominator) +import qualified GHC.Generics as GHC +import GHC.Real (infinity, notANumber) +import GHC.TypeLits + (Symbol, SomeSymbol(..), Nat, SomeNat(..), CmpNat, KnownSymbol, KnownNat, + natVal, someNatVal, symbolVal, someSymbolVal) +import qualified GHC.TypeLits as GHC +import Prelude hiding (round, ceiling, floor, truncate) +import qualified Prelude +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.ParserCombinators.ReadP as ReadP +import Text.Read (readPrec) +import Unsafe.Coerce (unsafeCoerce) + +#ifdef VERSION_aeson +import qualified Data.Aeson as Ae +#endif + +#ifdef VERSION_binary +import qualified Data.Binary as Binary +#endif + +#ifdef VERSION_cereal +import qualified Data.Serialize as Cereal +#endif + +#ifdef VERSION_deepseq +import Control.DeepSeq (NFData) +#endif + +#ifdef VERSION_hashable +import Data.Hashable (Hashable) +#endif + +#ifdef VERSION_store +import qualified Data.Store as Store +#endif + +-------------------------------------------------------------------------------- +-- | 'Dense' represents a dense monetary value for @currency@ (usually a +-- ISO-4217 currency code, but not necessarily) as a rational number. +-- +-- While monetary values associated with a particular currency are discrete, you +-- can still treat monetary values as dense while operating on them. For +-- example, the half of @USD 3.41@ is @USD 1.705@, which is not an amount that +-- can't be represented as a number of USD cents (the smallest unit that can +-- represent USD amounts). Nevertheless, if you eventually multiply @USD 1.705@ +-- by @4@, for example, you end up with @USD 6.82@, which is again a value +-- representable as USD cents. In other words, 'Dense' monetary values +-- allow us to perform precise calculations deferring the conversion to a +-- 'Discrete' monetary values as much as posible. Once you are ready to +-- aproximate a 'Dense' value to a 'Discrete' value you can use one of +-- 'round', 'floor', 'ceiling' or 'truncate'. Otherwise, using 'toRational' you +-- can obtain a precise 'Rational' representation. +-- +-- Construct 'Dense' monetary values using 'dense', or +-- 'fromInteger' / 'fromIntegral' if that suffices. +-- +-- /WARNING/ if you want to treat a dense monetary value as a /Real/ number (for +-- example, to take the square root of that monetary value), then you are on +-- your own. We can only guarantee lossless manipulation of rational values, so +-- you will need to convert back and forth betwen the 'Rational' representation +-- for 'Dense' and your (likely lossy) representation for /Real/ numbers. +newtype Dense (currency :: Symbol) = Dense Rational + deriving (Eq, Ord, Num, Real, Fractional, GHC.Generic) + +instance forall currency. KnownSymbol currency => Show (Dense currency) where + show = \(Dense r0) -> + let c = symbolVal (Proxy :: Proxy currency) + in concat [ "Dense ", show c, " (", show r0, ")" ] + +instance forall currency. KnownSymbol currency => Read (Dense currency) where + readPrec = do + let c = symbolVal (Proxy :: Proxy currency) + _ <- ReadPrec.lift (ReadP.string ("Dense " ++ show c ++ " ")) + maybe empty pure =<< fmap dense readPrec + +-- | Build a 'Dense' monetary value from a 'Rational' value. +-- +-- For example, if you want to represent @USD 12.52316@, then you can use: +-- +-- @ +-- 'dense' (125316 % 10000) +-- @ +-- +-- This function returns 'Nothing' in case the given 'Rational' is 'infinity' or +-- 'notANumber'. +dense :: Rational -> Maybe (Dense currency) +dense = \r0 -> + if (infinity == r0 || notANumber == r0) + then Nothing else Just (Dense r0) +{-# INLINE dense #-} + +-- | 'Discrete' represents a discrete monetary value for a @currency@ expresed +-- as an integer amount of a particular @unit@. For example, with @currency ~ +-- \"USD\"@ and @unit ~ \"cent\"@ you can represent United States Dollars to +-- their full extent. +-- +-- @currency@ is usually a ISO-4217 currency code, but not necessarily. +-- +-- Construct 'Discrete' values using 'fromInteger'. +-- +-- For example, if you want to represent @GBP 21.05@, where the smallest +-- represetable unit for a GBP (United Kingdom Pound) is the /penny/, and 100 +-- /pennies/ equal 1 GBP (i.e., @'Scale' \"GBP\" ~ '(100, 1)@), then you can +-- use: +-- +-- @ +-- 'fromInteger' 2105 :: Discrete \"GBP\" \"penny\" +-- @ +-- +-- Because @2015 / 100 == 20.15@. +type Discrete (currency :: Symbol) (unit :: Symbol) + = Discrete' currency (Scale currency unit) + +-- | 'Discrete'' represents a discrete monetary value for a @currency@ expresed +-- as an amount of @scale@, which is a rational number expressed as @(numerator, +-- denominator)@. +-- +-- You'll be using 'Discrete' instead of 'Discrete'' most of the time, which +-- mentions the unit name (such as /cent/ or /centavo/) instead of explicitely +-- mentioning the unit scale. +newtype Discrete' (currency :: Symbol) (scale :: (Nat, Nat)) + = Discrete Integer + deriving (Eq, Ord, Enum, Num, Real, Integral, GHC.Generic) + +instance forall currency scale. + ( KnownSymbol currency, GoodScale scale + ) => Show (Discrete' currency scale) where + show = \d0@(Discrete i0) -> + let c = symbolVal (Proxy :: Proxy currency) + in concat [ "Discrete ", show c, " (", show (scale d0), ") ", show i0 ] + +instance forall currency scale. + ( KnownSymbol currency, GoodScale scale + ) => Read (Discrete' currency scale) where + readPrec = do + let c = symbolVal (Proxy :: Proxy currency) + s = scale (Proxy :: Proxy scale) + _ <- ReadPrec.lift (ReadP.string + ("Discrete " ++ show c ++ " (" ++ show s ++ ") ") ) + Discrete <$> readPrec + +instance + ( GHC.TypeError + (('GHC.Text "The ") 'GHC.:<>: + ('GHC.ShowType Discrete') 'GHC.:<>: + ('GHC.Text " type is deliberately not a ") 'GHC.:<>: + ('GHC.ShowType Fractional) 'GHC.:$$: + ('GHC.Text "instance. Convert the ") 'GHC.:<>: + ('GHC.ShowType Discrete') 'GHC.:<>: + ('GHC.Text " value to a ") 'GHC.:<>: + ('GHC.ShowType Dense) 'GHC.:$$: + ('GHC.Text "value and use the ") 'GHC.:<>: + ('GHC.ShowType Fractional) 'GHC.:<>: + ('GHC.Text " features on it instead.")) ) + => Fractional (Discrete' currency scale) where + fromRational = undefined + recip = undefined + +-- | Convert currency 'Discrete' monetary value into a 'Dense' monetary +-- value. +fromDiscrete + :: GoodScale scale + => Discrete' currency scale + -> Dense currency -- ^ +fromDiscrete = \c@(Discrete i) -> Dense (fromInteger i / scale c) +{-# INLINE fromDiscrete #-} + +-- | Internal. Used to implement 'round', 'ceiling', 'floor' and 'truncate'. +roundf + :: GoodScale scale + => (Rational -> Integer) -- ^ 'Prelude.round', 'Prelude.ceiling' or similar. + -> Dense currency + -> (Discrete' currency scale, Maybe (Dense currency)) +roundf f = \c0 -> + let !r0 = toRational c0 :: Rational + !i2 = f (r0 * scale d2) :: Integer + !r2 = fromInteger i2 / scale d2 :: Rational + !ycrest | r0 == r2 = Nothing + | otherwise = Just (Dense (r0 - r2)) + !d2 = Discrete i2 + in (d2, ycrest) +{-# INLINE roundf #-} + +-- | Round a 'Dense' value @x@ to the nearest value fully representable in +-- its @currency@'s @unit@ 'Scale', which might be @x@ itself. +-- +-- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', +-- then the following holds: +-- +-- @ +-- 'round' x == (x, 'Nothing') +-- @ +-- +-- Otherwise, if the nearest value to @x@ that is fully representable in its +-- @currency@'s @unit@ 'Scale' is greater than @x@, then the following holds: +-- +-- @ +-- 'round' == 'ceiling' +-- @ +-- +-- Otherwise, the nearest value to @x@ that is fully representable in its +-- @currency@'s @unit@ 'Scale' is smaller than @x@, and the following holds: +-- +-- @ +-- 'round' == 'floor' +-- @ +-- +-- Proof that 'round' doesn't lose money: +-- +-- @ +-- x == case 'round' x of +-- (y, 'Nothing') -> y +-- (y, 'Just' z) -> y + z +-- @ +round + :: GoodScale scale + => Dense currency + -> (Discrete' currency scale, Maybe (Dense currency)) -- ^ +round = roundf Prelude.round +{-# INLINE round #-} + +-- | Round a 'Dense' value @x@ to the nearest value fully representable in +-- its @currency@'s @unit@ 'Scale' which is greater than @x@ or equal to @x@. +-- +-- +-- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', +-- then the following holds: +-- +-- @ +-- 'ceiling' x == (x, 'Nothing') +-- @ +-- +-- Otherwise, if @x@ is not representable in its @currency@'s @unit@ 'Scale', +-- then the following holds: +-- +-- @ +-- 'ceiling' x == (y, 'Just' z) +-- @ +-- +-- @ +-- x /= y +-- @ +-- +-- @ +-- z < 'zero' +-- @ +-- +-- Proof that 'ceiling' doesn't lose money: +-- +-- @ +-- x == case 'ceiling' x of +-- (y, 'Nothing') -> y +-- (y, 'Just' z) -> y + z +-- @ +ceiling + :: GoodScale scale + => Dense currency + -> (Discrete' currency scale, Maybe (Dense currency)) -- ^ +ceiling = roundf Prelude.ceiling +{-# INLINE ceiling #-} + +-- | Round a 'Dense' value @x@ to the nearest value fully representable in +-- its @currency@'s @unit@ 'Scale' which is smaller than @x@ or equal to @x@. +-- +-- +-- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', +-- then the following holds: +-- +-- @ +-- 'floor' x == (x, 'Nothing') +-- @ +-- +-- Otherwise, if @x@ is not representable in its @currency@'s @unit@ 'Scale', +-- then the following holds: +-- +-- @ +-- 'floor' x == (y, 'Just' z) +-- @ +-- +-- @ +-- x /= y +-- @ +-- +-- @ +-- z > 'zero' +-- @ +-- +-- Proof that 'floor' doesn't lose money: +-- +-- @ +-- x == case 'floor' x of +-- (y, 'Nothing') -> y +-- (y, 'Just' z) -> y + z +-- @ +floor + :: GoodScale scale + => Dense currency + -> (Discrete' currency scale, Maybe (Dense currency)) -- ^ +floor = roundf Prelude.floor +{-# INLINE floor #-} + +-- | Round a 'Dense' value @x@ to the nearest value between zero and +-- @x@ (inclusive) which is fully representable in its @currency@'s @unit@ +-- 'Scale'. +-- +-- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', +-- then the following holds: +-- +-- @ +-- 'truncate' x == (x, 'Nothing') +-- @ +-- +-- Otherwise, if @x@ is positive, then the following holds: +-- +-- @ +-- 'truncate' == 'floor' +-- @ +-- +-- Otherwise, if @x@ is negative, the following holds: +-- +-- @ +-- 'truncate' == 'ceiling' +-- @ +-- +-- Proof that 'truncate' doesn't lose money: +-- +-- @ +-- x == case 'truncate' x of +-- (y, 'Nothing') -> y +-- (y, 'Just' z) -> y + z +-- @ +truncate + :: GoodScale scale + => Dense currency + -> (Discrete' currency scale, Maybe (Dense currency)) -- ^ +truncate = roundf Prelude.truncate +{-# INLINE truncate #-} + +-------------------------------------------------------------------------------- + +-- | @'Scale' currency unit@ is a rational number (expressed as @'(numerator, +-- denominator)@) indicating how many pieces of @unit@ fit in @currency@. +-- +-- @currency@ is usually a ISO-4217 currency code, but not necessarily. +-- +-- The 'Scale' will determine how to convert a 'Dense' value into a +-- 'Discrete' value and vice-versa. +-- +-- For example, there are 100 USD cents in 1 USD, so the scale for this +-- relationship is: +-- +-- @ +-- type instance 'Scale' \"USD\" \"cent\" = '(100, 1) +-- @ +-- +-- As another example, there is 1 dollar in USD, so the scale for this +-- relationship is: +-- +-- @ +-- type instance 'Scale' \"USD\" \"dollar\" = '(1, 1) +-- @ +-- +-- When using 'Discrete' values to represent money, it will be impossible to +-- represent an amount of @currency@ smaller than @unit@. So, if you decide to +-- use @Scale \"USD\" \"dollar\"@ as your scale, you will not be able to +-- represent values such as USD 3.50 or USD 21.87, since they are not exact +-- multiples of a dollar. +-- +-- If there exists a cannonical smallest @unit@ that can fully represent the +-- currency, then an instance @'Scale' currency currency@ exists. +-- +-- @ +-- type instance 'Scale' \"USD\" \"USD\" = Scale \"USD\" \"cent\" +-- @ +-- +-- For some monetary values, such as precious metals, the smallest representable +-- unit is not obvious, since you can continue to split the precious metal many +-- times before it stops being a precious metal. Still, for practical purposes +-- we can make a sane arbitrary choice of smallest unit. For example, the base +-- unit for XAU (Gold) is the /troy ounce/, which is too big to be considered +-- the smallest unit, but we can arbitrarily choose the /milligrain/ as our +-- smallest unit, which is about as heavy as a single grain of table salt and +-- should be sufficiently precise for all monetary practical purposes. A /troy +-- ounce/ equals 480000 /milligrains/. +-- +-- @ +-- type instance 'Scale' \"XAG\" \"milligrain\" = '(480000, 1) +-- @ +-- +-- You can use other units such as /milligrams/ for measuring XAU, for example. +-- However, since the amount of /milligrams/ in a /troy ounce/ (31103.477) is +-- not integral, we need to use rational number to express it. +-- +-- @ +-- type instance 'Scale' \"XAU\" \"milligram\" = '(31103477, 1000) +-- @ +-- +-- If you try to obtain the 'Scale of a @currency@ without an obvious smallest +-- representable @unit@, like XAU, you will get a compile error. +type family Scale (currency :: Symbol) (unit :: Symbol) :: (Nat, Nat) + +-- | A friendly 'GHC.TypeError' to use for a @currency@ that doesn't have a +-- cannonical small unit. +type family ErrScaleNonCanonical (currency :: Symbol) :: k where + ErrScaleNonCanonical c = GHC.TypeError + ( 'GHC.Text c 'GHC.:<>: + 'GHC.Text " is not a currency with a canonical smallest unit," 'GHC.:$$: + 'GHC.Text "be explicit about the currency unit you want to use." ) + +-- | Constraints to a scale (like the one returned by @'Scale' currency unit@) +-- expected to always be satisfied. In particular, the scale is always +-- guaranteed to be a positive rational number ('infinity' and 'notANumber' are +-- forbidden by 'GoodScale'). +type GoodScale (scale :: (Nat, Nat)) + = ( CmpNat 0 (Fst scale) ~ 'LT + , CmpNat 0 (Snd scale) ~ 'LT + , KnownNat (Fst scale) + , KnownNat (Snd scale) + ) + +-- | If the specified @num@ and @den@ satisfy the expectations of 'GoodScale' at +-- the type level, then construct a proof for 'GoodScale'. +mkGoodScale + :: forall num den + . (KnownNat num, KnownNat den) + => Maybe (Dict (GoodScale '(num, den))) +mkGoodScale = + let n = natVal (Proxy :: Proxy num) + d = natVal (Proxy :: Proxy den) + in if (n > 0) && (d > 0) + then Just (unsafeCoerce (Dict :: Dict ('LT ~ 'LT, 'LT ~ 'LT, + KnownNat num, KnownNat den))) + else Nothing +{-# INLINE mkGoodScale #-} + +-- | Term-level representation for the @currency@'s @unit@ 'Scale'. +-- +-- For example, the 'Scale' for @\"USD\"@ in @\"cent\"@s is @100/1@. +-- +-- The returned 'Rational' is statically guaranteed to be a positive number, and +-- to be different from both 'notANumber' and 'infinity'. +scale :: forall proxy scale. GoodScale scale => proxy scale -> Rational -- ^ +scale = \_ -> + natVal (Proxy :: Proxy (Fst scale)) % + natVal (Proxy :: Proxy (Snd scale)) +{-# INLINE scale #-} + +-------------------------------------------------------------------------------- + +-- | Exchange rate for converting monetary values of currency @src@ into +-- monetary values of currency @dst@ by multiplying for it. +-- +-- For example, if in order to convert USD to GBP we have to multiply by 1.2345, +-- then we can represent this situaion using: +-- +-- @ +-- 'exchangeRate' (12345 % 10000) :: 'Maybe' ('ExchangeRate' \"USD\" \"GBP\") +-- @ +newtype ExchangeRate (src :: Symbol) (dst :: Symbol) = ExchangeRate Rational + deriving (Eq, Ord, GHC.Generic) + +instance forall src dst. + ( KnownSymbol src, KnownSymbol dst + ) => Show (ExchangeRate src dst) where + show = \(ExchangeRate r0) -> + let s = symbolVal (Proxy :: Proxy src) + d = symbolVal (Proxy :: Proxy dst) + in concat [ "ExchangeRate ", show s, " ", show d, " (", show r0, ")" ] + +instance forall src dst. + ( KnownSymbol src, KnownSymbol dst + ) => Read (ExchangeRate (src :: Symbol) (dst :: Symbol)) where + readPrec = do + let s = symbolVal (Proxy :: Proxy src) + d = symbolVal (Proxy :: Proxy dst) + _ <- ReadPrec.lift (ReadP.string + ("ExchangeRate " ++ show s ++ " " ++ show d ++ " ")) + maybe empty pure =<< fmap exchangeRate readPrec + +-- | Obtain a 'Rational' representation of the 'ExchangeRate'. +-- +-- This 'Rational' is statically guaranteed to be greater than 0, different +-- from 'infinity' and different from 'notANumber'. +fromExchangeRate :: ExchangeRate src dst -> Rational +fromExchangeRate = \(ExchangeRate r0) -> r0 +{-# INLINE fromExchangeRate #-} + +-- | Safely construct an 'ExchangeRate' from a 'Rational' number. +-- +-- For construction to succeed, this 'Rational' must be greater than 0, +-- different from 'infinity' and different from 'notANumber'. +exchangeRate :: Rational -> Maybe (ExchangeRate src dst) +exchangeRate = \r0 -> + if (r0 <= 0 || infinity == r0 || notANumber == r0) + then Nothing else Just (ExchangeRate r0) +{-# INLINE exchangeRate #-} + +-- | Flip the direction of an 'ExchangeRate'. +-- +-- Identity law: +-- +-- @ +-- 'flipExchangeRate' . 'flipExchangeRate' == 'id' +-- @ +flipExchangeRate :: ExchangeRate a b -> ExchangeRate b a +flipExchangeRate = \(ExchangeRate x) -> ExchangeRate (1 / x) +{-# INLINE flipExchangeRate #-} + +-- | Apply the 'ExchangeRate' to the given @'Dense' src@ monetary value. +-- +-- Identity law: +-- +-- @ +-- 'exchange' ('flipExchangeRate' x) . 'exchange' x == 'id' +-- @ +-- +-- Use the /Identity law/ for reasoning about going back and forth between @src@ +-- and @dst@ in order to manage any leftovers that might not be representable as +-- a 'Discrete' monetary value of @src@. +exchange :: ExchangeRate src dst -> Dense src -> Dense dst +exchange = \(ExchangeRate r) -> \(Dense s) -> Dense (r * s) +{-# INLINE exchange #-} + +-------------------------------------------------------------------------------- +-- DenseRep + +-- | A monomorphic representation of 'Dense' that is easier to serialize and +-- deserialize than 'Dense' in case you don't know the type indexes involved. +data DenseRep = DenseRep + { _denseRepCurrency :: !String + , _denseRepAmountNumerator :: !Integer + , _denseRepAmountDenominator :: !Integer -- ^ Positive, non-zero. + } deriving (Eq, Show, GHC.Generic) + +-- | WARNING: This instance does not compare monetary amounts, it just helps you +-- sort 'DenseRep' values in case you need to put them in a 'Data.Set.Set' or +-- similar. +deriving instance Ord DenseRep + +-- | Currency name. +denseRepCurrency :: DenseRep -> String +denseRepCurrency = _denseRepCurrency +{-# INLINE denseRepCurrency #-} + +-- | Currency unit amount. +denseRepAmount :: DenseRep -> Rational +denseRepAmount = \dr -> + denseRepAmountNumerator dr % denseRepAmountDenominator dr +{-# INLINE denseRepAmount #-} + +-- | Currency unit amount numerator. +denseRepAmountNumerator :: DenseRep -> Integer +denseRepAmountNumerator = _denseRepAmountNumerator +{-# INLINE denseRepAmountNumerator #-} + +-- | Currency unit amount denominator. Positive, non-zero. +denseRepAmountDenominator :: DenseRep -> Integer +denseRepAmountDenominator = _denseRepAmountDenominator +{-# INLINE denseRepAmountDenominator #-} + +-- | Internal. Build a 'DenseRep' from raw values. +mkDenseRep + :: String -- ^ Currency. + -> Integer -- ^ Scale nominator. + -> Integer -- ^ Scale denominator (positive, non zero) + -> Maybe DenseRep +mkDenseRep = \c n d -> case d > 0 of + False -> Nothing + True -> Just (DenseRep c n d) +{-# INLINE mkDenseRep #-} + +-- | Convert a 'Dense' to a 'DenseRep' for ease of serialization. +denseRep :: KnownSymbol currency => Dense currency -> DenseRep +denseRep = \(Dense r0 :: Dense currency) -> + let c = symbolVal (Proxy :: Proxy currency) + in DenseRep c (numerator r0) (denominator r0) +{-# INLINE denseRep #-} + +-- | Attempt to convert a 'DenseRep' to a 'Dense', provided you know the target +-- @currency@. +fromDenseRep + :: forall currency + . KnownSymbol currency + => DenseRep + -> Maybe (Dense currency) -- ^ +fromDenseRep = \dr -> + case denseRepCurrency dr == symbolVal (Proxy :: Proxy currency) of + False -> Nothing + True -> Just (Dense (denseRepAmount dr)) +{-# INLINE fromDenseRep #-} + +-- | Convert a 'DenseRep' to a 'Dense' without knowing the target @currency@. +-- +-- Notice that @currency@ here can't leave its intended scope unless you can +-- prove equality with some other type at the outer scope, but in that case you +-- would be better off using 'fromDenseRep' directly. +withDenseRep + :: DenseRep + -> (forall currency. KnownSymbol currency => Dense currency -> r) + -> r -- ^ +withDenseRep dr = \f -> + case someSymbolVal (denseRepCurrency dr) of + SomeSymbol (Proxy :: Proxy currency) -> + f (Dense (denseRepAmount dr) :: Dense currency) +{-# INLINE withDenseRep #-} + +-------------------------------------------------------------------------------- +-- DiscreteRep + +-- | A monomorphic representation of 'Discrete' that is easier to serialize and +-- deserialize than 'Discrete' in case you don't know the type indexes involved. +data DiscreteRep = DiscreteRep + { _discreteRepCurrency :: !String -- ^ Currency name. + , _discreteRepScaleNumerator :: !Integer -- ^ Positive, non-zero. + , _discreteRepScaleDenominator :: !Integer -- ^ Positive, non-zero. + , _discreteRepAmount :: !Integer -- ^ Amount of unit. + } deriving (Eq, Show, GHC.Generic) + +-- | WARNING: This instance does not compare monetary amounts, it just helps you +-- sort 'DiscreteRep' values in case you need to put them in a 'Data.Set.Set' or +-- similar. +deriving instance Ord DiscreteRep + +-- | Currency name. +discreteRepCurrency :: DiscreteRep -> String +discreteRepCurrency = _discreteRepCurrency +{-# INLINE discreteRepCurrency #-} + +-- | Positive, non-zero. +discreteRepScale :: DiscreteRep -> Rational +discreteRepScale = \dr -> + discreteRepScaleNumerator dr % discreteRepScaleDenominator dr +{-# INLINE discreteRepScale #-} + +-- | Positive, non-zero. +discreteRepScaleNumerator :: DiscreteRep -> Integer +discreteRepScaleNumerator = _discreteRepScaleNumerator +{-# INLINE discreteRepScaleNumerator #-} + +-- | Positive, non-zero. +discreteRepScaleDenominator :: DiscreteRep -> Integer +discreteRepScaleDenominator = _discreteRepScaleDenominator +{-# INLINE discreteRepScaleDenominator #-} + +-- | Amount of currency unit. +discreteRepAmount :: DiscreteRep -> Integer +discreteRepAmount = _discreteRepAmount +{-# INLINE discreteRepAmount #-} + +-- | Internal. Build a 'DiscreteRep' from raw values. +mkDiscreteRep + :: String -- ^ Currency name. + -> Integer -- ^ Scale numerator. Positive, non-zero. + -> Integer -- ^ Scale denominator. Positive, non-zero. + -> Integer -- ^ Amount of unit. + -> Maybe DiscreteRep +mkDiscreteRep = \c n d a -> case (n > 0) && (d > 0) of + False -> Nothing + True -> Just (DiscreteRep c n d a) +{-# INLINE mkDiscreteRep #-} + +-- | Convert a 'Discrete' to a 'DiscreteRep' for ease of serialization. +discreteRep + :: (KnownSymbol currency, GoodScale scale) + => Discrete' currency scale + -> DiscreteRep -- ^ +discreteRep = \(Discrete i0 :: Discrete' currency scale) -> + let c = symbolVal (Proxy :: Proxy currency) + n = natVal (Proxy :: Proxy (Fst scale)) + d = natVal (Proxy :: Proxy (Snd scale)) + in DiscreteRep c n d i0 +{-# INLINE discreteRep #-} + +-- | Attempt to convert a 'DiscreteRep' to a 'Discrete', provided you know the +-- target @currency@ and @unit@. +fromDiscreteRep + :: forall currency scale + . (KnownSymbol currency, GoodScale scale) + => DiscreteRep + -> Maybe (Discrete' currency scale) -- ^ +fromDiscreteRep = \dr -> + if (discreteRepCurrency dr == symbolVal (Proxy :: Proxy currency)) && + (discreteRepScaleNumerator dr == natVal (Proxy :: Proxy (Fst scale))) && + (discreteRepScaleDenominator dr == natVal (Proxy :: Proxy (Snd scale))) + then Just (Discrete (discreteRepAmount dr)) + else Nothing +{-# INLINE fromDiscreteRep #-} + +-- | Convert a 'DiscreteRep' to a 'Discrete' without knowing the target +-- @currency@ and @unit@. +-- +-- Notice that @currency@ and @unit@ here can't leave its intended scope unless +-- you can prove equality with some other type at the outer scope, but in that +-- case you would be better off using 'fromDiscreteRep' directly. +-- +-- Notice that you may need to add an explicit type to the result of this +-- function in order to keep the compiler happy. +withDiscreteRep + :: forall r + . DiscreteRep + -> ( forall currency scale. + ( KnownSymbol currency + , GoodScale scale + ) => Discrete' currency scale + -> r ) + -> r -- ^ +withDiscreteRep dr = \f -> + case someSymbolVal (discreteRepCurrency dr) of + SomeSymbol (Proxy :: Proxy currency) -> + case someNatVal (discreteRepScaleNumerator dr) of + Nothing -> error "withDiscreteRep: impossible: numerator < 0" + Just (SomeNat (Proxy :: Proxy num)) -> + case someNatVal (discreteRepScaleDenominator dr) of + Nothing -> error "withDiscreteRep: impossible: denominator < 0" + Just (SomeNat (Proxy :: Proxy den)) -> + case mkGoodScale of + Nothing -> error "withDiscreteRep: impossible: mkGoodScale" + Just (Dict :: Dict (GoodScale '(num, den))) -> + f (Discrete (discreteRepAmount dr) + :: Discrete' currency '(num, den)) +{-# INLINABLE withDiscreteRep #-} + +-------------------------------------------------------------------------------- +-- ExchangeRateRep + +-- | A monomorphic representation of 'ExchangeRate' that is easier to serialize +-- and deserialize than 'ExchangeRate' in case you don't know the type indexes +-- involved. +data ExchangeRateRep = ExchangeRateRep + { _exchangeRateRepSrcCurrency :: !String + , _exchangeRateRepDstCurrency :: !String + , _exchangeRateRepRateNumerator :: !Integer -- ^ Positive, non-zero. + , _exchangeRateRepRateDenominator :: !Integer -- ^ Positive, non-zero. + } deriving (Eq, Show, GHC.Generic) + +-- | WARNING: This instance does not compare monetary amounts, it just helps you +-- sort 'ExchangeRateRep' values in case you need to put them in a +-- 'Data.Set.Set' or similar. +deriving instance Ord ExchangeRateRep + +-- | Source currency name. +exchangeRateRepSrcCurrency :: ExchangeRateRep -> String +exchangeRateRepSrcCurrency = _exchangeRateRepSrcCurrency +{-# INLINE exchangeRateRepSrcCurrency #-} + +-- | Destination currency name. +exchangeRateRepDstCurrency :: ExchangeRateRep -> String +exchangeRateRepDstCurrency = _exchangeRateRepDstCurrency +{-# INLINE exchangeRateRepDstCurrency #-} + +-- | Exchange rate. Positive, non-zero. +exchangeRateRepRate :: ExchangeRateRep -> Rational +exchangeRateRepRate = \x -> + exchangeRateRepRateNumerator x % _exchangeRateRepRateDenominator x +{-# INLINE exchangeRateRepRate #-} + +-- | Exchange rate numerator. Positive, non-zero. +exchangeRateRepRateNumerator :: ExchangeRateRep -> Integer +exchangeRateRepRateNumerator = _exchangeRateRepRateNumerator +{-# INLINE exchangeRateRepRateNumerator #-} + +-- | Exchange rate denominator. Positive, non-zero. +exchangeRateRepRateDenominator :: ExchangeRateRep -> Integer +exchangeRateRepRateDenominator = _exchangeRateRepRateDenominator +{-# INLINE exchangeRateRepRateDenominator #-} + +-- | Internal. Build a 'ExchangeRateRep' from raw values. +mkExchangeRateRep + :: String -- ^ Source currency name. + -> String -- ^ Destination currency name. + -> Integer -- ^ Exchange rate numerator. Positive, non-zero. + -> Integer -- ^ Exchange rate denominator. Positive, non-zero. + -> Maybe ExchangeRateRep +mkExchangeRateRep = \src dst n d -> case (n > 0) && (d > 0) of + False -> Nothing + True -> Just (ExchangeRateRep src dst n d) +{-# INLINE mkExchangeRateRep #-} + +-- | Convert a 'ExchangeRate' to a 'DiscreteRep' for ease of serialization. +exchangeRateRep + :: (KnownSymbol src, KnownSymbol dst) + => ExchangeRate src dst + -> ExchangeRateRep -- ^ +exchangeRateRep = \(ExchangeRate r0 :: ExchangeRate src dst) -> + let src = symbolVal (Proxy :: Proxy src) + dst = symbolVal (Proxy :: Proxy dst) + in ExchangeRateRep src dst (numerator r0) (denominator r0) +{-# INLINE exchangeRateRep #-} + +-- | Attempt to convert a 'ExchangeRateRep' to a 'ExchangeRate', provided you +-- know the target @src@ and @dst@ types. +fromExchangeRateRep + :: forall src dst + . (KnownSymbol src, KnownSymbol dst) + => ExchangeRateRep + -> Maybe (ExchangeRate src dst) -- ^ +fromExchangeRateRep = \x -> + if (exchangeRateRepSrcCurrency x == symbolVal (Proxy :: Proxy src)) && + (exchangeRateRepDstCurrency x == symbolVal (Proxy :: Proxy dst)) + then Just (ExchangeRate (exchangeRateRepRate x)) + else Nothing +{-# INLINE fromExchangeRateRep #-} + +-- | Convert a 'ExchangeRateRep' to a 'ExchangeRate' without knowing the target +-- @currency@ and @unit@. +-- +-- Notice that @src@ and @dst@ here can't leave its intended scope unless +-- you can prove equality with some other type at the outer scope, but in that +-- case you would be better off using 'fromExchangeRateRep' directly. +withExchangeRateRep + :: ExchangeRateRep + -> ( forall src dst. + ( KnownSymbol src + , KnownSymbol dst + ) => ExchangeRate src dst + -> r ) + -> r -- ^ +withExchangeRateRep x = \f -> + case someSymbolVal (exchangeRateRepSrcCurrency x) of + SomeSymbol (Proxy :: Proxy src) -> + case someSymbolVal (exchangeRateRepDstCurrency x) of + SomeSymbol (Proxy :: Proxy dst) -> + f (ExchangeRate (exchangeRateRepRate x) :: ExchangeRate src dst) +{-# INLINABLE withExchangeRateRep #-} + +-------------------------------------------------------------------------------- +-- Miscellaneous + +type family Fst (ab :: (ka, kb)) :: ka where Fst '(a,b) = a +type family Snd (ab :: (ka, kb)) :: ka where Snd '(a,b) = b + +-------------------------------------------------------------------------------- +-- Extra instances: hashable +#ifdef VERSION_hashable +instance Hashable (Dense currency) +instance Hashable DenseRep +instance Hashable (Discrete' currency scale) +instance Hashable DiscreteRep +instance Hashable (ExchangeRate src dst) +instance Hashable ExchangeRateRep +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: deepseq +#ifdef VERSION_deepseq +instance NFData (Dense currency) +instance NFData DenseRep +instance NFData (Discrete' currency scale) +instance NFData DiscreteRep +instance NFData (ExchangeRate src dst) +instance NFData ExchangeRateRep +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: cereal +#ifdef VERSION_cereal +-- | Compatible with 'DenseRep'. +instance (KnownSymbol currency) => Cereal.Serialize (Dense currency) where + put = Cereal.put . denseRep + get = maybe empty pure =<< fmap fromDenseRep Cereal.get +-- | Compatible with 'DiscreteRep'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Cereal.Serialize (Discrete' currency scale) where + put = Cereal.put . discreteRep + get = maybe empty pure =<< fmap fromDiscreteRep Cereal.get +-- | Compatible with 'ExchangeRateRep'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Cereal.Serialize (ExchangeRate src dst) where + put = Cereal.put . exchangeRateRep + get = maybe empty pure =<< fmap fromExchangeRateRep Cereal.get +-- | Compatible with 'Dense'. +instance Cereal.Serialize DenseRep where + put = \(DenseRep c n d) -> Cereal.put c >> Cereal.put n >> Cereal.put d + get = maybe empty pure =<< mkDenseRep + <$> Cereal.get <*> Cereal.get <*> Cereal.get +-- | Compatible with 'Discrete'. +instance Cereal.Serialize DiscreteRep where + put = \(DiscreteRep c n d a) -> + Cereal.put c >> Cereal.put n >> Cereal.put d >> Cereal.put a + get = maybe empty pure =<< mkDiscreteRep + <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get +-- | Compatible with 'ExchangeRate'. +instance Cereal.Serialize ExchangeRateRep where + put = \(ExchangeRateRep src dst n d) -> + Cereal.put src >> Cereal.put dst >> Cereal.put n >> Cereal.put d + get = maybe empty pure =<< mkExchangeRateRep + <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: binary +#ifdef VERSION_binary +-- | Compatible with 'DenseRep'. +instance (KnownSymbol currency) => Binary.Binary (Dense currency) where + put = Binary.put . denseRep + get = maybe empty pure =<< fmap fromDenseRep Binary.get +-- | Compatible with 'DiscreteRep'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Binary.Binary (Discrete' currency scale) where + put = Binary.put . discreteRep + get = maybe empty pure =<< fmap fromDiscreteRep Binary.get +-- | Compatible with 'ExchangeRateRep'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Binary.Binary (ExchangeRate src dst) where + put = Binary.put . exchangeRateRep + get = maybe empty pure =<< fmap fromExchangeRateRep Binary.get +-- | Compatible with 'Dense'. +instance Binary.Binary DenseRep where + put = \(DenseRep c n d) -> Binary.put c >> Binary.put n >> Binary.put d + get = maybe empty pure =<< mkDenseRep + <$> Binary.get <*> Binary.get <*> Binary.get +-- | Compatible with 'Discrete'. +instance Binary.Binary DiscreteRep where + put = \(DiscreteRep c n d a) -> + Binary.put c >> Binary.put n >> Binary.put d >> Binary.put a + get = maybe empty pure =<< mkDiscreteRep + <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get +-- | Compatible with 'ExchangeRate'. +instance Binary.Binary ExchangeRateRep where + put = \(ExchangeRateRep src dst n d) -> + Binary.put src >> Binary.put dst >> Binary.put n >> Binary.put d + get = maybe empty pure =<< mkExchangeRateRep + <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: aeson +#ifdef VERSION_aeson +-- | Compatible with 'DenseRep' +instance KnownSymbol currency => Ae.ToJSON (Dense currency) where + toJSON = Ae.toJSON . denseRep +-- | Compatible with 'DenseRep' +instance KnownSymbol currency => Ae.FromJSON (Dense currency) where + parseJSON = maybe empty pure <=< fmap fromDenseRep . Ae.parseJSON +-- | Compatible with 'Dense' +instance Ae.ToJSON DenseRep where + toJSON = \(DenseRep c n d) -> Ae.toJSON ("Dense", c, n, d) +-- | Compatible with 'Dense' +instance Ae.FromJSON DenseRep where + parseJSON = \v -> do + ("Dense", c, n, d) <- Ae.parseJSON v + maybe empty pure (mkDenseRep c n d) +-- | Compatible with 'DiscreteRep' +instance + ( KnownSymbol currency, GoodScale scale + ) => Ae.ToJSON (Discrete' currency scale) where + toJSON = Ae.toJSON . discreteRep +-- | Compatible with 'DiscreteRep' +instance + ( KnownSymbol currency, GoodScale scale + ) => Ae.FromJSON (Discrete' currency scale) where + parseJSON = maybe empty pure <=< fmap fromDiscreteRep . Ae.parseJSON +-- | Compatible with 'Discrete'' +instance Ae.ToJSON DiscreteRep where + toJSON = \(DiscreteRep c n d a) -> Ae.toJSON ("Discrete", c, n, d, a) +-- | Compatible with 'Discrete'' +instance Ae.FromJSON DiscreteRep where + parseJSON = \v -> do + ("Discrete", c, n, d, a) <- Ae.parseJSON v + maybe empty pure (mkDiscreteRep c n d a) +-- | Compatible with 'ExchangeRateRep' +instance + ( KnownSymbol src, KnownSymbol dst + ) => Ae.ToJSON (ExchangeRate src dst) where + toJSON = Ae.toJSON . exchangeRateRep +-- | Compatible with 'ExchangeRateRep' +instance + ( KnownSymbol src, KnownSymbol dst + ) => Ae.FromJSON (ExchangeRate src dst) where + parseJSON = maybe empty pure <=< fmap fromExchangeRateRep . Ae.parseJSON +-- | Compatible with 'ExchangeRate' +instance Ae.ToJSON ExchangeRateRep where + toJSON = \(ExchangeRateRep src dst n d) -> + Ae.toJSON ("ExchangeRate", src, dst, n, d) +-- | Compatible with 'ExchangeRate' +instance Ae.FromJSON ExchangeRateRep where + parseJSON = \v -> do + ("ExchangeRate", src, dst, n, d) <- Ae.parseJSON v + maybe empty pure (mkExchangeRateRep src dst n d) +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: store +#ifdef VERSION_store +-- | Compatible with 'DenseRep'. +instance (KnownSymbol currency) => Store.Store (Dense currency) where + poke = Store.poke . denseRep + peek = maybe (fail "peek") pure =<< fmap fromDenseRep Store.peek +-- | Compatible with 'Dense'. +instance Store.Store DenseRep where + poke = \(DenseRep c n d) -> Store.poke (c, n, d) + peek = do (c, n, d) <- Store.peek + maybe (fail "peek") pure (mkDenseRep c n d) +-- | Compatible with 'DiscreteRep'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Store.Store (Discrete' currency scale) where + poke = Store.poke . discreteRep + peek = maybe (fail "peek") pure =<< fmap fromDiscreteRep Store.peek +-- | Compatible with 'Discrete''. +instance Store.Store DiscreteRep where + poke = \(DiscreteRep c n d a) -> Store.poke (c, n, d, a) + peek = do (c, n, d, a) <- Store.peek + maybe (fail "peek") pure (mkDiscreteRep c n d a) +-- | Compatible with 'ExchangeRateRep'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Store.Store (ExchangeRate src dst) where + poke = Store.poke . exchangeRateRep + peek = maybe (fail "peek") pure =<< fmap fromExchangeRateRep Store.peek +-- | Compatible with 'ExchangeRate'. +instance Store.Store ExchangeRateRep where + poke = \(ExchangeRateRep src dst n d) -> Store.poke (src, dst, n, d) + peek = do (src, dst, n, d) <- Store.peek + maybe (fail "peek") pure (mkExchangeRateRep src dst n d) +#endif diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Runners as Tasty +import Test.Tasty.QuickCheck ((===), (==>)) +import qualified Test.Tasty.QuickCheck as QC + +import qualified Data.Aeson as Ae +import qualified Data.Binary as Binary +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (catMaybes, isJust, isNothing) +import Data.Proxy (Proxy(Proxy)) +import qualified Data.Serialize as Cereal +import qualified Data.Store as Store +import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) + +import qualified Data.Money as Money +import qualified Data.Money.Internal as Money + +-------------------------------------------------------------------------------- + +instance QC.Arbitrary (Money.Discrete' currency scale) where + arbitrary = fmap fromInteger QC.arbitrary + shrink = fmap fromInteger . QC.shrink . toInteger + +instance QC.Arbitrary Money.DiscreteRep where + arbitrary = do + let md = Money.mkDiscreteRep <$> QC.arbitrary <*> QC.arbitrary + <*> QC.arbitrary <*> QC.arbitrary + Just x <- QC.suchThat md isJust + pure x + shrink = \x -> Money.withDiscreteRep x (map Money.discreteRep . QC.shrink) + +instance QC.Arbitrary (Money.Dense currency) where + arbitrary = do + Just x <- QC.suchThat (Money.dense <$> QC.arbitrary) isJust + pure x + shrink = catMaybes . fmap Money.dense . QC.shrink . toRational + +instance QC.Arbitrary Money.DenseRep where + arbitrary = do + let md = Money.mkDenseRep <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary + Just x <- QC.suchThat md isJust + pure x + shrink = \x -> Money.withDenseRep x (map Money.denseRep . QC.shrink) + +instance QC.Arbitrary (Money.ExchangeRate src dst) where + arbitrary = do + Just x <- QC.suchThat (fmap Money.exchangeRate QC.arbitrary) isJust + pure x + shrink = + catMaybes . fmap Money.exchangeRate . QC.shrink . Money.fromExchangeRate + +instance QC.Arbitrary Money.ExchangeRateRep where + arbitrary = do + let md = Money.mkExchangeRateRep <$> QC.arbitrary <*> QC.arbitrary + <*> QC.arbitrary <*> QC.arbitrary + Just x <- QC.suchThat md isJust + pure x + shrink = \x -> + Money.withExchangeRateRep x (map Money.exchangeRateRep . QC.shrink) + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] tests + +tests :: Tasty.TestTree +tests = + Tasty.testGroup "root" + [ testCurrencies + , testCurrencyUnits + , testExchange + ] + +testCurrencies :: Tasty.TestTree +testCurrencies = + Tasty.testGroup "Currency" + [ testDense (Proxy :: Proxy "BTC") -- A cryptocurrency. + , testDense (Proxy :: Proxy "USD") -- A fiat currency with decimal fractions. + , testDense (Proxy :: Proxy "VUV") -- A fiat currency with non-decimal fractions. + , testDense (Proxy :: Proxy "XAU") -- A precious metal. + ] + +testCurrencyUnits :: Tasty.TestTree +testCurrencyUnits = + Tasty.testGroup "Currency units" + [ testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "BTC") + , testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "satoshi") + , testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "bitcoin") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "USD") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "cent") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "dollar") + , testDiscrete (Proxy :: Proxy "VUV") (Proxy :: Proxy "vatu") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "micrograin") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "milligrain") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "grain") + ] + +testDense + :: forall currency + . KnownSymbol currency + => Proxy currency + -> Tasty.TestTree +testDense pc = + Tasty.testGroup ("Dense " ++ show (symbolVal pc)) + [ QC.testProperty "read . show == id" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + x === read (show x) + , QC.testProperty "fromDenseRep . denseRep == Just" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === Money.fromDenseRep (Money.denseRep x) + , QC.testProperty "fromDenseRep works only for same currency" $ + QC.forAll QC.arbitrary $ \(dr :: Money.DenseRep) -> + (Money.denseRepCurrency dr /= symbolVal pc) + ==> isNothing (Money.fromDenseRep dr :: Maybe (Money.Dense currency)) + , QC.testProperty "withDenseRep" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let dr = Money.denseRep x + in Money.withDenseRep dr $ \x' -> + (show x, dr, Money.denseRep (x + 1)) + === (show x', Money.denseRep x', Money.denseRep (x' + 1)) + + , QC.testProperty "Aeson encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === Ae.decode (Ae.encode x) + , QC.testProperty "Aeson encoding roundtrip (DenseRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.denseRep x + in Just x' === Ae.decode (Ae.encode x') + , QC.testProperty "Aeson encoding roundtrip (Dense through DenseRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === Ae.decode (Ae.encode (Money.denseRep x)) + , QC.testProperty "Aeson encoding roundtrip (DenseRep through Dense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just (Money.denseRep x) === Ae.decode (Ae.encode x) + + , QC.testProperty "Binary encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let Right (_,_,y) = Binary.decodeOrFail (Binary.encode x) + in x === y + , QC.testProperty "Binary encoding roundtrip (DenseRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.denseRep x + bs = Binary.encode x' + in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs + , QC.testProperty "Binary encoding roundtrip (Dense through DenseRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.denseRep x + bs = Binary.encode x' + in Right (mempty, BSL.length bs, x) === Binary.decodeOrFail bs + , QC.testProperty "Binary encoding roundtrip (DenseRep through Dense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.denseRep x + bs = Binary.encode x + in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs + + , QC.testProperty "Cereal encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Right x === Cereal.decode (Cereal.encode x) + , QC.testProperty "Cereal encoding roundtrip (DenseRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.denseRep x + in Right x' === Cereal.decode (Cereal.encode x') + , QC.testProperty "Cereal encoding roundtrip (Dense through DenseRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Right x === Cereal.decode (Cereal.encode (Money.denseRep x)) + , QC.testProperty "Cereal encoding roundtrip (DenseRep through Dense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Right (Money.denseRep x) === Cereal.decode (Cereal.encode x) + ] + +testExchange :: Tasty.TestTree +testExchange = + Tasty.testGroup "Exchange" + [ testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "XAU") + ] + +testDiscrete + :: forall (currency :: Symbol) (unit :: Symbol) + . ( Money.GoodScale (Money.Scale currency unit) + , KnownSymbol currency + , KnownSymbol unit ) + => Proxy currency + -> Proxy unit + -> Tasty.TestTree +testDiscrete pc pu = + Tasty.testGroup ("Discrete " ++ show (symbolVal pc) ++ " " + ++ show (symbolVal pu)) + [ testRounding pc pu + , QC.testProperty "read . show == id" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + x === read (show x) + , QC.testProperty "fromDiscreteRep . discreteRep == Just" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === Money.fromDiscreteRep (Money.discreteRep x) + , QC.testProperty "fromDiscreteRep works only for same currency and scale" $ + QC.forAll QC.arbitrary $ \(dr :: Money.DiscreteRep) -> + ((Money.discreteRepCurrency dr /= symbolVal pc) && + (Money.discreteRepScale dr /= + Money.scale (Proxy :: Proxy (Money.Scale currency unit))) + ) ==> isNothing (Money.fromDiscreteRep dr + :: Maybe (Money.Discrete currency unit)) + , QC.testProperty "withDiscreteRep" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let dr = Money.discreteRep x + in ( Money.withDiscreteRep dr $ \x' -> + (show x, dr, Money.discreteRep (x + 1)) + === (show x', Money.discreteRep x', Money.discreteRep (x' + 1)) + ) :: QC.Property + + , QC.testProperty "Aeson encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === Ae.decode (Ae.encode x) + , QC.testProperty "Aeson encoding roundtrip (DiscreteRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.discreteRep x + in Just x' === Ae.decode (Ae.encode x') + , QC.testProperty "Aeson encoding roundtrip (Discrete through DiscreteRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === Ae.decode (Ae.encode (Money.discreteRep x)) + , QC.testProperty "Aeson encoding roundtrip (DiscreteRep through Discrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just (Money.discreteRep x) === Ae.decode (Ae.encode x) + + , QC.testProperty "Binary encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let Right (_,_,y) = Binary.decodeOrFail (Binary.encode x) + in x === y + , QC.testProperty "Binary encoding roundtrip (DiscreteRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.discreteRep x + bs = Binary.encode x' + in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs + , QC.testProperty "Binary encoding roundtrip (Discrete through DiscreteRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.discreteRep x + bs = Binary.encode x' + in Right (mempty, BSL.length bs, x) === Binary.decodeOrFail bs + , QC.testProperty "Binary encoding roundtrip (DiscreteRep through Discrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.discreteRep x + bs = Binary.encode x + in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs + + , QC.testProperty "Cereal encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Right x === Cereal.decode (Cereal.encode x) + , QC.testProperty "Cereal encoding roundtrip (DiscreteRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.discreteRep x + in Right x' === Cereal.decode (Cereal.encode x') + , QC.testProperty "Cereal encoding roundtrip (Discrete through DiscreteRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Right x === Cereal.decode (Cereal.encode (Money.discreteRep x)) + , QC.testProperty "Cereal encoding roundtrip (DiscreteRep through Discrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Right (Money.discreteRep x) === Cereal.decode (Cereal.encode x) + ] + +testExchangeRate + :: forall (src :: Symbol) (dst :: Symbol) + . (KnownSymbol src, KnownSymbol dst) + => Proxy src + -> Proxy dst + -> Tasty.TestTree +testExchangeRate ps pd = + Tasty.testGroup ("ExchangeRate " ++ show (symbolVal ps) ++ " " + ++ show (symbolVal pd)) + [ QC.testProperty "read . show == id" $ + QC.forAll QC.arbitrary $ \(xr :: Money.ExchangeRate src dst) -> + xr === read (show xr) + , QC.testProperty "flipExchangeRate . flipExchangeRate == id" $ + QC.forAll QC.arbitrary $ \(xr :: Money.ExchangeRate src dst) -> + let xr' = Money.flipExchangeRate xr + in (Money.fromExchangeRate xr /= Money.fromExchangeRate xr') + ==> (xr === Money.flipExchangeRate xr') + , QC.testProperty "exchange (flipExchangeRate x) . exchange x == id" $ + QC.forAll QC.arbitrary $ + \( c0 :: Money.Dense src + , xr :: Money.ExchangeRate src dst + ) -> c0 === Money.exchange (Money.flipExchangeRate xr) + (Money.exchange xr c0) + , QC.testProperty "x == 1 ===> exchange x == id" $ + QC.forAll QC.arbitrary $ + \( c0 :: Money.Dense src + ) -> let Just xr = Money.exchangeRate 1 + in toRational c0 === toRational (Money.exchange xr c0) + , QC.testProperty "x /= 1 ===> exchange x /= id" $ + QC.forAll QC.arbitrary $ + \( c0 :: Money.Dense src + , xr :: Money.ExchangeRate src dst + ) -> (Money.fromExchangeRate xr /= 1) + ==> (toRational c0 /= toRational (Money.exchange xr c0)) + , QC.testProperty "fromExchangeRateRep . exchangeRateRep == Just" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === Money.fromExchangeRateRep (Money.exchangeRateRep x) + , QC.testProperty "fromExchangeRateRep works only for same currencies" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRateRep) -> + ((Money.exchangeRateRepSrcCurrency x /= symbolVal ps) && + (Money.exchangeRateRepDstCurrency x /= symbolVal pd)) + ==> isNothing (Money.fromExchangeRateRep x + :: Maybe (Money.ExchangeRate src dst)) + , QC.testProperty "withExchangeRateRep" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let dr = Money.exchangeRateRep x + in Money.withExchangeRateRep dr $ \x' -> + (show x, dr) === (show x', Money.exchangeRateRep x') + + , QC.testProperty "Aeson encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === Ae.decode (Ae.encode x) + , QC.testProperty "Aeson encoding roundtrip (ExchangeRateRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.exchangeRateRep x + in Just x' === Ae.decode (Ae.encode x') + , QC.testProperty "Aeson encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === Ae.decode (Ae.encode (Money.exchangeRateRep x)) + , QC.testProperty "Aeson encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just (Money.exchangeRateRep x) === Ae.decode (Ae.encode x) + + , QC.testProperty "Binary encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let Right (_,_,y) = Binary.decodeOrFail (Binary.encode x) + in x === y + , QC.testProperty "Binary encoding roundtrip (ExchangeRateRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.exchangeRateRep x + bs = Binary.encode x' + in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs + , QC.testProperty "Binary encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.exchangeRateRep x + bs = Binary.encode x' + in Right (mempty, BSL.length bs, x) === Binary.decodeOrFail bs + , QC.testProperty "Binary encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.exchangeRateRep x + bs = Binary.encode x + in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs + + , QC.testProperty "Cereal encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Right x === Cereal.decode (Cereal.encode x) + , QC.testProperty "Cereal encoding roundtrip (ExchangeRateRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.exchangeRateRep x + in Right x' === Cereal.decode (Cereal.encode x') + , QC.testProperty "Cereal encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Right x === Cereal.decode (Cereal.encode (Money.exchangeRateRep x)) + , QC.testProperty "Cereal encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Right (Money.exchangeRateRep x) === Cereal.decode (Cereal.encode x) + ] + +testRounding + :: forall (currency :: Symbol) (unit :: Symbol) + . (Money.GoodScale (Money.Scale currency unit), KnownSymbol currency) + => Proxy currency + -> Proxy unit + -> Tasty.TestTree +testRounding _ _ = + Tasty.testGroup "Rounding" + [ QC.testProperty "floor" $ QC.forAll QC.arbitrary (g Money.floor) + , QC.testProperty "ceiling" $ QC.forAll QC.arbitrary (g Money.ceiling) + , QC.testProperty "round" $ QC.forAll QC.arbitrary (g Money.round) + , QC.testProperty "truncate" $ QC.forAll QC.arbitrary (g Money.truncate) + ] + where + g f = \(x :: Money.Dense currency) -> x === case f x of + (y, Nothing) -> Money.fromDiscrete (y :: Money.Discrete currency unit) + (y, Just z) -> Money.fromDiscrete y + z