diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ -# Changelog for `tiles` +# Changelog for `convert-units` All notable changes to this project will be documented in this file. @@ -6,6 +6,34 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## Unreleased +## 0.1 - 2026-01-24 -## 0.1.0.0 - YYYY-MM-DD +### Added + +- #4 : Imperial and UsCustomary units for Area and Length (thanks to Aster89) +- Use integer singletons for exponentiating units: + +``` haskell + >>> Meter 2 .^. pos @10 + quantity @(Meter.^+10) 1024.0 +``` + +### Renamed + +This is strongly against backward compatibility, but this is still very early stages of this library. Sorry ! + +- `NonStd` -> `NonSI` (more accurate in terms of physics) +- `Base` -> `Core` (avoid confusion with base units) + +### Removed + +- The file `Data.Type.Int.Proxy` was deleted. `zero, pos1, pos2, pos3, pos4, neg1, neg2, neg3 , neg4` are now exported by `Data.Type.Int`. + + +## 0 - 2025-09-10 + +### Added + +- Units +- Dimensions +- Quantities diff --git a/convert-units.cabal b/convert-units.cabal --- a/convert-units.cabal +++ b/convert-units.cabal @@ -1,19 +1,19 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: convert-units -version: 0 -synopsis: Arithmetic and type checked conversions between units. +version: 0.1 +synopsis: Statically typed unit conversions description: Please see the README on GitHub at category: Physics, Data, Numeric, Math homepage: https://github.com/AliceRixte/convert-units#readme bug-reports: https://github.com/AliceRixte/convert-units/issues author: Alice Rixte maintainer: alice.rixte@u-bordeaux.fr -copyright: BSD 3 +copyright: (c) Alice Rixte 2025 license: BSD-3-Clause license-file: LICENSE build-type: Simple @@ -29,31 +29,38 @@ library exposed-modules: Data.Type.Int - Data.Type.Int.Proxy Data.Units Data.Units.AngleSI Data.Units.AngleSI.Derived - Data.Units.AngleSI.NonStd - Data.Units.AngleSI.NonStd.Angle + Data.Units.AngleSI.NonSI + Data.Units.AngleSI.NonSI.Angle Data.Units.AngleSI.System - Data.Units.Base - Data.Units.Base.Arithmetic - Data.Units.Base.Convert - Data.Units.Base.Prefix - Data.Units.Base.System - Data.Units.Base.TH - Data.Units.NonStd - Data.Units.NonStd.Frequency - Data.Units.NonStd.Temperature - Data.Units.NonStd.Time + Data.Units.Core + Data.Units.Core.Arithmetic + Data.Units.Core.Convert + Data.Units.Core.Prefix + Data.Units.Core.System + Data.Units.Core.TH + Data.Units.Imperial + Data.Units.Imperial.Area + Data.Units.Imperial.Length + Data.Units.NonSI + Data.Units.NonSI.Area + Data.Units.NonSI.Frequency + Data.Units.NonSI.Length + Data.Units.NonSI.Temperature + Data.Units.NonSI.Time Data.Units.SI Data.Units.SI.Derived Data.Units.SI.Derived.Angle Data.Units.SI.Derived.NonAngle - Data.Units.SI.NonStd - Data.Units.SI.NonStd.Angle + Data.Units.SI.NonSI + Data.Units.SI.NonSI.Angle Data.Units.SI.Prefixes Data.Units.SI.System + Data.Units.UsCustomary + Data.Units.UsCustomary.Area + Data.Units.UsCustomary.Length other-modules: Paths_convert_units autogen-modules: @@ -61,38 +68,33 @@ hs-source-dirs: src default-extensions: - TypeApplications - StandaloneDeriving - DerivingVia - GeneralizedNewtypeDeriving - TypeOperators - PolyKinds - ScopedTypeVariables - DataKinds + NoStarIsType + FunctionalDependencies TypeFamilies - FlexibleInstances UndecidableInstances - MultiParamTypeClasses - FlexibleContexts + DerivingVia + UndecidableInstances TemplateHaskell ghc-options: -Wall -threaded build-depends: base >=4.18 && <5 - , template-haskell >=2.21.0 - default-language: Haskell2010 + , template-haskell >=2.21.0 && <2.24 + default-language: GHC2024 test-suite convert-units-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Data.Epsilon - Data.Units.Base.ArithmeticProp - Data.Units.Base.ConvertProp - Data.Units.BaseProp - Data.Units.NonStd.AngleSpec - Data.Units.NonStd.FrequencySpec - Data.Units.NonStd.TemperatureSpec - Data.Units.NonStd.TimeSpec + Data.Type.IntSpec + Data.Units.Core.ArithmeticProp + Data.Units.Core.ConvertProp + Data.Units.CoreProp + Data.Units.NonSI.AngleSpec + Data.Units.NonSI.AreaSpec + Data.Units.NonSI.FrequencySpec + Data.Units.NonSI.LengthSpec + Data.Units.NonSI.TemperatureSpec + Data.Units.NonSI.TimeSpec Data.Units.SI.PrefixSpec Data.Units.SI.SystemSpec Paths_convert_units @@ -101,19 +103,12 @@ hs-source-dirs: test default-extensions: - TypeApplications - StandaloneDeriving - DerivingVia - GeneralizedNewtypeDeriving - TypeOperators - PolyKinds - ScopedTypeVariables - DataKinds + NoStarIsType + FunctionalDependencies TypeFamilies - FlexibleInstances UndecidableInstances - MultiParamTypeClasses - FlexibleContexts + DerivingVia + UndecidableInstances TemplateHaskell ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: @@ -121,9 +116,9 @@ , base >=4.18 && <5 , convert-units , hspec >=2.11 - , linear - , template-haskell >=2.21.0 - default-language: Haskell2010 + , ieee754 <=0.8.0 + , template-haskell >=2.21.0 && <2.24 + default-language: GHC2024 benchmark convert-units-bench type: exitcode-stdio-1.0 @@ -135,24 +130,17 @@ hs-source-dirs: benchmark default-extensions: - TypeApplications - StandaloneDeriving - DerivingVia - GeneralizedNewtypeDeriving - TypeOperators - PolyKinds - ScopedTypeVariables - DataKinds + NoStarIsType + FunctionalDependencies TypeFamilies - FlexibleInstances UndecidableInstances - MultiParamTypeClasses - FlexibleContexts + DerivingVia + UndecidableInstances TemplateHaskell ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.18 && <5 , convert-units , criterion >=1.6 - , template-haskell >=2.21.0 - default-language: Haskell2010 + , template-haskell >=2.21.0 && <2.24 + default-language: GHC2024 diff --git a/src/Data/Type/Int.hs b/src/Data/Type/Int.hs --- a/src/Data/Type/Int.hs +++ b/src/Data/Type/Int.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE ExistentialQuantification #-} - -------------------------------------------------------------------------------- -- | -- @@ -139,4 +136,91 @@ instance KnownNat n => KnownInt (Neg n) where intVal _ = -natVal (Proxy :: Proxy n) +-- | Singleton type for type-level integers. +data SZZ (z :: ZZ) where + SPos :: KnownNat n => SNat n -> SZZ ('Pos n) + SNeg :: KnownNat n => SNat n -> SZZ ('Neg n) + SZero :: SZZ 'Zero +-- | Singleton for zero. +zero :: SZZ 'Zero +zero = SZero + +-- | Singleton for positive integers. +-- +-- >>> :t pos @3 +-- pos @3 :: KnownNat 3 => SZZ ('Pos 3) +-- +pos :: KnownNat n => SZZ ('Pos n) +pos = SPos SNat + +-- | Integer singleton for 1. +pos1 :: SZZ ('Pos 1) +pos1 = pos @1 + +-- | Integer singleton for 2. +pos2 :: SZZ ('Pos 2) +pos2 = pos @2 + +-- | Integer singleton for 3. +pos3 :: SZZ ('Pos 3) +pos3 = pos @3 + +-- | Integer singleton for 4. +pos4 :: SZZ ('Pos 4) +pos4 = pos @4 + +-- | Singleton for negative integers. +-- +-- >>> :t neg @3 +-- neg @3 :: KnownNat 3 => SZZ ('Neg 3) +-- +neg :: KnownNat n => SZZ ('Neg n) +neg = SNeg SNat + +-- | Integer singleton for -1. +neg1 :: SZZ ('Neg 1) +neg1 = neg @1 + +-- | Integer singleton for -2. +neg2 :: SZZ ('Neg 2) +neg2 = neg @2 + +-- | Integer singleton for -3. +neg3 :: SZZ ('Neg 3) +neg3 = neg @3 + +-- | Integer singleton for -4. +neg4 :: SZZ ('Neg 4) +neg4 = neg @4 + + +-- | Return the 'Integer' corresponding to @n@ in an @SZZ n@ value. +fromSZZ :: SZZ n -> Integer +fromSZZ SZero = 0 +fromSZZ (SPos sn) = natVal sn +fromSZZ (SNeg sn) = -natVal sn + +-- | Convert an 'Integer' into an @'SZZ' n@ value, where @n@ is a fresh +-- type-level symbol. +withSomeSZZ :: Integer -> (forall (n :: ZZ). SZZ n -> r) -> r +withSomeSZZ 0 f = f SZero +withSomeSZZ i f + | i == 0 = f SZero + | i > 0 = withSomeSNat i (fpos f) + | otherwise = withSomeSNat (negate i) (fneg f) + where + fpos f' (Just (SNat :: SNat n)) = f' (SPos (SNat @n)) + fpos _ Nothing = error "withSomeSZZ: This should never happen.\ + \ A bug report would be appreciated." + + fneg f' (Just (SNat :: SNat n)) = f' (SNeg (SNat @n)) + fneg _ Nothing = error "withSomeSZZ: This should never happen.\ + \ A bug report would be appreciated." + +-- | Convert an explicit @'SZZ' n@ value into an implicit @'KnownInt' n@ +-- constraint. +withKnownInt :: SZZ n -> (KnownInt n => r) -> r +withKnownInt SZero r = r +withKnownInt (SPos sn) r = withKnownNat sn r +withKnownInt (SNeg sn) r = withKnownNat sn r diff --git a/src/Data/Type/Int/Proxy.hs b/src/Data/Type/Int/Proxy.hs deleted file mode 100644 --- a/src/Data/Type/Int/Proxy.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Data.Type.Int.Proxy - ( zero - , pos1 - , neg1 - , pos2 - , neg2 - , pos3 - , neg3 - , pos4 - , neg4 - ) - where - -import Data.Proxy -import Data.Type.Int - -zero :: Proxy Zero -zero = Proxy - -pos1 :: Proxy (Pos 1) -pos1 = Proxy - -neg1 :: Proxy (Neg 1) -neg1 = Proxy - -pos2 :: Proxy (Pos 2) -pos2 = Proxy - -neg2 :: Proxy (Neg 2) -neg2 = Proxy - -pos3 :: Proxy (Pos 3) -pos3 = Proxy - -neg3 :: Proxy (Neg 3) -neg3 = Proxy - -pos4 :: Proxy (Pos 4) -pos4 = Proxy - -neg4 :: Proxy (Neg 4) -neg4 = Proxy diff --git a/src/Data/Units.hs b/src/Data/Units.hs --- a/src/Data/Units.hs +++ b/src/Data/Units.hs @@ -1,9 +1,9 @@ module Data.Units - ( module Data.Units.Base + ( module Data.Units.Core , module Data.Units.SI - , module Data.Units.SI.NonStd + , module Data.Units.SI.NonSI ) where -import Data.Units.Base +import Data.Units.Core import Data.Units.SI -import Data.Units.SI.NonStd +import Data.Units.SI.NonSI diff --git a/src/Data/Units/AngleSI/Derived.hs b/src/Data/Units/AngleSI/Derived.hs --- a/src/Data/Units/AngleSI/Derived.hs +++ b/src/Data/Units/AngleSI/Derived.hs @@ -30,7 +30,7 @@ import Data.Coerce -import Data.Units.Base +import Data.Units.Core import Data.Units.AngleSI.System import Data.Units.SI.Derived.NonAngle @@ -48,8 +48,7 @@ -- type LuminousFlux = NormalizeDim (LuminousIntensity .*. SolidAngle) --- | Luminous flux in lumens --- +-- | Luminous flux in lumens. $(mkUnit "Lumen" "lm" ''LuminousFlux 1) -- | Illuminance quantity. Equal to @@ -58,6 +57,5 @@ -- type Illuminance = NormalizeDim (LuminousFlux ./. Area) --- | Illuminance in lux --- +-- | Illuminance in lux. $(mkUnit "Lux" "lx" ''Illuminance 1) diff --git a/src/Data/Units/AngleSI/NonSI.hs b/src/Data/Units/AngleSI/NonSI.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI/NonSI.hs @@ -0,0 +1,17 @@ +module Data.Units.AngleSI.NonSI + ( module Data.Units.NonSI + , module Data.Units.AngleSI.Derived + , module Data.Units.AngleSI.NonSI.Angle + , module Data.Units.SI.System + , module Data.Units.SI.Prefixes + , module Data.Units.SI.Derived.NonAngle + ) +where + +import Data.Units.NonSI +import Data.Units.AngleSI.Derived +import Data.Units.AngleSI.NonSI.Angle +import Data.Units.SI.System +import Data.Units.SI.Prefixes +import Data.Units.SI.Derived.NonAngle + diff --git a/src/Data/Units/AngleSI/NonSI/Angle.hs b/src/Data/Units/AngleSI/NonSI/Angle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI/NonSI/Angle.hs @@ -0,0 +1,58 @@ + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.AngleSI.NonSI.Angle +-- Description : Non standard angle units with a dimension A +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Non standard angle units with a dimension A. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.AngleSI.NonSI.Angle + ( Degree (..) + , Turn (..) + , Gradian (..) + ) +where + +import Data.Units.Core + +import Data.Units.AngleSI.System + + + +-- | Angle in degrees. +$(mkUnitNoFactor "Degree" "°" ''Angle) + +-- | Angle in complete turns (also called cycles or revolutions). +$(mkUnitNoFactor "Turn" "tr" ''Angle) + +-- | Angle in gradians. +$(mkUnitNoFactor "Gradian" "grad" ''Angle) + + +instance Floating a => ConvertibleUnit Degree a + +instance Floating a => ConversionFactor Degree a where + factor = pi / 180 + {-# INLINE factor #-} + +instance Floating a => ConvertibleUnit Turn a + +instance Floating a => ConversionFactor Turn a where + factor = 2 * pi + {-# INLINE factor #-} + +instance Floating a => ConvertibleUnit Gradian a + +instance Floating a => ConversionFactor Gradian a where + factor = pi / 200 + {-# INLINE factor #-} + diff --git a/src/Data/Units/AngleSI/NonStd.hs b/src/Data/Units/AngleSI/NonStd.hs deleted file mode 100644 --- a/src/Data/Units/AngleSI/NonStd.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Data.Units.AngleSI.NonStd - ( module Data.Units.NonStd - , module Data.Units.AngleSI.Derived - , module Data.Units.AngleSI.NonStd.Angle - ) -where - -import Data.Units.NonStd -import Data.Units.AngleSI.Derived -import Data.Units.AngleSI.NonStd.Angle diff --git a/src/Data/Units/AngleSI/NonStd/Angle.hs b/src/Data/Units/AngleSI/NonStd/Angle.hs deleted file mode 100644 --- a/src/Data/Units/AngleSI/NonStd/Angle.hs +++ /dev/null @@ -1,65 +0,0 @@ - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.AngleSI.NonStd.Angle --- Description : Non standard angle units with a dimension A --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Non standard angle units with a dimension A. --- --------------------------------------------------------------------------------- - - -module Data.Units.AngleSI.NonStd.Angle - ( Degree (..) - , Turn (..) - , Gradian (..) - ) -where - -import Data.Units.Base - -import Data.Units.AngleSI.System - - - --- | Angle in degrees. --- -$(mkUnitNoFactor "Degree" "°" ''Angle) - --- | Angle in complete turns (also called cycles or revolutions) --- --- See https://en.wikipedia.org/wiki/Turn_(angle) --- -$(mkUnitNoFactor "Turn" "tr" ''Angle) - --- | Angle in gradians --- --- See https://en.wikipedia.org/wiki/Gradian --- -$(mkUnitNoFactor "Gradian" "grad" ''Angle) - - -instance Floating a => ConvertibleUnit Degree a - -instance Floating a => ConversionFactor Degree a where - factor = pi / 180 - {-# INLINE factor #-} - -instance Floating a => ConvertibleUnit Turn a - -instance Floating a => ConversionFactor Turn a where - factor = 2 * pi - {-# INLINE factor #-} - -instance Floating a => ConvertibleUnit Gradian a - -instance Floating a => ConversionFactor Gradian a where - factor = pi / 200 - {-# INLINE factor #-} - diff --git a/src/Data/Units/AngleSI/System.hs b/src/Data/Units/AngleSI/System.hs --- a/src/Data/Units/AngleSI/System.hs +++ b/src/Data/Units/AngleSI/System.hs @@ -29,7 +29,7 @@ import Data.Fixed import Data.Coerce -import Data.Units.Base +import Data.Units.Core import Data.Units.SI.System -- | The angle dimension, denotated @A@. @@ -38,6 +38,8 @@ -- | An angle in radians. +-- +-- This is the base unit of the angle dimension. -- $(mkBaseUnit "Radian" "rad" ''Angle) diff --git a/src/Data/Units/Base.hs b/src/Data/Units/Base.hs deleted file mode 100644 --- a/src/Data/Units/Base.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Data.Units.Base - ( -- ** Core modules - module Data.Units.Base.System - , module Data.Units.Base.Convert - , module Data.Units.Base.Arithmetic - , module Data.Units.Base.Prefix - , module Data.Units.Base.TH - -- ** Re-exported for Template Haskell to work out of the box - -- on @import Data.Units.Base@ - , coerce - -- ** Type level integers - , module Data.Type.Int - , module Data.Type.Int.Proxy - -- ** Re-exported from GHC.TypeError - , ErrorMessage (..) - ) where - -import GHC.TypeError (ErrorMessage(..)) -import Data.Coerce (coerce) - -import Data.Units.Base.System -import Data.Units.Base.Convert -import Data.Units.Base.Arithmetic -import Data.Units.Base.Prefix -import Data.Units.Base.TH -import Data.Type.Int -import Data.Type.Int.Proxy diff --git a/src/Data/Units/Base/Arithmetic.hs b/src/Data/Units/Base/Arithmetic.hs deleted file mode 100644 --- a/src/Data/Units/Base/Arithmetic.hs +++ /dev/null @@ -1,393 +0,0 @@ --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.Base.Arithmetic --- Description : Addition, multiplication and exponentiation of quantities --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Addition, multiplication and exponentiation of quantities. Dimension analysis is done statically via the type system. --- --- == Addition and multiplication of a quantity by a scalar --- --- To add, multiply, divide, and so on, a quantity with a scalar , use its @'Fractional'@ instance : --- --- >>> a = Milli (Second 5) --- >>> 3 * a --- quantity @(Milli Second) 15 --- --- [Warning] These instances are provided because they are convenient, but be careful ! This means that you can write: --- --- >>> Second 2 * Second 3 --- Second 6 --- --- which does not respect dimension analysis: the multiplication of two time --- quantities should be of dimension @T²@ and here it has dimension @T@. --- --- Some of the operators proposed here solve this problem: --- --- >>> Second 2 .*~ Second 3 --- quantity @(Second .^+ 2) 6 --- --------------------------------------------------------------------------------- - -module Data.Units.Base.Arithmetic - ( - -- ** Addition - (.+~) - , (~+.) - , (~+~) - -- ** Subtraction - , (.-~) - , (~-.) - , (~-~) - -- ** Multiplication - , (.*.) - , (.*~) - , (~*.) - , (~*~) - -- ** Division - , (./.) - , (./~) - , (~/.) - , (~/~) - -- ** Exponentiation - , (.^.) - , (~^.) - , (.^~) - , (~^~) - ) where - -import Data.Type.Int - -import Data.Units.Base.System -import Data.Units.Base.Convert - ------------------------------------ Addition ----------------------------------- - --- | Add two quantities of same dimension. The unit of the right operand is --- converted to the unit of the left operand --- --- >>> Kilo (Meter 5) .+~ Meter 80 --- quantity @(Kilo Meter) 5.08 --- --- >>> Meter 2 .+~ Second 3 --- • Cannot convert unit ‘s’ of dimension ‘T’ --- to unit ‘m’ of dimension ‘L’. --- -(.+~) :: forall u v a. FromTo' v u a => u a -> v a -> u a -u .+~ v = quantity (unQuantity u + unQuantity (fromTo' v :: u a)) -{-# INLINE (.+~) #-} - -infixr 5 .+~ - --- | Same as @'(.+~)'@ but it is the left operand that is converted. --- --- >>> Kilo (Meter 5) ~+. Meter 80 --- quantity @(Kilo Meter) 5080.0 --- -(~+.) :: FromTo' u v a => u a -> v a -> v a -(~+.) = flip (.+~) -{-# INLINE (~+.) #-} - -infixr 5 ~+. - --- | Add two quantities of same dimension and convert to the standard unit. --- --- >>> Kilo (Meter 1) ~+~ Milli (Meter 150) --- Meter 1000.15 --- -(~+~) :: - ( DimEq u v - , ConversionFactor u a, ConversionFactor v a - ) - => u a -> v a -> (BaseUnitOf u) a -u ~+~ v = quantity (unQuantity (toBaseUnit' u) + unQuantity (toBaseUnit' v)) -{-# INLINE (~+~) #-} - -infixr 5 ~+~ - ---------------------------------- Subtraction ---------------------------------- - --- | Subtract two quantities of same dimension. The unit of the right operand is converted to the unit of the left operand --- --- >>> Kilo (Meter 5) .-~ Meter 80 --- quantity @(Kilo Meter) 4.92 --- -(.-~) :: forall u v a. FromTo' v u a => u a -> v a -> u a -u .-~ v = quantity (unQuantity u - unQuantity (fromTo' v :: u a)) -{-# INLINE (.-~) #-} - -infixr 5 .-~ - --- | Same as @'(.-~)'@ but it is the left operand that is converted. --- --- >>> Kilo (Meter 5) ~-. Meter 80 --- Meter 4920.0 --- -(~-.) :: forall u v a. FromTo' u v a => u a -> v a -> v a -u ~-. v = quantity (unQuantity (fromTo' u :: v a) - unQuantity v) --- {-# INLINE (~-.) #-} - -infixr 5 ~-. - --- | Subtract two quantities of same dimension and convert to the standard unit. --- --- >>> Kilo (Meter 1) ~-~ Milli (Meter 150) --- Meter 999.85 --- -(~-~) :: - ( DimEq u v - , ConversionFactor v a, ConversionFactor u a - ) - => u a -> v a -> (BaseUnitOf u) a -u ~-~ v = quantity $ unQuantity (toBaseUnit' u) - unQuantity (toBaseUnit' v) -{-# INLINE (~-~) #-} - -infixr 5 ~-~ - --------------------------------- Multiplication -------------------------------- - - - --- | Multiply two quantities. --- --- Usage is not recommended, as this will result non standard units. --- --- For instance: --- --- >>> Kilo (Meter 2) .*. Milli (Meter 4) --- quantity @(Kilo Meter .*. Milli Meter) 8 --- -(.*.) :: - ( IsUnit u, IsUnit v - , Num a - ) - => u a -> v a -> (u .*. v) a -u .*. v = quantity $ unQuantity u * unQuantity v -{-# INLINE (.*.) #-} - -infixr 7 .*. - --- | Multiply two quantities, and tries to normalize the resulting unit, without --- converting to base units. --- --- >>> Meter 2 .*~ Meter 3 .*~ Meter 4 --- quantity @(Meter.^+3) 24 --- --- When two multiplied units have the same dimension, the right most unit is --- converted to left most unit: --- --- >>> Milli (Meter 2) .*~ Micro (Meter 3) --- quantity @(Milli Meter.^+2) 6.0e-3 --- --- Derived units are not unfolded: --- --- >>> Kilo Watt 3 .*~ Hour 5 --- quantity @(Kilo Watt .*. Hour) 14.999999999999998 --- --- Units are ordered, so that the result unit do not depend on the order of the --- computations. --- --- >>> Meter 2 .*~ Newton 2 .*~ Kilo (Meter 2) .*~ Kilo (Gram 1) --- quantity @(Newton .*. Kilo Gram .*. Meter.^+2) 8000.0 --- -(.*~) :: forall u v a uv. - ( uv ~ u .*~ v - , FromTo' (u .*. v) uv a - , IsUnit u, IsUnit v, IsUnit uv - , Num a - ) - => u a -> v a -> uv a -u .*~ v = to' @uv (u .*. v) -{-# INLINE (.*~) #-} - -infixr 7 .*~ - --- | Same as '(.*~)' but with right priority --- --- >>> Meter 2 ~*. Meter 3 ~*. Meter 4 --- quantity @(Meter.^+3) 24 --- --- >>> Milli (Meter 2) ~*. Micro (Meter 3) --- quantity @(Micro Meter.^+2) 6000.000000000001 --- -(~*.) :: forall u v a uv. - ( uv ~ u ~*. v - , FromTo' (u .*. v) uv a - , IsUnit u, IsUnit v, IsUnit uv - , Num a - ) - => u a -> v a -> uv a -u ~*. v = to' @uv (u .*. v) -{-# INLINE (~*.) #-} - -infixr 7 ~*. - --- | Multiply two quantities of the same dimension and convert both of them to the corresponding standard unity. --- --- >>> Milli (Meter 2) ~*~ Kilo (Meter 3) --- quantity @(Meter .^+ 2) 6.0 --- --- >>> Meter 2 ~*~ Second 5 --- • Cannot convert unit ‘m’ to unit ‘s’ because their dimensions do not match. --- Dimension of ‘m’ is: L --- Dimension of ‘s’ is: T --- -(~*~) :: - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - ) - => u a -> v a -> u2 a -u ~*~ v = quantity $ unQuantity (toBaseUnit' u) * unQuantity (toBaseUnit' v) -{-# INLINE (~*~) #-} - -infix 7 ~*~ - - ------------------------------------ Division ----------------------------------- - --- | Multiply two quantities. --- --- Usage is not recommended, as this will result non standard units. --- --- For instance: --- --- >>> Kilo (Meter 2) ./. Milli (Meter 4) --- quantity @(Kilo Meter .*. Milli Meter.^-1) 0.5 --- -(./.) :: - ( IsUnit u, IsUnit v, IsUnit (u ./. v) - , Fractional a - ) - => u a -> v a -> (u ./. v) a -u ./. v = quantity (unQuantity u / unQuantity v) -{-# INLINE (./.) #-} - -infix 7 ./. - --- | Same '(.*~)' but for division. --- --- >>> Milli (Meter 3) ./~ quantity @(Meter .^+ 2) 2 --- quantity @(Milli Meter.^-1) 1.5e-6 --- -(./~) :: forall u v a uv. - ( uv ~ u ./~ v - , FromTo' (u ./. v) uv a - , IsUnit u, IsUnit v, IsUnit uv - , Num a - ) - => u a -> v a -> uv a -u ./~ v = to' @uv (u ./. v) -{-# INLINE (./~) #-} - -infix 7 ./~ - --- | Same '(~/.)' but with right priority --- --- >>> Milli (Meter 3) ~/. quantity @(Meter .^+ 2) 2 --- quantity @(Meter.^-1) 1.5e-3 --- -(~/.) :: forall u v a uv. - ( uv ~ u ~/. v - , FromTo' (u ./. v) uv a - , IsUnit u, IsUnit v, IsUnit uv - , Num a - ) - => u a -> v a -> uv a -u ~/. v = to' @uv (u ./. v) -{-# INLINE (~/.) #-} - -infix 7 ~/. - --- | Divide two quantities of same dimensions. The numerator will be converted --- to the denominator --- --- Units of the same dimension are authorized only when the units are equal. --- --- >>> Meter 4 ~/~ Kilo (Meter 1) --- NoUnit 4.0e-3 --- -(~/~) :: - ( DimEq u v - , ConversionFactor u a, ConversionFactor v a - ) - => u a -> v a -> NoUnit a -u ~/~ v = quantity $ unQuantity (toBaseUnit' u) / unQuantity (toBaseUnit' v) -{-# INLINE (~/~) #-} - -infix 6 ~/~ - --------------------------------- Exponentiation -------------------------------- - --- | Raise a quantity to a power. --- --- This is meant to be used with @'Data.Type.Int.Proxy'@ --- --- >>> Meter 2 .^. pos2 --- quantity @(Meter.^+2) 4. --- --- Usage is not recommended, as this will result non standard units. --- --- For instance: --- --- >>> (Meter 2 .*. Centi (Meter 30)) .^. pos2 --- quantity @((Meter .*. Centi Meter).^+2) 3600.0 --- -(.^.) :: forall (n :: ZZ) proxy u a. (IsUnit u, KnownInt n, Fractional a) - => u a -> proxy n -> (u .^. n) a -u .^. p = quantity $ unQuantity u ^^ intVal p -{-# INLINE (.^.) #-} - -infix 8 .^. - --- | Raise a quantity to a power and tries to normalize the resulting unit, --- without converting to base units. --- --- >>> Meter 2 ~^. pos2 --- quantity @(Meter.^+2) 4.0 --- --- >>> (Meter 2 .*. Centi (Meter 30)) ~^. pos2 --- quantity @(Centi Meter.^+4) 3.6e7 -(~^.) :: forall (n :: ZZ) proxy u a un. - (un ~ u ~^. n, FromTo' (u .^. n) un a, IsUnit u, KnownInt n, Fractional a) - => u a -> proxy n -> un a -u ~^. p = to' @un (u .^. p) -{-# INLINE (~^.) #-} - -infix 8 ~^. - --- | Same as @'(.^~)'@ but with priority to rightmost units. --- --- >>> Meter 2 .^~ pos2 --- quantity @(Meter.^+2) 4.0 --- --- >>> (Meter 2 .*. Centi (Meter 30)) ~^. pos2 --- quantity @(Meter.^+4) 0.36000000000000004 --- -(.^~ ) :: forall (n :: ZZ) proxy u a un. - (un ~ u .^~ n, FromTo' (u .^. n) un a, IsUnit u, KnownInt n, Fractional a) - => u a -> proxy n -> un a -u .^~ p = to' @un (u .^. p) -{-# INLINE (.^~ ) #-} - -infix 8 .^~ - --- | Raise a quantity to a power and convert to the standard unit. --- --- >>> Kilo (Meter 2) ~^~ neg1 --- quantity @(Meter .^- 1) 5.0e-4 --- -(~^~) :: forall (n :: ZZ) proxy u un a. - (KnownInt n, ConversionFactor u a, un ~ BaseUnitOf u .^. n ) - => u a -> proxy n -> un a -u ~^~ p = quantity @un $ unQuantity (toBaseUnit' u) ^^ intVal p -{-# INLINE (~^~) #-} - -infix 8 ~^~ - - diff --git a/src/Data/Units/Base/Convert.hs b/src/Data/Units/Base/Convert.hs deleted file mode 100644 --- a/src/Data/Units/Base/Convert.hs +++ /dev/null @@ -1,393 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.Base.Convert --- Description : Conversion between units --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Conversion between units. Use @'from'@, @'to'@, or @'fromTo'@ to convert --- between two units of the same dimension. --- --- = Implementing conversions for custom units --- --- Depending on how the custom unit is converted to its standard unit, there are --- three ways to implement its conversion summarized in the following table and --- described with further details afterwards: --- --- +-----------------------+---------------------------+----------------------+ --- | | Which instances | Note | --- | | to declare | | --- +=======================+===========================+======================+ --- | Conversion factor | @'ConversionFactor'@ and | | --- | | @'ConvertibleUnit'@ using | | --- | | the default | @'fromTo' == @ | --- | | implementations | @'fromTo''@ | --- | | for 'fromBaseUnit' and | | --- | | 'toBaseUnit' | | --- +-----------------------+---------------------------+----------------------+ --- | Affine conversion | @'ConversionFactor'@ and | | --- | | @'ConvertibleUnit'@ | | --- | | | @'fromTo' /= @ | --- | | | @'fromTo''@ | --- +-----------------------+---------------------------+----------------------+ --- | Non linear conversion | | @'from''@, @'to''@ | --- | | @'ConvertibleUnit'@ | and @'fromTo''@ | --- | | | cannot be used | --- +-----------------------+---------------------------+----------------------+ --- --- --- === Multiplication by a conversion factor --- --- For units that can be converted to and from their corresponding standard --- units by multiplication of a converion factor, you only need to declare an --- instance of @'ConversionFactor'@, like --- --- @ --- instance Fractional a => ConversionFactor Hour a where --- factor = 3600 --- --- instance Fractional a => ConvertibleUnit Hour a --- -- uses default implementations for 'fromBaseUnit' and 'toBaseUnit' --- @ --- --- >>> fromTo @Hour @Second 1 --- Second 3600.0 --- >>> fromTo' @Hour @Second 1 --- Second 3600.0 --- --- === Affine conversion (with an offset) --- --- Some units cannot be conversed by a simple multiplication. For instance, the --- conversion between Celsius degrees and Kelvin degrees involves addition --- @x °C = x + 273.15 K@. --- --- However, when considered as /differences/ of temperatures, Celsius degrees --- are converted to Kelvin degrees by a multiplication of @1@. --- --- This can be expressed by the following instances: --- --- @ --- instance Num a => ConversionFactor Celsius a where --- factor = 1 --- --- instance Fractional a => ConvertibleUnit Celsius a where --- toBaseUnit (Celsius x) = Kelvin (x - 273.15) --- fromBaseUnit (Kelvin x) = Celsius (x + 273.15) --- @ --- --- >>> fromTo @Celsius @Kelvin 0 --- Kelvin 273.15 --- >>> fromTo' @Celsius @Kelvin 0 --- Kelvin 0.0 --- --- === Other conversions --- --- Any other conversion can be implemented, like for instance logarithmic units. --- In this case, you should only give an instance for @'ConvertibleUnit'@, and --- no instance for @'ConversionFactor'@. See for instance linear picth --- @'Data.Unit.NonStd.Frequency.Tet'@. --- --------------------------------------------------------------------------------- - -module Data.Units.Base.Convert - ( DimEq - -- * Generic conversion between units - , ConvertibleUnit (..) - , FromTo - , fromTo - , from - , to - , ($~) - , (~&) - -- * Conversion using conversion factors - , ConversionFactor (..) - , toBaseUnit' - , fromBaseUnit' - , FromTo' - , fromTo' - , from' - , to' - ) - where - -import Data.Proxy -import Data.Kind -import Data.Type.Bool -import Data.Type.Equality -import GHC.TypeError - -import Data.Type.Int - -import Data.Units.Base.System - --- | A constraint to test whether two units have -type family DimEq (u :: Unit) (v :: Unit) :: Constraint where - DimEq u v = DimEqStd u v (DimOf u) (DimOf v) - -type family DimEqStd (u :: Unit) (v :: Unit) (du :: Dim) (dv :: Dim) - :: Constraint where - DimEqStd u v du dv = - ( IsUnit u - , IsUnit v - , du ~ dv - , If (du == dv) (() :: Constraint) - (TypeError ( - Text "Cannot convert unit ‘" - :<>: ShowUnitType u - :<>: Text "’ to unit ‘" - :<>: ShowUnitType v - :<>: Text "’ because their dimensions do not match." - :$$: Text "Dimension of ‘" - :<>: ShowUnitType u - :<>: Text "’ is: " - :<>: ShowDimType du - :$$: Text "Dimension of ‘" - :<>: ShowUnitType v - :<>: Text "’ is: " - :<>: ShowDimType dv - ))) - - - --- | A unit whose quantities are convertible from that unit to its corresponding --- base unit. --- --- Instances must satisfy the following law : --- --- * @'toBaseUnit' . 'fromBaseUnit' == 'id'@ --- -class (IsUnit u, IsUnit (BaseUnitOf u)) => ConvertibleUnit u a where - -- | Convert a quantity to its base unit. - -- - -- >>> import Data.Units.NonStd.Time - -- >>> toBaseUnit @Hour 1 - -- Second 3600.0 - -- >>> toBaseUnit (Hour 1) - -- Second 3600.0 - -- >>> toBaseUnit @(Kilo Meter ./. Hour) 36 - -- quantity @(Meter .*. Second .^- 1) 10.0 - -- >>> toBaseUnit (Celsius 0) - -- Kelvin 273.15 - toBaseUnit :: u a -> BaseUnitOf u a - default toBaseUnit :: ConversionFactor u a => u a -> BaseUnitOf u a - toBaseUnit = toBaseUnit' - {-# INLINE toBaseUnit #-} - - -- | Convert a quantity from its base unit to another unit. - -- - -- >>> fromBaseUnit @Hour 1800 - -- Hour 0.5 - -- >>> fromBaseUnit 1800 :: Hour Double - -- Hour 0.5 - -- >>> fromBaseUnit @(Kilo Meter ./. Hour) 10 - -- quantity @(Kilo Meter .*. Hour .^- 1) 36.0 - -- >>> fromBaseUnit @Celsius 0 - -- Celsius (-273.15) - -- - fromBaseUnit :: BaseUnitOf u a -> u a - default fromBaseUnit :: ConversionFactor u a => BaseUnitOf u a -> u a - fromBaseUnit = fromBaseUnit' - {-# INLINE fromBaseUnit #-} - - - --- | A constraint that is satisfied when both units have the same dimension and --- are such that @u@ can be converted to @v@. --- -type FromTo u v a = (DimEq u v, ConvertibleUnit u a, ConvertibleUnit v a) - --- | Conversion between two quantities with the same dimension. --- --- >>> fromTo @Celsius @Kelvin 0 --- Kelvin 273.15 --- >>> fromTo @(Milli Second) @Hour 1 --- Hour 2.7777777777777776e-7 --- >>> fromTo (Milli (Second 1)) :: Hour Double --- Hour 2.7777777777777776e-7 --- >>> fromTo @Turn @Degree (1/4) -- angle conversion --- Degree 90.0 --- >>> fromTo @(Kilo Meter ./. Hour) @(Milli Meter ./. Milli Second) 36 --- quantity @(Milli Meter .*. Milli Second .^- 1) 10.0 --- -fromTo :: FromTo u v a => u a -> v a -fromTo = fromBaseUnit . toBaseUnit -{-# INLINE fromTo #-} - --- | A mere synonym of @'fromTo'@ where it is more intuitive to use only one --- type application. --- --- >>> from @Celsius 0 :: Kelvin Double --- Kelvin 273.15 --- -from :: FromTo u v a => u a -> v a -from = fromTo -{-# INLINE from #-} - --- | Same as @'fromTo'@ but the type applications are reversed --- --- >>> to @Kelvin (Celsius 0) --- Kelvin 273.15 --- -to :: forall v u a. FromTo u v a => u a -> v a -to = fromTo -{-# INLINE to #-} - --- | A convenient operator for converting a unit before feeding it to a --- function. --- --- >>> import Linear --- >>> rotation (Radian th) = V2 (V2 (cos th) (- sin th)) (V2 (sin th) (cos th)) --- >>> rotation $~ Degree 90 --- V2 (V2 6.123031769111886e-17 (-1.0)) (V2 1.0 6.123031769111886e-17) --- -($~) :: FromTo u v a => (v a -> b) -> u a -> b -f $~ x = f (fromTo x) -{-# INLINE ($~) #-} - -infixr 0 $~ - --- | Same as @'($~)'@ but with arguments flipped. --- -(~&) :: FromTo u v a => u a -> (v a -> b) -> b -(~&) = flip ($~) -{-# INLINE (~&) #-} - -infixl 1 ~& - --------------------------------------------------------------------------------- - --- | Unit that can be converted to their corresponding standard unit by --- multiplication with a conversion factor. --- --- Instances must satisfy the following laws: --- --- * @'toBaseUnit' @u == 'quantity' ('unQuantity' q * 'factor' @u)@ --- * @'fromBaseUnit' @u == 'quantity' (''unQuantity' q / 'factor' @u)@ --- -class (ConvertibleUnit u a, Fractional a) => ConversionFactor u a where - {-# MINIMAL factor #-} - - -- | Multiplying a quantity of type @u a@ with @'factor'@ will convert it - -- to its corresponding base unit @BaseUnitOf u a@ - -- - -- >>> factor @Hour :: Double - -- 3600.0 - -- >>> factor @Celsius :: Double - -- 1.0 - -- >>> factor @(Kilo Meter ./. Hour) :: Double - -- 0.2777777777777778 - factor :: a - -instance Fractional a => ConvertibleUnit NoUnit a - -instance Fractional a => ConversionFactor NoUnit a where - factor = 1 - {-# INLINE factor #-} - -instance (Num a, ConversionFactor u a, ConversionFactor v a, IsUnit (BaseUnitOf (u .*. v))) - => ConvertibleUnit (u .*. v) a - -instance (Num a, ConversionFactor u a, ConversionFactor v a, IsUnit (BaseUnitOf (u .*. v))) - => ConversionFactor (u .*. v) a where - factor = factor @u * factor @v - {-# INLINE factor #-} - -instance (ConversionFactor u a, IsUnit (BaseUnitOf (u .^. n)), KnownInt n) - => ConvertibleUnit (u .^. n) a - -instance (ConversionFactor u a, IsUnit (BaseUnitOf (u .^. n)), KnownInt n) - => ConversionFactor (u .^. n) a where - factor = factor @u ^^ intVal (Proxy :: Proxy n) - {-# INLINE factor #-} - --- | Convert a quantity to its corresponding base unit by multiplying it --- by @'factor'@. --- --- >>> toBaseUnit' @Hour 1 --- Second 3600.0 --- >>> toBaseUnit' (Hour 1) --- Second 3600.0 --- >>> toBaseUnit' @(Kilo Meter ./. Hour) 36 --- quantity @(Meter .*. Second .^- 1) 10.0 --- >>> toBaseUnit' (Celsius 0) --- Kelvin 0.0 --- -toBaseUnit' :: forall u a. ConversionFactor u a - => u a -> BaseUnitOf u a -toBaseUnit' q = quantity (unQuantity q * factor @u) -{-# INLINE toBaseUnit' #-} - --- | Convert a standard quantity to a unit @u@ by dividing it by --- by @'factor'@. --- --- >>> fromBaseUnit' @Hour 1800 --- Hour 0.5 --- >>> fromBaseUnit' 1800 :: Hour Double --- Hour 0.5 --- >>> fromBaseUnit' @(Kilo Meter ./. Hour) 10 --- quantity @(Kilo Meter .*. Hour .^- 1) 36.0 --- >>> fromBaseUnit' @Celsius 0 --- Celsius 0.0 --- -fromBaseUnit' :: forall u a. ConversionFactor u a - => BaseUnitOf u a -> u a -fromBaseUnit' q = quantity (unQuantity q / factor @u) -{-# INLINE fromBaseUnit' #-} - --- | A constraint that is satisfied when both units have the same dimension and --- are such that @u@ can be converted to @v@ by using a conversion factor. --- -type FromTo' u v a = (DimEq u v, ConversionFactor u a, ConversionFactor v a) - --- | Conversion, using conversion factors, between two quantities with the same --- dimension --- --- >>> fromTo' @Celsius @Kelvin 0 --- Kelvin 0.0 --- >>> fromTo' @(Milli Second) @Hour 1 --- Hour 2.7777777777777776e-7 --- >>> fromTo' (Milli (Second 1)) :: Hour Double --- Hour 2.7777777777777776e-7 --- >>> fromTo' @Turn @Degree (1/4) -- angle conversion --- Degree 90.0 --- >>> fromTo' @(Kilo Meter ./. Hour) @(Milli Meter ./. Milli Second) 36 --- quantity @(Milli Meter .*. Milli Second .^- 1) 10.0 --- -fromTo' :: forall u v a. - FromTo' u v a - => u a -> v a -fromTo' q = quantity (unQuantity q * (factor @u / factor @v)) -{-# INLINE fromTo' #-} - - - --- | A mere synonym of @'fromTo''@ where it is more intuitive to use only one --- type application. --- --- >>> from' @Celsius 0 :: Kelvin Double --- Kelvin 0.0 --- -from' :: FromTo' u v a => u a -> v a -from' = fromTo' -{-# INLINE from' #-} - --- | Same as @'fromTo''@ but the type applications are reversed --- --- >>> to' @Kelvin (Celsius 0) --- Kelvin 0.0 --- -to' :: forall v u a. FromTo' u v a => u a -> v a -to' = fromTo' -{-# INLINE to' #-} - - diff --git a/src/Data/Units/Base/Prefix.hs b/src/Data/Units/Base/Prefix.hs deleted file mode 100644 --- a/src/Data/Units/Base/Prefix.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE InstanceSigs #-} - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.Base.Prefix --- Description : Unit prefix for a system of units --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Provides a way to define prefixes for any system of units. --- --------------------------------------------------------------------------------- - - -module Data.Units.Base.Prefix where - -import GHC.TypeError - -import Data.Units.Base.System -import Data.Units.Base.Convert - --- | A unit prefix, like Kilo, Milli, etc. -type Prefix = Unit -> Unit - --- | The application of a prefix to a unit must always be a unit. -class (forall (u :: Unit). IsUnit u => IsUnit (p u)) - => IsPrefix (p :: Prefix) - -instance (forall (u :: Unit). IsUnit u => IsUnit (p u)) - => IsPrefix (p :: Prefix) - --- | A prefix that has a conversion factor. --- -class (Fractional a, IsPrefix p) => PrefixFactor (p :: Prefix) a where - -- | Prefix conversion factor from the prefixed unit to the corresponding - -- standard unit - -- - -- >>> prefixFactor @Kilo - -- 1000.0 - -- - prefixFactor :: a - --- | Prefixes that can be shown as a string, or as a type error message. -class IsPrefix p => ShowPrefix (p :: Prefix) where - {-# MINIMAL showPrefix | showsPrefixPrec #-} - - -- | Allows to print units in conversion error messages - -- - -- >>> type ShowPrefix Kilo = "k" - -- - type ShowPrefixType p :: ErrorMessage - - -- | Convert a prefix to a readable string - -- - -- @'showsPrefixPrec'@ should satisfy the law : - -- - -- @showsPrefixPrec d x r ++ s == showsPrec d x (r ++ s)@ - -- - showsPrefixPrec :: Int -> ShowS - showsPrefixPrec _ = (showPrefix @p ++) - - -- | Convert a prefix to a string representing its type. - -- - -- >>> showPrefix @Kilo - -- "Kilo" - -- - showPrefix :: String - showPrefix = showsPrefix @p "" - - -- | Same as @'showsPrefixPrec'@ but for pretty printing. - -- - -- @'prettysPrefixPrec'@ should satisfy the law : - -- - -- @prettysPrefixPrec d x r ++ s == prettysPrec d x (r ++ s)@ - -- - prettysPrefixPrec :: Int -> ShowS - prettysPrefixPrec _ = (prettyPrefix @p ++) - - -- | Same as @'showPrefix'@ but for pretty printing - -- - -- >>> prettyPrefix @Kilo - -- "k" - prettyPrefix :: String - prettyPrefix = prettysPrefix @p "" - --- | Equivalent to 'showsPrefixPrec' with a precedence of 0. -showsPrefix :: forall p. ShowPrefix p => ShowS -showsPrefix = showsPrefixPrec @p 0 - --- | Equivalent to 'prettysPrefixPrec' with a precedence of 0. -prettysPrefix :: forall p. ShowPrefix p => ShowS -prettysPrefix = prettysPrefixPrec @p 0 - - --- | A prefix that can represent any prefix. --- --- This can be used with the `deriving via` mechanism to derive some of the --- prefix instances. --- -newtype MetaPrefix (p :: Prefix) (u :: Unit) a = MetaPrefix (p u a) - deriving Show via (MetaUnit (p u) a) - -instance PrefixFactor p a => PrefixFactor (MetaPrefix p) a where - prefixFactor = prefixFactor @p - {-# INLINE prefixFactor #-} - -instance - (PrefixFactor p a, ConversionFactor u a, BaseUnitOf (p u) ~ BaseUnitOf u) - => ConversionFactor (MetaPrefix p u) a where - factor = prefixFactor @p * factor @u - {-# INLINE factor #-} - -instance - (PrefixFactor p a, ConvertibleUnit u a, BaseUnitOf (p u) ~ BaseUnitOf u) - => ConvertibleUnit (MetaPrefix p u) a where - toBaseUnit (MetaPrefix a) = prefixToBaseUnit @p @u a - {-# INLINE toBaseUnit #-} - fromBaseUnit a = MetaPrefix $ prefixFromBaseUnit @p @u a - {-# INLINE fromBaseUnit #-} - --- | Convert a prefixed unit to the corresponding standard unit. --- -prefixToBaseUnit :: forall (p :: Prefix) (u :: Unit) a. - (PrefixFactor p a, ConvertibleUnit u a, BaseUnitOf (p u) ~ BaseUnitOf u) - => p u a -> BaseUnitOf u a -prefixToBaseUnit u = - toBaseUnit @u $ quantity @u (prefixFactor @p * unQuantity u) -{-# INLINE prefixToBaseUnit #-} - --- | Convert a standard unit to the corresponding prefixed unit. --- -prefixFromBaseUnit :: forall (p :: Prefix) (u :: Unit) a. - (PrefixFactor p a, ConvertibleUnit u a - , BaseUnitOf (p u) a ~ BaseUnitOf u a) - => BaseUnitOf (p u) a -> p u a -prefixFromBaseUnit a = quantity $ unQuantity (fromBaseUnit @u a) / prefixFactor @p -{-# INLINE prefixFromBaseUnit #-} - - -instance ShowPrefix p => ShowPrefix (MetaPrefix p) where - type ShowPrefixType (MetaPrefix p) = ShowPrefixType p - showsPrefixPrec = showsPrefixPrec @p - showPrefix = showPrefix @p - prettysPrefixPrec = prettysPrefixPrec @p - prettyPrefix = prettyPrefix @p - -instance (IsPrefix p, IsUnit u) - => IsUnit (MetaPrefix p u) where - type DimOf (MetaPrefix p u) = DimOf u - -instance (ShowPrefix p, ShowUnit u) - => ShowUnit (MetaPrefix p u) where - type ShowUnitType (MetaPrefix p u) = ShowPrefixType p :<>: ShowUnitType u - showsUnitPrec d = showParen (d > 10) $ - showsPrefix @p . showString " " . showsUnitPrec @u 11 - prettysUnitPrec d = showParen (d > 10) $ - prettysPrefix @p . prettysUnit @u - diff --git a/src/Data/Units/Base/System.hs b/src/Data/Units/Base/System.hs deleted file mode 100644 --- a/src/Data/Units/Base/System.hs +++ /dev/null @@ -1,916 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE QuantifiedConstraints #-} - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.Base.System --- Description : System of units --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Describe a system of units and their dimensions. --- --------------------------------------------------------------------------------- - -module Data.Units.Base.System - ( - -- * Dimensions - Dim - , DimId - , IsDim (..) - , ShowDim (..) - , prettysDim - , showsDim - , showDimOf - , prettyDimOf - , putDimOf - , NormalizeDim - - -- * Units - , Unit - , ShowUnit (..) - , prettysUnit - , showsUnit - , prettyUnitInfo - , putInfoU - , IsUnit (..) - - -- * Quantity - , quantity - , unQuantity - , showQuantity - , prettyQuantity - , putQuantity - , putInfoQ - - -- * Unit and dimension constructors - , NoDim (..) - , NoUnit (..) - , MetaUnit (..) - , type (.*.) (..) - , type (.^.) (..) - , type (.^+) - , type (.^-) - - - -- * Unit normalization - , BaseUnitOf - , NormalizeUnitL - , NormalizeUnitR - -- ** Normalization operators - -- *** Multiplication - , type (.*~) - , type (~*.) - , type (~*~) - -- *** Division - , type (./.) - , type (./~) - , type (~/.) - , type (~/~) - -- *** Exponentiation - , type (~^.) - , type (.^~) - , type (~^~) - ) - where - -import Data.Coerce -import Data.Kind -import Data.Proxy -import Data.Type.Ord -import Data.Type.Bool -import Data.Type.Equality -import GHC.TypeError -import GHC.TypeLits - -import Data.Type.Int - - ----------------------------------- Dimension ----------------------------------- - --- | A unit dimension. --- --- Modeled as a newtype constructor, just like @'Unit'@. --- --- >>> type Speed = Length -/- Time --- -type Dim = Type -> Type - -class (IsUnit (DimToUnit d), forall a. Coercible (d a) a) - => IsDim (d :: Dim) where - type DimToUnit d :: Unit - --- | A dimension identifier. --- --- This identifiers allow to sort the units when computing the standard unit. --- --- >>> type instance DimId Length = 300 --- --- >>> :kind! BaseUnitOf (Second .^- 1 .*. Meter) --- Meter .*. (Second .^. Neg 1) --- --- --- Two different dimensions must have different identifiers. To make sure this --- remains true, we maintain here an /exhaustive/ list of dimensions declared --- in this package /and/ any package that depends on it. Please raise an issue --- if you added a new dimension. --- --- [This package:] --- --- +----------------------------------------------------+----------------+ --- | Dimension | Id | --- +====================================================+================+ --- | Reserved | 0 | --- +----------------------------------------------------+----------------+ --- | @'NoDim'@ | 1 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.AngleSI.System.Angle'@ | 1000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.Mass'@ | 2000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.Length'@ | 3000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.Time'@ | 4000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.ElectricCurrent'@ | 5000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.Temperature'@ | 6000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.AmountOfSubstance'@ | 7000 | --- +----------------------------------------------------+----------------+ --- | @'Data.Units.SI.System.LuminousIntensity'@ | 8000 | --- +----------------------------------------------------+----------------+ --- -type family DimId (d:: Dim) :: ZZ - --- | Dimensions that can be shown as a string, or as a type error message. --- -class ShowDim (d :: Dim) where - {-# MINIMAL showDim | showsDimPrec #-} - - -- | Allows to print dimensions in conversion error messages - -- - -- >>> type ShowDimType Length = "L" - -- - type ShowDimType d :: ErrorMessage - - -- | Convert a dimension to a readable string - -- - -- @'showsDimPrec'@ should satisfy the law : - -- - -- @showsDimPrec d x r ++ s == showsPrec d x (r ++ s)@ - showsDimPrec :: Int -> ShowS - showsDimPrec _ = (showDim @d ++) - - -- | Convert a dimension to a string representing its type. - -- - -- >>> showDim @(Length ./. Time) - -- "Length .*. Time.^-1" - showDim :: String - showDim = showsDim @d "" - - -- | Same as @'showsDimPrec'@ but for pretty printing. - -- - -- @'prettysDimPrec'@ should satisfy the law : - -- - -- @prettysDimPrec d x r ++ s == prettysPrec d x (r ++ s)@ - -- - prettysDimPrec :: Int -> ShowS - prettysDimPrec _ = (prettyDim @d ++) - - -- | Same as @'showDim'@ but for pretty printing - -- - -- >>> putStrLn $ prettyDim @(Kilo Meter ./. Second) - -- km.s⁻¹ - -- - prettyDim :: String - prettyDim = prettysDim @d "" - --- | Equivalent to 'showsDimPrec' with a precedence of 0. --- -showsDim :: forall d. ShowDim d => ShowS -showsDim = showsDimPrec @d 0 - --- | Equivalent to 'prettysDimPrec' with a precedence of 0. --- -prettysDim :: forall d. ShowDim d => ShowS -prettysDim = prettysDimPrec @d 0 - --- | Show the dimension of a quantity. --- --- >>> showDimOf (quantity @(Kilo Meter ./. Second) 1) --- "Length .*. Time.^-1" --- -showDimOf :: forall u a. (IsUnit u, ShowDim (DimOf u)) => u a -> String -showDimOf _ = showDim @(DimOf u) - --- | Same as 'showDimOf' but for pretty printing. --- >>> putStrLn $ prettyDimOf (quantity @(Kilo Meter ./. Second) 1) --- L.T⁻¹ -prettyDimOf :: forall u a. (IsUnit u, ShowDim (DimOf u)) => u a -> String -prettyDimOf _ = prettyDim @(DimOf u) - --- | Print the dimension of a quantity. --- --- >>> putDimOf (quantity @(Kilo Meter ./. Second) 1) --- L.T⁻¹ --- -putDimOf :: forall u a. (IsUnit u, ShowDim (DimOf u)) => u a -> IO () -putDimOf = putStrLn . prettyDimOf - - - --- | The dimension of non dimensional quantities --- -newtype NoDim a = NoDim a - deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real - , RealFrac, RealFloat, Bounded, Enum, Semigroup, Monoid, Functor) - - -type instance DimId NoDim = Pos 1 - -instance ShowDim NoDim where - type ShowDimType NoDim = Text "NoDim" - showDim = "NoDim" - prettyDim = "NoDim" - - -type family CmpDim (d :: Dim) (e :: Dim) :: Ordering where - CmpDim (d .*. d') (e .*. e') = - If (CmpDim d e == 'EQ) (CmpDim d' e') (CmpDim d e) - CmpDim (d .*. d') e ='LT - CmpDim d (e .*. e') = 'GT - CmpDim (d .^. dn) (e .^. en) = - If (CmpDim d e == 'EQ) (CmpSigned dn en) (CmpDim d e) - CmpDim (d .^. dn) e = - If (CmpDim d e == 'EQ) (CmpSigned dn (Pos 1)) (CmpDim d e) - CmpDim d (e .^. en) = - If (CmpDim d e == 'EQ) (CmpSigned (Pos 1) en) (CmpDim d e) - CmpDim d e = CmpSigned (DimId d) (DimId e) - - --------------------------- Dimension normalization --------------------------- - - --- | Helper type family for defining DimOf for .*. and .^. --- -type family DimOf' (u :: Unit) :: Dim where - DimOf' u = NormalizeDim (UnitToDim u) - -type family UnitToDim (u :: Unit) :: Dim where - UnitToDim (u .*. v) = UnitToDim u .*. UnitToDim v - UnitToDim (u .^. n) = UnitToDim u .^. n - UnitToDim u = DimOf u - -type NormalizeDim d = NormalizeFlatDim (Flatten d) - -type family Flatten u where - Flatten (u .*. v) = Flatten u .*. Flatten v - Flatten ((u .*. v) .^. n) = Flatten (u .^. n) .*. Flatten (v .^. n) - Flatten ((u .^. n) .^. m) = Flatten (u .^. Mul n m) - Flatten (u .^. n) = u .^. n - Flatten u = u - -type family NormalizeFlatDim d where - NormalizeFlatDim (d .*. NoDim) = NormalizeFlatDim d - NormalizeFlatDim (NoDim .*. e) = NormalizeFlatDim e - NormalizeFlatDim ((d .*. e) .*. f) = NormalizeFlatDim (d .*. (e .*. f)) - NormalizeFlatDim (d .*. e) = - InsertDim (NormalizeFlatDim d) (NormalizeFlatDim e) - NormalizeFlatDim (NoDim .^. n) = NoDim - NormalizeFlatDim (d .^. n) = NormalizeExpDim (d .^. n) - NormalizeFlatDim d = d - -type family InsertDim d e where - InsertDim NoDim e = e - InsertDim d NoDim = d - InsertDim d (e .*. f) = - InsertCmpDim (Compare (DimId d) (DimId e)) d (e .*. f) - InsertDim d e = - InsertCmpDim (Compare (DimId d) (DimId e)) d e - -type family InsertCmpDim cmp d v where - InsertCmpDim 'LT d (e .*. f) = d .*. e .*. f - InsertCmpDim 'GT d (e .*. f) = e .*. InsertDim d f - InsertCmpDim 'EQ d (e .*. f) = MulNoDim (MulPowDim d e) f - InsertCmpDim 'LT d e = d .*. e - InsertCmpDim 'GT d e = e .*. d - InsertCmpDim 'EQ d e = MulPowDim d e - -type family MulNoDim d e where - MulNoDim NoDim e = e - MulNoDim d NoDim = d - MulNoDim d e = d .*. e - -type family MulPowDim d e where - MulPowDim (d .^. n) (d .^. m) = NormalizeExpDim (d .^. Add n m) - MulPowDim d (d .^. m) = NormalizeExpDim (d .^. Add (Pos 1) m) - MulPowDim (d .^. n) d = NormalizeExpDim (d .^. Add n (Pos 1)) - MulPowDim d d = d .^. Pos 2 - MulPowDim d e = TypeError ( - Text "Failed to multiply two different units ‘" - :<>: ShowUnitType d - :<>: Text "’ and ‘" - :<>: ShowUnitType e - :<>: Text "’ with the same dimension ‘" - :<>: ShowDimType (DimOf d) - :<>: Text "’." - :$$: Text "Hint : Did you try to multiply via (.*.) two quantities with" - :$$: Text " the same dimension but different units ?" - :$$: Text "If so, you might want to use (~*-), (-*~) or (~*~) instead. " - ) - -type family NormalizeExpDim u where - NormalizeExpDim (u .^. Pos 1) = u - NormalizeExpDim (u .^. Zero) = NoDim - NormalizeExpDim u = u - - ------------------------------------- Units ------------------------------------- - --- | A unit is represented by a newtype constructor. A quantity of some unit --- @u@ is of type @u a@. --- -type Unit = Type -> Type - --- | Any unit must have a dimension. Additionally, a unit is a newtype --- constructor : a quantity @u a@ can always be coerced to its magnitude @a@. --- -class (forall a. Coercible (u a) a) => IsUnit (u :: Unit) where - type DimOf u :: Dim - --- | Make a quantity out of any numerical value (called the /magnitude/ of that --- quantity) --- --- >>> quantity @(Meter ./. Second) 1 --- quantity @(Meter .*. Second .^- 1) 1 -quantity :: forall u a. IsUnit u => a -> u a -quantity = coerce -{-# INLINE quantity #-} - --- | Get the magnitude of a quantity. --- --- @unQuantity (quantity @u a) === a @ --- -unQuantity :: IsUnit u => u a -> a -unQuantity = coerce -{-# INLINE unQuantity #-} - --- | Units that can be shown as a string, or as a type error message. --- -class IsUnit u => ShowUnit (u :: Unit) where - {-# MINIMAL showUnit | showsUnitPrec #-} - - -- | Allows to print units in conversion error messages - -- - -- >>> type ShowUnit Meter = "m" - -- - type ShowUnitType u :: ErrorMessage - - -- | Convert a unit to a readable string - -- - -- @'showsUnitPrec'@ should satisfy the law : - -- - -- @showsUnitPrec d x r ++ s == showsPrec d x (r ++ s)@ - -- - showsUnitPrec :: Int -> ShowS - showsUnitPrec _ = (showUnit @u ++) - - -- | Convert a unit to a string representing its type. - -- - -- >>> showUnit @(Kilo Meter ./. Second) - -- "Kilo Meter .*. Second.^-1" - showUnit :: String - showUnit = showsUnit @u "" - - -- | Same as @'showsUnitPrec'@ but for pretty printing. - -- - prettysUnitPrec :: Int -> ShowS - prettysUnitPrec _ = (prettyUnit @u ++) - - -- | Same as @'showUnit'@ but for pretty printing - -- - -- >>> putStrLn $ prettyUnit @(Kilo Meter ./. Second) - -- km.s⁻¹ - -- - prettyUnit :: String - prettyUnit = prettysUnit @u "" - - --- | Equivalent to 'showsUnitPrec' with a precedence of 0. --- -showsUnit :: forall u. ShowUnit u => ShowS -showsUnit = showsUnitPrec @u 0 - --- | Equivalent to 'prettysUnitPrec' with a precedence of 0. --- -prettysUnit :: forall u. ShowUnit u => ShowS -prettysUnit = prettysUnitPrec @u 0 - --- | Pretty print information about a unit, its dimension and its normalized --- form. --- -prettyUnitInfo :: forall u du nu. - ( du ~ DimOf u - , nu ~ BaseUnitOf u - , ShowUnit u - , ShowDim du - , ShowUnit nu - ) => String -prettyUnitInfo = - "Unit: " ++ showUnit @u ++ "\n" ++ - " abbr: " ++ prettyUnit @u ++ "\n" ++ - "Dimension: " ++ showDim @du ++ "\n" ++ - " abbr: " ++ prettyDim @du ++ "\n" ++ - "Normalized: " ++ showUnit @nu ++ "\n" ++ - " abbr: " ++ prettyUnit @nu ++ "\n" - --- | Print information about a unit, its dimension and its normalized form. --- --- >>> putInfoU @Newton --- Unit: Newton --- abbr: N --- Dimension: Mass .*. Length .*. Time.^-2 --- abbr: M⋅L⋅T⁻² --- Normalized: Kilo Gram .*. Meter .*. Second.^-2 --- abbr: kg⋅m⋅s⁻² --- -putInfoU :: forall u du nu. - ( du ~ DimOf u - , nu ~ BaseUnitOf u - , ShowUnit u - , ShowDim du - , ShowUnit nu - ) => IO () -putInfoU = putStr $ prettyUnitInfo @u - --- | Same as 'prettyUnitInfo' but for quantities. --- -prettyQuantityInfo :: forall u a. - ( ShowUnit u - , ShowDim (DimOf u) - , ShowUnit (BaseUnitOf u) - , Show a - ) => u a -> String -prettyQuantityInfo u = prettyUnitInfo @u ++ - "Magnitude: " ++ show (unQuantity u) ++ "\n" - --- | Same as 'putInfoU' but for quantities. --- --- >>> putInfoQ (Newton 4) --- Unit: Newton --- abbr: N --- Dimension: Mass .*. Length .*. Time.^-2 --- abbr: M⋅L⋅T⁻² --- Normalized: Kilo Gram .*. Meter .*. Second.^-2 --- abbr: kg⋅m⋅s⁻² --- Magnitude: 4 -putInfoQ :: forall u a. - ( ShowUnit u - , ShowDim (DimOf u) - , ShowUnit (BaseUnitOf u) - , Show a - ) => u a -> IO () -putInfoQ u = putStr $ prettyQuantityInfo @u u - - --- | Same as 'showsUnitPrec' but for quantities. --- -showsQuantityPrec :: forall u a. (ShowUnit u, Show a) => Int -> u a -> ShowS -showsQuantityPrec d u = showParen (d > 10) $ - showString "quantity @" . showsUnitPrec @u 11 . showString " " . - showsPrec 11 (unQuantity u) - --- | Equivalent to 'showsQuantityPrec' with a precedence of 0. --- -showsQuantity :: (ShowUnit u, Show a) => u a -> ShowS -showsQuantity = showsQuantityPrec 0 - --- | Same as 'showUnit' but for quantities --- --- >>> showQuantity (quantity @(Kilo Meter ./. Second) 1) --- "quantity @(Kilo Meter .*. Second.^-1) 1.0" --- -showQuantity :: (ShowUnit u, Show a) => u a -> String -showQuantity u = showsQuantity u "" - --- | Same as 'prettyUnit' but for quantities --- --- >>> putStrLn $ prettyQuantity (quantity @(Kilo Meter ./. Second) 1) --- 1 km.s⁻¹ --- -prettyQuantity :: forall u a. (ShowUnit u, Show a) => u a -> String -prettyQuantity u = show (unQuantity u) ++ " " ++ prettyUnit @u - --- | Pretty print a quantity. --- --- >>> putQuantity (quantity @(Kilo Meter ./. Second) 1) --- 1 km.s⁻¹ -putQuantity :: (Show a, ShowUnit u) => u a -> IO () -putQuantity = putStrLn . prettyQuantity - - --------------------------------------------------------------------------------- - - --- | A unit that can represent any unit. --- --- This can be used with the `deriving via` mechanism to derive some of the --- unit instances. --- -newtype MetaUnit (u :: Unit) a = MetaUnit a - deriving ( Eq, Ord, Num, Fractional, Floating, Real - , RealFrac, RealFloat, Bounded, Enum, Semigroup, Monoid, Functor) - -instance ShowUnit u => ShowUnit (MetaUnit u) where - type ShowUnitType (MetaUnit u) = ShowUnitType u - prettysUnitPrec = prettysUnitPrec @u - showsUnitPrec = showsUnitPrec @u - -instance (Show a, ShowUnit u) => Show (MetaUnit u a) where - showsPrec = showsQuantityPrec - -instance IsUnit u => IsUnit (MetaUnit u) where - type DimOf (MetaUnit u) = DimOf u - --------------------------------------------------------------------------------- - --- | A unit that has no dimension. --- --- @ --- type MyHertz = NoUnit ./. Second --- @ --- -newtype NoUnit a = NoUnit a - deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real - , RealFrac, RealFloat, Functor) - -instance IsUnit NoUnit where - type DimOf NoUnit = NoDim - -instance IsDim NoDim where - type DimToUnit NoDim = NoUnit - - --- | Multiplication of two units. --- --- @ --- type MyForceMoment = Newton .*. Meter --- @ --- -newtype ((u :: Unit) .*. (v :: Unit)) a = MulUnit a - deriving ( Eq, Ord, Num, Fractional, Floating, Real - , RealFrac, RealFloat, Functor) - deriving Show via MetaUnit (u .*. v) a - -infixr 7 .*. - -instance (ShowUnit u, ShowUnit v) => ShowUnit (u .*. v) where - type ShowUnitType (u .*. v) = - ShowUnitType u - :<>: Text "⋅" :<>: ShowUnitType v - prettysUnitPrec d = showParen (d > 7) $ - prettysUnitPrec @u 7 . showString "⋅" . prettysUnitPrec @v 7 - showsUnitPrec d = showParen (d > 7) $ - showsUnitPrec @u 7 . showString " .*. " . showsUnitPrec @v 7 - -instance (ShowDim u, ShowDim v) => ShowDim (u .*. v) where - type ShowDimType (u .*. v) = - ShowDimType u - :<>: Text "⋅" :<>: ShowDimType v - prettysDimPrec d = showParen (d > 7) $ - prettysDimPrec @u 7 . showString "⋅" . prettysDimPrec @v 7 - showsDimPrec d = showParen (d > 7) $ - showsDimPrec @u 7 . showString " .*. " . showsDimPrec @v 7 - - -instance (IsUnit u, IsUnit v) => IsUnit (u .*. v) where - type DimOf (u .*. v) = DimOf' (u .*. v) - -instance (IsDim d, IsDim e) => IsDim (d .*. e) where - type DimToUnit (d .*. e) = DimToUnit d .*. DimToUnit e - - - --------------------------------- Unit division --------------------------------- - -type family InverseUnit u where - InverseUnit (u .*. v) = InverseUnit u .*. InverseUnit v - InverseUnit (u .^. n) = NormalizeExp (u .^. Negate n) - InverseUnit NoUnit = NoUnit - InverseUnit u = u .^. Neg 1 - --- | Division of two units. --- --- @ --- type MySpeed a = (Meter ./. Second) a --- type MyMolarEntropy a = (Joule ./. Mole .*. Kelvin) a --- @ --- --- Notice that multiplication has priority over division. --- -type family (u :: Unit) ./. (v :: Unit) :: Unit where - u ./. v = u .*. InverseUnit v - -infix 6 ./. - - ------------------------------ Unit exponentiation ------------------------------ - - --- | Exponentiation of a unit --- --- @ --- type Acceleration = Meter .*. Second .^. Neg 2 --- @ --- -newtype ((u :: Unit) .^. (n :: ZZ)) a = PowUnit a - deriving ( Eq, Ord, Num, Fractional, Floating, Real - , RealFrac, RealFloat, Functor) - deriving Show via MetaUnit (u .^. n) a -infix 8 .^. - --- | Positive exponentiation of a unit --- --- @ --- type Area = Meter .^+ 2 --- @ --- -type a .^+ b = a .^. Pos b -infix 8 .^+ - --- | Negative exponentiation of a unit --- --- @ --- type Hertz = Second .^- 1 --- @ --- -type a .^- b = a .^. Neg b -infix 8 .^- - -type instance DimId (d .^. n) = DimId d - -type family ShowIntExponent (n :: ZZ) :: ErrorMessage where - ShowIntExponent (Pos n) = - If (n <=? 9) (ShowDigitExponent n) (Text "^" :<>: ShowType n) - ShowIntExponent Zero = Text "⁰" - ShowIntExponent (Neg n) = - If (n <=? 9) (Text "⁻" :<>: ShowDigitExponent n) - (Text "^-" :<>: ShowType n) - -type family ShowDigitExponent (n :: Nat) :: ErrorMessage where - ShowDigitExponent 0 = Text "⁰" - ShowDigitExponent 1 = Text "¹" - ShowDigitExponent 2 = Text "²" - ShowDigitExponent 3 = Text "³" - ShowDigitExponent 4 = Text "⁴" - ShowDigitExponent 5 = Text "⁵" - ShowDigitExponent 6 = Text "⁶" - ShowDigitExponent 7 = Text "⁷" - ShowDigitExponent 8 = Text "⁸" - ShowDigitExponent 9 = Text "⁹" - -instance IsUnit u => IsUnit (u .^. n) where - type DimOf (u .^. n) = DimOf' (u .^. n) - -instance IsDim d => IsDim (d .^. n) where - type DimToUnit (d .^. n) = DimToUnit d .^. n - - -instance (ShowUnit u, KnownInt n) => ShowUnit (u .^. n) where - type ShowUnitType (u .^. n) = - ShowUnitType u :<>: ShowIntExponent n - prettysUnitPrec d = showParen (d >= 8) $ - prettysUnitPrec @u 8 . showString (toSuperscript <$> show (intVal (Proxy :: Proxy n))) - showsUnitPrec d = showParen (d >= 8) $ - if n >= 0 then - showsUnitPrec @u 8 . showString ".^+" . shows n - else - showsUnitPrec @u 8 . showString ".^-" . shows (-n) - where - n = intVal (Proxy :: Proxy n) - -instance (ShowDim u, KnownInt n) => ShowDim (u .^. n) where - type ShowDimType (u .^. n) = - ShowDimType u :<>: ShowIntExponent n - prettysDimPrec d = showParen (d >= 8) $ - prettysDimPrec @u 8 . showString (toSuperscript <$> show (intVal (Proxy :: Proxy n))) - showsDimPrec d = showParen (d >= 8) $ - if n >= 0 then - showsDimPrec @u 8 . showString ".^+" . shows n - else - showsDimPrec @u 8 . showString ".^-" . shows (-n) - where - n = intVal (Proxy :: Proxy n) - - -toSuperscript :: Char -> Char -toSuperscript '0' = '⁰' -toSuperscript '1' = '¹' -toSuperscript '2' = '²' -toSuperscript '3' = '³' -toSuperscript '4' = '⁴' -toSuperscript '5' = '⁵' -toSuperscript '6' = '⁶' -toSuperscript '7' = '⁷' -toSuperscript '8' = '⁸' -toSuperscript '9' = '⁹' -toSuperscript '+' = '⁺' -toSuperscript '-' = '⁻' -toSuperscript ')' = '⁾' -toSuperscript '(' = '⁽' -toSuperscript '=' = '⁼' -toSuperscript a = a - ------------------------------- Unit normalization ------------------------------ - --- | Normalizes a unit by converting it to a product of exponentiations of base --- units. -type BaseUnitOf u = DimToUnit (DimOf u) - --- | Multiplies two units and normalizes the result. --- -type (u :: Unit) ~*~ (v :: Unit) = BaseUnitOf (u .*. v) - -infixr 7 ~*~ - --- | Divides two units and normalizes the result. --- -type (u :: Unit) ~/~ (v :: Unit) = BaseUnitOf (u ./. v) - -infixr 6 ~/~ - --- | Exponentiates a unit and normalizes the result. --- -type (u :: Unit) ~^~ (n :: ZZ) = BaseUnitOf (u .^. n) - -infixr 8 ~^~ - - -type family MulNoUnit d e where - MulNoUnit NoUnit e = e - MulNoUnit d NoUnit = d - MulNoUnit d e = d .*. e - -type family NormalizeExp u where - NormalizeExp (u .^. Pos 1) = u - NormalizeExp (u .^. Zero) = NoUnit - NormalizeExp u = u - - ---------------------- Unit normalization left priority ---------------------- - --- | Tries to normalize a unit without converting to base units. --- --- >>> :kind! NormalizeUnitR (Minute .*. Second) --- Minute .^. Pos 2 --- -type NormalizeUnitL u = NormalizeFlatUnitL (Flatten u) - --- | Multiplies two units and use left weak normalization. -type (u :: Unit) .*~ (v :: Unit) = NormalizeUnitL (u .*. v) - -infixr 7 .*~ - --- | Divides two units and use left weak normalization. -type (u :: Unit) ./~ (v :: Unit) = NormalizeUnitL (u ./. v) - -infixr 6 ./~ - --- | Exponentiates a unit and use left weak normalization. -type (u :: Unit) .^~ (n :: ZZ) = NormalizeUnitL (u .^. n) - -infixr 8 .^~ - - -type family NormalizeFlatUnitL u where - NormalizeFlatUnitL (u .*. NoUnit) = NormalizeFlatUnitL u - NormalizeFlatUnitL (NoUnit .*. v) = NormalizeFlatUnitL v - NormalizeFlatUnitL ((u .*. v) .*. w) = NormalizeFlatUnitL (u .*. (v .*. w)) - NormalizeFlatUnitL (u .*. v) = - InsertUnitL (NormalizeFlatUnitL u) (NormalizeFlatUnitL v) - NormalizeFlatUnitL (NoUnit .^. n) = NoUnit - NormalizeFlatUnitL (u .^. n) = NormalizeExp (u .^. n) - NormalizeFlatUnitL u = u - -type family InsertUnitL u v where - InsertUnitL NoUnit v = v - InsertUnitL u NoUnit = u - InsertUnitL (u .*. v) w = - TypeError (Text - "Insert unit : Removing left association failed in NormalizeFlatUnitL") - InsertUnitL (u .^. n) (v .^. m .*. w) = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m .*. w) - InsertUnitL (u .^. n) (v .*. w) = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .*. w) - InsertUnitL (u .^. n) (v .^. m) = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m) - InsertUnitL (u .^. n) v = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) v - InsertUnitL u (v .^. m .*. w) = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) u (v .^. m .*. w) - InsertUnitL u (v .*. w) = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) u (v .*. w) - InsertUnitL u (v .^. m) = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) u (v .^. m) - InsertUnitL u v = - InsertCmpL (CmpDim (DimOf u) (DimOf v)) u v - -type family InsertCmpL cmp u v where - InsertCmpL 'LT u (v .*. w) = u .*. v .*. w - InsertCmpL 'GT u (v .*. w) = v .*. InsertUnitL u w - InsertCmpL 'EQ u (v .*. w) = MulNoUnit (MulSameDimL u v) w - InsertCmpL 'LT u v = u .*. v - InsertCmpL 'GT u v = v .*. u - InsertCmpL 'EQ u v = MulSameDimL u v - -type family MulSameDimL u v where - MulSameDimL (u .^. n) (v .^. m) = NormalizeExp (u .^. Add n m) - MulSameDimL u (v .^. m) = NormalizeExp (u .^. Add (Pos 1) m) - MulSameDimL (u .^. n) v = NormalizeExp (u .^. Add n (Pos 1)) - MulSameDimL u v = u .^. Pos 2 - - - ----------------------- Unit normalization right priotiy ----------------------- - --- The only difference with right is MulSameDim - - --- | Tries to normalize a unit without converting to base units. When two units --- have the same dimension, they will be collapsed to an exponentiation right --- most unit. --- --- >>> :kind! NormalizeUnitR (Minute .*. Second) --- Second .^. Pos 2 --- -type NormalizeUnitR u = NormalizeFlatUnitR (Flatten u) - --- | Same as @'(~*.)'@ but with priority to right most units -type (u :: Unit) ~*. (v :: Unit) = NormalizeUnitR (u .*. v) - -infixr 7 ~*. - --- | Same as @'(~/.)'@ but with priority to right most units -type (u :: Unit) ~/. (v :: Unit) = NormalizeUnitR (u ./. v) - -infixr 7 ~/. - --- | Same as @'(.^~)'@ but with priority to right most units -type (u :: Unit) ~^. (n :: ZZ) = NormalizeUnitR (u .^. n) - -infix 8 ~^. - - -type family NormalizeFlatUnitR u where - NormalizeFlatUnitR (u .*. NoUnit) = NormalizeFlatUnitR u - NormalizeFlatUnitR (NoUnit .*. v) = NormalizeFlatUnitR v - NormalizeFlatUnitR ((u .*. v) .*. w) = NormalizeFlatUnitR (u .*. (v .*. w)) - NormalizeFlatUnitR (u .*. v) = - InsertUnitR (NormalizeFlatUnitR u) (NormalizeFlatUnitR v) - NormalizeFlatUnitR (NoUnit .^. n) = NoUnit - NormalizeFlatUnitR (u .^. n) = NormalizeExp (u .^. n) - NormalizeFlatUnitR u = u - -type family InsertUnitR u v where - InsertUnitR NoUnit v = v - InsertUnitR u NoUnit = u - InsertUnitR (u .*. v) w = - TypeError (Text - "Insert unit : Removing left association failed in NormalizeFlatUnitR") - InsertUnitR (u .^. n) (v .^. m .*. w) = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m .*. w) - InsertUnitR (u .^. n) (v .*. w) = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .*. w) - InsertUnitR (u .^. n) (v .^. m) = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m) - InsertUnitR (u .^. n) v = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) v - InsertUnitR u (v .^. m .*. w) = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) u (v .^. m .*. w) - InsertUnitR u (v .*. w) = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) u (v .*. w) - InsertUnitR u (v .^. m) = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) u (v .^. m) - InsertUnitR u v = - InsertCmpR (CmpDim (DimOf u) (DimOf v)) u v - -type family InsertCmpR cmp u v where - InsertCmpR 'LT u (v .*. w) = u .*. v .*. w - InsertCmpR 'GT u (v .*. w) = v .*. InsertUnitR u w - InsertCmpR 'EQ u (v .*. w) = MulNoUnit (MulSameDimR u v) w - InsertCmpR 'LT u v = u .*. v - InsertCmpR 'GT u v = v .*. u - InsertCmpR 'EQ u v = MulSameDimR u v - -type family MulSameDimR u v where - MulSameDimR (u .^. n) (v .^. m) = NormalizeExp (v .^. Add n m) - MulSameDimR u (v .^. m) = NormalizeExp (v .^. Add (Pos 1) m) - MulSameDimR (u .^. n) v = NormalizeExp (v .^. Add n (Pos 1)) - MulSameDimR u v = v .^. Pos 2 diff --git a/src/Data/Units/Base/TH.hs b/src/Data/Units/Base/TH.hs deleted file mode 100644 --- a/src/Data/Units/Base/TH.hs +++ /dev/null @@ -1,441 +0,0 @@ - -{-# LANGUAGE TemplateHaskell #-} - - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.Base.TH --- Description : Template Haskell quasi quoter for unit declaration --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --------------------------------------------------------------------------------- - - -module Data.Units.Base.TH - ( -- * Units - mkUnit - , mkUnitNoFactor - , mkBaseUnit - -- * Dimensions - , mkDim - -- * Prefixes - , mkPrefix - ) - where - -import GHC.TypeError - -import Language.Haskell.TH - -import Data.Type.Int -import Data.Units.Base.System -import Data.Units.Base.Convert -import Data.Units.Base.Prefix - ------------------------------------- Units ------------------------------------- - --- | List of derived class for a unit. --- -deriveList :: [Name] -deriveList = - [''Eq - , ''Ord - , ''Num - , ''Fractional - , ''Floating - , ''Real - , ''RealFrac - , ''RealFloat - ] - --- | List of derived classes for a unit. --- -deriveListUnit :: [Name] -deriveListUnit = ''Show : deriveList - --- | Make a newtype of the form --- --- @ --- newtype Minute a = Minute a --- deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real --- , RealFrac, RealFloat) --- @ --- -mkUnitNewtype :: Quote m - => [Name] -> Name -> m Dec -mkUnitNewtype l unitName = - let a = varT (mkName "a") in - newtypeD - (cxt []) - unitName - [PlainTV (mkName "a") BndrReq] - Nothing - (normalC unitName - [bangType (bang noSourceUnpackedness noSourceStrictness) a]) - [ derivClause Nothing (conT <$> l)] - --- | Make instance of the form --- --- @ --- instance IsUnit Hour where --- type DimOf Hour = Time --- @ --- -mkIsUnitInstance :: Quote m => Name -> Name -> m [Dec] -mkIsUnitInstance unitName dimName = [d| - instance IsUnit $(conT unitName) where - type DimOf $(conT unitName) = $(conT dimName) - |] - --- | Make an instance of the form --- --- @ --- instance ShowUnit Minute where --- type ShowUnitType Minute = Text "min" --- showUnit = "Minute" --- prettyUnit = "min" --- @ --- -mkShowUnitInstance :: Quote m => Name -> String -> String -> m [Dec] -mkShowUnitInstance unitName unitStr prettyStr = [d| - instance ShowUnit $(conT unitName) where - type ShowUnitType $(conT unitName) = Text $(pure (LitT (StrTyLit prettyStr))) - showUnit = $(litE (StringL unitStr)) - prettyUnit = $(litE (StringL prettyStr)) - |] - - --- | Make an instance of the form --- --- @ --- instance Fractional a => ConversionFactor Minute a where --- factor = 60 --- @ --- -mkConvFactorInstance :: Quote m => Name -> Rational -> m [Dec] -mkConvFactorInstance unitName fctr = [d| - instance Fractional a => ConversionFactor $(conT unitName) a where - factor = $(litE (RationalL fctr)) - |] - - --- | Make an instance of the form --- --- @ --- instance Fractional a => ConvertibleUnit Minute a --- @ --- -mkDefaultSigConvertibleInstance :: Quote m => Name -> m [Dec] -mkDefaultSigConvertibleInstance unitName = [d| - instance Fractional a => ConvertibleUnit $(conT unitName) a - |] - --- | Make an instance of the form --- --- @ --- instance Fractional a => ConvertibleUnit Meter a where --- toBaseUnit = coerce --- {-# INLINE toBaseUnit #-} --- fromBaseUnit = coerce --- {-# INLINE fromBaseUnit #-} --- @ --- -mkNormalConvertibleInstance :: Quote m => Name -> m [Dec] -mkNormalConvertibleInstance unitName = [d| - instance Fractional a => ConvertibleUnit $(conT unitName) a where - toBaseUnit = coerce - {-# INLINE toBaseUnit #-} - fromBaseUnit = coerce - {-# INLINE fromBaseUnit #-} - |] - - --- | Make a unit that can be converted via a factor --- --- [Usage:] --- --- @ --- \$(mkUnit "Minute" "min" ''Time 60) --- @ --- -mkUnit :: String -> String -> Name -> Rational -> Q [Dec] -mkUnit unitStr prettyStr dimName fctr = do - let unitName = mkName unitStr - newtypeDec <- mkUnitNewtype deriveListUnit unitName - isUnitDec <- mkIsUnitInstance unitName dimName - showUnitDec <- mkShowUnitInstance unitName unitStr prettyStr - convFactorDec <- mkConvFactorInstance unitName fctr - convUnitDec <- - if fctr == 1 then - mkNormalConvertibleInstance unitName - else - mkDefaultSigConvertibleInstance unitName - return $ - [newtypeDec] ++ isUnitDec ++ showUnitDec ++ convFactorDec ++ convUnitDec - --- | Make a unit without declaring any conversion instances. --- --- Conversion instances must be added by hand. --- --- [Usage:] --- --- @ --- \$(mkUnit \"Bel\" "B" ''NoUnit ) --- @ --- -mkUnitNoFactor :: String -> String -> Name -> Q [Dec] -mkUnitNoFactor unitStr prettyStr dimName = do - let unitName = mkName unitStr - newtypeDec <- mkUnitNewtype deriveListUnit unitName - isUnitDec <- mkIsUnitInstance unitName dimName - showUnitDec <- mkShowUnitInstance unitName unitStr prettyStr - return $ [newtypeDec] ++ isUnitDec ++ showUnitDec - - --- | Make a base unit. --- --- In addition to calling 'mkUnit' with factor 1, this also makes an --- instance of 'IsDim', which cannot be done in 'mkDim' since the base unit is --- not yet declared. --- --- [Usage:] --- --- @ \$(mkBaseUnit "Second" "s" ''Time ) @ --- -mkBaseUnit :: String -> String -> Name -> Q [Dec] -mkBaseUnit unitStr prettyStr dimName = do - let unitName = mkName unitStr - unitDec <- mkUnit unitStr prettyStr dimName 1 - isDimDec <- mkIsDimInstance dimName unitName - return $ unitDec ++ isDimDec - ----------------------------------- Dimensions ---------------------------------- - --- | List of derived classes for a dimension. --- -deriveListDim :: [Name] -deriveListDim = deriveListUnit - - -mkDimNewtype :: Quote m - => [Name] -> Name -> m Dec -mkDimNewtype = mkUnitNewtype - --- | Make an instance of the form --- --- @ --- instance IsDim Time where --- type DimToUnit Time = Second --- @ --- -mkIsDimInstance :: Quote m => Name -> Name -> m [Dec] -mkIsDimInstance dimName unitName = [d| - instance IsDim $(conT dimName) where - type DimToUnit $(conT dimName) = $(conT unitName) - |] - --- | Make a type instance of the form --- --- @ --- type instance DimId Time = 400 --- @ --- -mkDimIdTypeInstance :: Quote m => Name -> Integer -> m [Dec] -mkDimIdTypeInstance dimName n = [d| - type instance DimId $(conT dimName) = Pos $(litT (numTyLit n)) - |] - --- | Make a type instance of the form --- --- @ --- instance ShowDim Minute where --- type ShowDimType Minute = Text "min" --- showDim = "Minute" --- prettyDim = "min" --- @ --- -mkShowDimInstance :: Quote m => Name -> String -> String -> m [Dec] -mkShowDimInstance dimName dimStr prettyStr = [d| - instance ShowDim $(conT dimName) where - type ShowDimType $(conT dimName) = Text $(pure (LitT (StrTyLit prettyStr))) - showDim = $(litE (StringL dimStr)) - prettyDim = $(litE (StringL prettyStr)) - |] - --- | Make a dimension. --- --- This will not declare an instance for 'IsDim', which is instead declared --- using 'mkBaseUnit'. - --- [Usage:] --- --- @ \$(mkDim "Time" "T" 400) @ --- -mkDim :: String -> String -> Integer -> Q [Dec] -mkDim dimStr prettyStr n = do - let dimName = mkName dimStr - newtypeDec <- mkDimNewtype deriveListDim dimName - -- isDimDec <- mkIsDimInstance dimName unitName - dimIdDec <- mkDimIdTypeInstance dimName n - showDimDec <- mkShowDimInstance dimName dimStr prettyStr - return $ [newtypeDec] ++ dimIdDec ++ showDimDec - - - ------------------------------------ Prefixes ----------------------------------- - - - --- | Make a newtype of the form: --- --- @ --- newtype Milli (u :: Unit) a = Milli (u a) --- deriving (Eq, Ord, Num, Fractional, Floating, Real --- , RealFrac, RealFloat, Functor) --- deriving Show via MetaPrefix Milli u a --- deriving ShowUnit via MetaPrefix Milli u --- @ --- -mkPrefixNewtype :: Monad m => [Name] -> Name -> m Dec -mkPrefixNewtype l prefixName = pure $ - NewtypeD - [] - prefixName - [ KindedTV (mkName "u") BndrReq (ConT ''Unit) - , PlainTV (mkName "a") BndrReq - ] - Nothing - (NormalC prefixName - [ ( Bang NoSourceUnpackedness NoSourceStrictness - , AppT (VarT (mkName "u")) (VarT (mkName "a")) - ) - ]) - [ DerivClause - (Just NewtypeStrategy) - (map ConT l) - , DerivClause - (Just (ViaStrategy viaType)) - [ConT ''Show] - , DerivClause - (Just (ViaStrategy viaTypeNoA)) - [ConT ''ShowUnit] - ] - where - viaType = - foldl AppT (ConT ''MetaPrefix) - [ ConT prefixName - , VarT (mkName "u") - , VarT (mkName "a") - ] - - viaTypeNoA = - foldl AppT (ConT ''MetaPrefix) - [ ConT prefixName - , VarT (mkName "u") - ] - --- | Make a deriving instance of the form --- --- @ --- deriving via MetaPrefix Milli u instance IsUnit u => IsUnit (Milli u ) --- @ --- -mkPrefixIsUnitInstance :: Name -> Q [Dec] -mkPrefixIsUnitInstance prefixName = [d| - deriving via MetaPrefix $(conT prefixName) u instance IsUnit u => IsUnit ($(conT prefixName) u) - |] - --- | Make an instance of the form --- --- @ --- instance ShowPrefix Milli where --- type ShowPrefixType Milli = Text "m" --- showPrefix = "Milli" --- prettyPrefix = "m" --- @ --- -mkShowPrefixInstance :: Quote m => Name -> String -> String -> m [Dec] -mkShowPrefixInstance prefixName prefixStr prettyStr = [d| - instance ShowPrefix $(conT prefixName) where - type ShowPrefixType $(conT prefixName) = Text $(pure (LitT (StrTyLit prettyStr))) - showPrefix = $(litE (StringL prefixStr)) - prettyPrefix = $(litE (StringL prettyStr)) - |] - --- | Make an instance of the form --- --- @ --- instance Fractional a => PrefixFactor Kilo a where --- prefixFactor = 1000 --- {-# INLINE prefixFactor #-} --- -mkPrefixFactorInstance :: Name -> Rational -> Q [Dec] -mkPrefixFactorInstance prefixName fctr = [d| - instance Fractional a => PrefixFactor $(conT prefixName) a where - prefixFactor = $(litE (RationalL fctr)) - {-# INLINE prefixFactor #-} - |] - --- | Make an instance of the form --- --- @ --- instance ConversionFactor u a => ConversionFactor (Milli u) a where --- factor = factor @(MetaPrefix Milli u) --- {-# INLINE factor #-} --- @ --- -mkPrefixConvFactorInstance :: Name -> Q [Dec] -mkPrefixConvFactorInstance prefixName = [d| - instance ConversionFactor u a => ConversionFactor ($(conT prefixName) u) a where - factor = factor @(MetaPrefix $(conT prefixName) u) - {-# INLINE factor #-} - |] - --- | Make an instance of the form --- --- @ --- instance (ConvertibleUnit u a, Fractional a) --- => ConvertibleUnit (Milli u) a where --- toBaseUnit = prefixToBaseUnit --- {-# INLINE toBaseUnit #-} --- fromBaseUnit = prefixFromBaseUnit --- {-# INLINE fromBaseUnit #-} --- @ --- -mkPrefixConvUnitInstance :: Name -> Q [Dec] -mkPrefixConvUnitInstance prefixName = [d| - instance (ConvertibleUnit u a, Fractional a) - => ConvertibleUnit ($(conT prefixName) u) a where - toBaseUnit = prefixToBaseUnit - {-# INLINE toBaseUnit #-} - fromBaseUnit = prefixFromBaseUnit - {-# INLINE fromBaseUnit #-} - |] - --- | Make a unit prefix. --- --- [Usage:] --- --- @ --- \$(mkPrefix "Kilo" "k" 1000) --- @ --- -mkPrefix :: String -> String -> Rational -> Q [Dec] -mkPrefix prefixStr prettyStr fctr = do - let prefixName = mkName prefixStr - newtypeDec <- mkPrefixNewtype deriveList prefixName - isUnitDec <- mkPrefixIsUnitInstance prefixName - showPrefixDec <- mkShowPrefixInstance prefixName prefixStr prettyStr - factorDec <- mkPrefixFactorInstance prefixName fctr - convFactorDec <- mkPrefixConvFactorInstance prefixName - convUnitDec <- mkPrefixConvUnitInstance prefixName - return $ [newtypeDec] ++ isUnitDec ++ showPrefixDec - ++ factorDec ++ convFactorDec ++ convUnitDec - - - diff --git a/src/Data/Units/Core.hs b/src/Data/Units/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Core.hs @@ -0,0 +1,25 @@ +module Data.Units.Core + ( -- ** Core modules + module Data.Units.Core.System + , module Data.Units.Core.Convert + , module Data.Units.Core.Arithmetic + , module Data.Units.Core.Prefix + , module Data.Units.Core.TH + -- ** Re-exported for Template Haskell to work out of the box + -- on @import Data.Units.Core@ + , coerce + -- ** Type level integers + , module Data.Type.Int + -- ** Re-exported from GHC.TypeError + , ErrorMessage (..) + ) where + +import GHC.TypeError (ErrorMessage(..)) +import Data.Coerce (coerce) + +import Data.Units.Core.System +import Data.Units.Core.Convert +import Data.Units.Core.Arithmetic +import Data.Units.Core.Prefix +import Data.Units.Core.TH +import Data.Type.Int diff --git a/src/Data/Units/Core/Arithmetic.hs b/src/Data/Units/Core/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Core/Arithmetic.hs @@ -0,0 +1,397 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.Core.Arithmetic +-- Description : Addition, multiplication and exponentiation of quantities +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Addition, multiplication and exponentiation of quantities. Dimension analysis is done statically via the type system. +-- +-- == Addition and multiplication of a quantity by a scalar +-- +-- To add, multiply, divide, and so on, a quantity with a scalar , use its @'Fractional'@ instance : +-- +-- >>> a = Milli (Second 5) +-- >>> 3 * a +-- quantity @(Milli Second) 15 +-- +-- [Warning] These instances are provided because they are convenient, but be careful ! This means that you can write: +-- +-- >>> Second 2 * Second 3 +-- Second 6 +-- +-- which does not respect dimension analysis: the multiplication of two time +-- quantities should be of dimension @T²@ and here it has dimension @T@. +-- +-- Some of the operators proposed here solve this problem: +-- +-- >>> Second 2 .*~ Second 3 +-- quantity @(Second .^+ 2) 6 +-- +-------------------------------------------------------------------------------- + +module Data.Units.Core.Arithmetic + ( + -- ** Addition + (.+~) + , (~+.) + , (~+~) + -- ** Subtraction + , (.-~) + , (~-.) + , (~-~) + -- ** Multiplication + , (.*.) + , (.*~) + , (~*.) + , (~*~) + -- ** Division + , (./.) + , (./~) + , (~/.) + , (~/~) + -- ** Exponentiation + , (.^.) + , (~^.) + , (.^~) + , (~^~) + ) where + +import Data.Type.Int + +import Data.Units.Core.System +import Data.Units.Core.Convert + +----------------------------------- Addition ----------------------------------- + +-- | Add two quantities of same dimension. The unit of the right operand is +-- converted to the unit of the left operand +-- +-- >>> Kilo (Meter 5) .+~ Meter 80 +-- quantity @(Kilo Meter) 5.08 +-- +-- >>> Meter 2 .+~ Second 3 +-- • Cannot convert unit ‘s’ of dimension ‘T’ +-- to unit ‘m’ of dimension ‘L’. +-- +(.+~) :: forall u v a. FromTo' v u a => u a -> v a -> u a +u .+~ v = quantity (unQuantity u + unQuantity (fromTo' v :: u a)) +{-# INLINE (.+~) #-} + +infixr 5 .+~ + +-- | Same as @'(.+~)'@ but it is the left operand that is converted. +-- +-- >>> Kilo (Meter 5) ~+. Meter 80 +-- quantity @(Kilo Meter) 5080.0 +-- +(~+.) :: FromTo' u v a => u a -> v a -> v a +(~+.) = flip (.+~) +{-# INLINE (~+.) #-} + +infixr 5 ~+. + +-- | Add two quantities of same dimension and convert to the standard unit. +-- +-- >>> Kilo (Meter 1) ~+~ Milli (Meter 150) +-- Meter 1000.15 +-- +(~+~) :: + ( DimEq u v + , ConversionFactor u a, ConversionFactor v a + ) + => u a -> v a -> (BaseUnitOf u) a +u ~+~ v = quantity (unQuantity (toBaseUnit' u) + unQuantity (toBaseUnit' v)) +{-# INLINE (~+~) #-} + +infixr 5 ~+~ + +--------------------------------- Subtraction ---------------------------------- + +-- | Subtract two quantities of same dimension. The unit of the right operand is converted to the unit of the left operand +-- +-- >>> Kilo (Meter 5) .-~ Meter 80 +-- quantity @(Kilo Meter) 4.92 +-- +(.-~) :: forall u v a. FromTo' v u a => u a -> v a -> u a +u .-~ v = quantity (unQuantity u - unQuantity (fromTo' v :: u a)) +{-# INLINE (.-~) #-} + +infixr 5 .-~ + +-- | Same as @'(.-~)'@ but it is the left operand that is converted. +-- +-- >>> Kilo (Meter 5) ~-. Meter 80 +-- Meter 4920.0 +-- +(~-.) :: forall u v a. FromTo' u v a => u a -> v a -> v a +u ~-. v = quantity (unQuantity (fromTo' u :: v a) - unQuantity v) +-- {-# INLINE (~-.) #-} + +infixr 5 ~-. + +-- | Subtract two quantities of same dimension and convert to the standard unit. +-- +-- >>> Kilo (Meter 1) ~-~ Milli (Meter 150) +-- Meter 999.85 +-- +(~-~) :: + ( DimEq u v + , ConversionFactor v a, ConversionFactor u a + ) + => u a -> v a -> (BaseUnitOf u) a +u ~-~ v = quantity $ unQuantity (toBaseUnit' u) - unQuantity (toBaseUnit' v) +{-# INLINE (~-~) #-} + +infixr 5 ~-~ + +-------------------------------- Multiplication -------------------------------- + + + +-- | Multiply two quantities. +-- +-- Usage is not recommended, as this will result non standard units. +-- +-- For instance: +-- +-- >>> Kilo (Meter 2) .*. Milli (Meter 4) +-- quantity @(Kilo Meter .*. Milli Meter) 8 +-- +(.*.) :: + ( IsUnit u, IsUnit v + , Num a + ) + => u a -> v a -> (u .*. v) a +u .*. v = quantity $ unQuantity u * unQuantity v +{-# INLINE (.*.) #-} + +infixr 7 .*. + +-- | Multiply two quantities, and tries to normalize the resulting unit, without +-- converting to base units. +-- +-- >>> Meter 2 .*~ Meter 3 .*~ Meter 4 +-- quantity @(Meter.^+3) 24 +-- +-- When two multiplied units have the same dimension, the right most unit is +-- converted to left most unit: +-- +-- >>> Milli (Meter 2) .*~ Micro (Meter 3) +-- quantity @(Milli Meter.^+2) 6.0e-3 +-- +-- Derived units are not unfolded: +-- +-- >>> Kilo Watt 3 .*~ Hour 5 +-- quantity @(Kilo Watt .*. Hour) 14.999999999999998 +-- +-- Units are ordered, so that the result unit do not depend on the order of the +-- computations. +-- +-- >>> Meter 2 .*~ Newton 2 .*~ Kilo (Meter 2) .*~ Kilo (Gram 1) +-- quantity @(Newton .*. Kilo Gram .*. Meter.^+2) 8000.0 +-- +(.*~) :: forall u v a uv. + ( uv ~ u .*~ v + , FromTo' (u .*. v) uv a + , IsUnit u, IsUnit v, IsUnit uv + , Num a + ) + => u a -> v a -> uv a +u .*~ v = to' @uv (u .*. v) +{-# INLINE (.*~) #-} + +infixr 7 .*~ + +-- | Same as '(.*~)' but with right priority +-- +-- >>> Meter 2 ~*. Meter 3 ~*. Meter 4 +-- quantity @(Meter.^+3) 24 +-- +-- >>> Milli (Meter 2) ~*. Micro (Meter 3) +-- quantity @(Micro Meter.^+2) 6000.000000000001 +-- +(~*.) :: forall u v a uv. + ( uv ~ u ~*. v + , FromTo' (u .*. v) uv a + , IsUnit u, IsUnit v, IsUnit uv + , Num a + ) + => u a -> v a -> uv a +u ~*. v = to' @uv (u .*. v) +{-# INLINE (~*.) #-} + +infixr 7 ~*. + +-- | Multiply two quantities of the same dimension and convert both of them to the corresponding standard unity. +-- +-- >>> Milli (Meter 2) ~*~ Kilo (Meter 3) +-- quantity @(Meter .^+ 2) 6.0 +-- +-- >>> Meter 2 ~*~ Second 5 +-- • Cannot convert unit ‘m’ to unit ‘s’ because their dimensions do not match. +-- Dimension of ‘m’ is: L +-- Dimension of ‘s’ is: T +-- +(~*~) :: + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + ) + => u a -> v a -> u2 a +u ~*~ v = quantity $ unQuantity (toBaseUnit' u) * unQuantity (toBaseUnit' v) +{-# INLINE (~*~) #-} + +infix 7 ~*~ + + +----------------------------------- Division ----------------------------------- + +-- | Multiply two quantities. +-- +-- Usage is not recommended, as this will result non standard units. +-- +-- For instance: +-- +-- >>> Kilo (Meter 2) ./. Milli (Meter 4) +-- quantity @(Kilo Meter .*. Milli Meter.^-1) 0.5 +-- +(./.) :: + ( IsUnit u, IsUnit v, IsUnit (u ./. v) + , Fractional a + ) + => u a -> v a -> (u ./. v) a +u ./. v = quantity (unQuantity u / unQuantity v) +{-# INLINE (./.) #-} + +infix 7 ./. + +-- | Same '(.*~)' but for division. +-- +-- >>> Milli (Meter 3) ./~ quantity @(Meter .^+ 2) 2 +-- quantity @(Milli Meter.^-1) 1.5e-6 +-- +(./~) :: forall u v a uv. + ( uv ~ u ./~ v + , FromTo' (u ./. v) uv a + , IsUnit u, IsUnit v, IsUnit uv + , Num a + ) + => u a -> v a -> uv a +u ./~ v = to' @uv (u ./. v) +{-# INLINE (./~) #-} + +infix 7 ./~ + +-- | Same '(~/.)' but with right priority +-- +-- >>> Milli (Meter 3) ~/. quantity @(Meter .^+ 2) 2 +-- quantity @(Meter.^-1) 1.5e-3 +-- +(~/.) :: forall u v a uv. + ( uv ~ u ~/. v + , FromTo' (u ./. v) uv a + , IsUnit u, IsUnit v, IsUnit uv + , Num a + ) + => u a -> v a -> uv a +u ~/. v = to' @uv (u ./. v) +{-# INLINE (~/.) #-} + +infix 7 ~/. + +-- | Divide two quantities of same dimensions. The numerator will be converted +-- to the denominator +-- +-- Units of the same dimension are authorized only when the units are equal. +-- +-- >>> Meter 4 ~/~ Kilo (Meter 1) +-- NoUnit 4.0e-3 +-- +(~/~) :: + ( DimEq u v + , ConversionFactor u a, ConversionFactor v a + ) + => u a -> v a -> NoUnit a +u ~/~ v = quantity $ unQuantity (toBaseUnit' u) / unQuantity (toBaseUnit' v) +{-# INLINE (~/~) #-} + +infix 6 ~/~ + +-------------------------------- Exponentiation -------------------------------- + +-- | Raise a quantity to a power. +-- +-- >>> Meter 2 .^. pos2 +-- quantity @(Meter.^+2) 4.0 +-- +-- Usage is not recommended, as this will result non standard units. +-- +-- For instance: +-- +-- >>> (Meter 2 .*. Centi (Meter 30)) .^. pos2 +-- quantity @((Meter .*. Centi Meter).^+2) 3600.0 +-- +(.^.) :: forall (n :: ZZ) proxy u a. (IsUnit u, KnownInt n, Fractional a) + => u a -> proxy n -> (u .^. n) a +u .^. p = quantity $ unQuantity u ^^ intVal p +{-# INLINE (.^.) #-} + +infix 8 .^. + +-- | Raise a quantity to a power and tries to normalize the resulting unit, +-- without converting to base units. +-- +-- This is meant to be used with @'SZZ'@ singletons, like 'pos', 'neg' +-- or 'zero', and there other flavors like 'pos2', 'neg3', etc. +-- +-- >>> Meter 2 ~^. pos2 +-- quantity @(Meter.^+2) 4.0 +-- +-- >>> Meter 2 ~^. pos @10 +-- quantity @(Meter.^+10) 1024.0 +-- +-- >>> (Meter 2 .*. Centi (Meter 30)) ~^. pos2 +-- quantity @(Centi Meter.^+4) 3.6e7 +(~^.) :: forall (n :: ZZ) proxy u a un. + (un ~ u ~^. n, FromTo' (u .^. n) un a, IsUnit u, KnownInt n, Fractional a) + => u a -> proxy n -> un a +u ~^. p = to' @un (u .^. p) +{-# INLINE (~^.) #-} + +infix 8 ~^. + +-- | Same as @'(.^~)'@ but with priority to rightmost units. +-- +-- >>> Meter 2 .^~ pos2 +-- quantity @(Meter.^+2) 4.0 +-- +-- >>> (Meter 2 .*. Centi (Meter 30)) ~^. pos2 +-- quantity @(Meter.^+4) 0.36000000000000004 +-- +(.^~ ) :: forall (n :: ZZ) proxy u a un. + (un ~ u .^~ n, FromTo' (u .^. n) un a, IsUnit u, KnownInt n, Fractional a) + => u a -> proxy n -> un a +u .^~ p = to' @un (u .^. p) +{-# INLINE (.^~ ) #-} + +infix 8 .^~ + +-- | Raise a quantity to a power and convert to the standard unit. +-- +-- >>> Kilo (Meter 2) ~^~ neg1 +-- quantity @(Meter .^- 1) 5.0e-4 +-- +(~^~) :: forall (n :: ZZ) proxy u un a. + (KnownInt n, ConversionFactor u a, un ~ BaseUnitOf u .^. n ) + => u a -> proxy n -> un a +u ~^~ p = quantity @un $ unQuantity (toBaseUnit' u) ^^ intVal p +{-# INLINE (~^~) #-} + +infix 8 ~^~ + + diff --git a/src/Data/Units/Core/Convert.hs b/src/Data/Units/Core/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Core/Convert.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.Core.Convert +-- Description : Conversion between units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Conversion between units. Use @'from'@, @'to'@, or @'fromTo'@ to convert +-- between two units of the same dimension. +-- +-- = Implementing conversions for custom units +-- +-- Depending on how the custom unit is converted to its standard unit, there are +-- three ways to implement its conversion summarized in the following table and +-- described with further details afterwards: +-- +-- +-----------------------+---------------------------+----------------------+ +-- | | Which instances | Note | +-- | | to declare | | +-- +=======================+===========================+======================+ +-- | Conversion factor | @'ConversionFactor'@ and | | +-- | | @'ConvertibleUnit'@ using | | +-- | | the default | @'fromTo' == @ | +-- | | implementations | @'fromTo''@ | +-- | | for 'fromBaseUnit' and | | +-- | | 'toBaseUnit' | | +-- +-----------------------+---------------------------+----------------------+ +-- | Affine conversion | @'ConversionFactor'@ and | | +-- | | @'ConvertibleUnit'@ | | +-- | | | @'fromTo' /= @ | +-- | | | @'fromTo''@ | +-- +-----------------------+---------------------------+----------------------+ +-- | Non linear conversion | | @'from''@, @'to''@ | +-- | | @'ConvertibleUnit'@ | and @'fromTo''@ | +-- | | | cannot be used | +-- +-----------------------+---------------------------+----------------------+ +-- +-- +-- === Multiplication by a conversion factor +-- +-- For units that can be converted to and from their corresponding standard +-- units by multiplication of a converion factor, you only need to declare an +-- instance of @'ConversionFactor'@, like +-- +-- @ +-- instance Fractional a => ConversionFactor Hour a where +-- factor = 3600 +-- +-- instance Fractional a => ConvertibleUnit Hour a +-- -- uses default implementations for 'fromBaseUnit' and 'toBaseUnit' +-- @ +-- +-- >>> fromTo @Hour @Second 1 +-- Second 3600.0 +-- >>> fromTo' @Hour @Second 1 +-- Second 3600.0 +-- +-- === Affine conversion (with an offset) +-- +-- Some units cannot be conversed by a simple multiplication. For instance, the +-- conversion between Celsius degrees and Kelvin degrees involves addition +-- @x °C = x + 273.15 K@. +-- +-- However, when considered as /differences/ of temperatures, Celsius degrees +-- are converted to Kelvin degrees by a multiplication of @1@. +-- +-- This can be expressed by the following instances: +-- +-- @ +-- instance Num a => ConversionFactor Celsius a where +-- factor = 1 +-- +-- instance Fractional a => ConvertibleUnit Celsius a where +-- toBaseUnit (Celsius x) = Kelvin (x - 273.15) +-- fromBaseUnit (Kelvin x) = Celsius (x + 273.15) +-- @ +-- +-- >>> fromTo @Celsius @Kelvin 0 +-- Kelvin 273.15 +-- >>> fromTo' @Celsius @Kelvin 0 +-- Kelvin 0.0 +-- +-- === Other conversions +-- +-- Any other conversion can be implemented, like for instance logarithmic units. +-- In this case, you should only give an instance for @'ConvertibleUnit'@, and +-- no instance for @'ConversionFactor'@. See for instance linear picth +-- @'Data.Unit.NonStd.Frequency.Tet'@. +-- +-------------------------------------------------------------------------------- + +module Data.Units.Core.Convert + ( DimEq + -- * Generic conversion between units + , ConvertibleUnit (..) + , FromTo + , fromTo + , from + , to + , ($~) + , (~&) + -- * Conversion using conversion factors + , ConversionFactor (..) + , toBaseUnit' + , fromBaseUnit' + , FromTo' + , fromTo' + , from' + , to' + ) + where + +import Data.Proxy +import Data.Kind +import Data.Type.Bool +import Data.Type.Equality +import GHC.TypeError + +import Data.Type.Int + +import Data.Units.Core.System + +-- | A constraint to test whether two units have +type family DimEq (u :: Unit) (v :: Unit) :: Constraint where + DimEq u v = DimEqStd u v (DimOf u) (DimOf v) + +type family DimEqStd (u :: Unit) (v :: Unit) (du :: Dim) (dv :: Dim) + :: Constraint where + DimEqStd u v du dv = + ( IsUnit u + , IsUnit v + , du ~ dv + , If (du == dv) (() :: Constraint) + (TypeError ( + Text "Cannot convert unit ‘" + :<>: ShowUnitType u + :<>: Text "’ to unit ‘" + :<>: ShowUnitType v + :<>: Text "’ because their dimensions do not match." + :$$: Text "Dimension of ‘" + :<>: ShowUnitType u + :<>: Text "’ is: " + :<>: ShowDimType du + :$$: Text "Dimension of ‘" + :<>: ShowUnitType v + :<>: Text "’ is: " + :<>: ShowDimType dv + ))) + + + +-- | A unit whose quantities are convertible from that unit to its corresponding +-- base unit. +-- +-- Instances must satisfy the following law : +-- +-- * @'toBaseUnit' . 'fromBaseUnit' == 'id'@ +-- +class (IsUnit u, IsUnit (BaseUnitOf u)) => ConvertibleUnit u a where + -- | Convert a quantity to its base unit. + -- + -- >>> import Data.Units.NonStd.Time + -- >>> toBaseUnit @Hour 1 + -- Second 3600.0 + -- >>> toBaseUnit (Hour 1) + -- Second 3600.0 + -- >>> toBaseUnit @(Kilo Meter ./. Hour) 36 + -- quantity @(Meter .*. Second .^- 1) 10.0 + -- >>> toBaseUnit (Celsius 0) + -- Kelvin 273.15 + toBaseUnit :: u a -> BaseUnitOf u a + default toBaseUnit :: ConversionFactor u a => u a -> BaseUnitOf u a + toBaseUnit = toBaseUnit' + {-# INLINE toBaseUnit #-} + + -- | Convert a quantity from its base unit to another unit. + -- + -- >>> fromBaseUnit @Hour 1800 + -- Hour 0.5 + -- >>> fromBaseUnit 1800 :: Hour Double + -- Hour 0.5 + -- >>> fromBaseUnit @(Kilo Meter ./. Hour) 10 + -- quantity @(Kilo Meter .*. Hour .^- 1) 36.0 + -- >>> fromBaseUnit @Celsius 0 + -- Celsius (-273.15) + -- + fromBaseUnit :: BaseUnitOf u a -> u a + default fromBaseUnit :: ConversionFactor u a => BaseUnitOf u a -> u a + fromBaseUnit = fromBaseUnit' + {-# INLINE fromBaseUnit #-} + + + +-- | A constraint that is satisfied when both units have the same dimension and +-- are such that @u@ can be converted to @v@. +-- +type FromTo u v a = (DimEq u v, ConvertibleUnit u a, ConvertibleUnit v a) + +-- | Conversion between two quantities with the same dimension. +-- +-- >>> fromTo @Celsius @Kelvin 0 +-- Kelvin 273.15 +-- >>> fromTo @(Milli Second) @Hour 1 +-- Hour 2.7777777777777776e-7 +-- >>> fromTo (Milli (Second 1)) :: Hour Double +-- Hour 2.7777777777777776e-7 +-- >>> fromTo @Turn @Degree (1/4) -- angle conversion +-- Degree 90.0 +-- >>> fromTo @(Kilo Meter ./. Hour) @(Milli Meter ./. Milli Second) 36 +-- quantity @(Milli Meter .*. Milli Second .^- 1) 10.0 +-- +fromTo :: FromTo u v a => u a -> v a +fromTo = fromBaseUnit . toBaseUnit +{-# INLINE fromTo #-} + +-- | A mere synonym of @'fromTo'@ where it is more intuitive to use only one +-- type application. +-- +-- >>> from @Celsius 0 :: Kelvin Double +-- Kelvin 273.15 +-- +from :: FromTo u v a => u a -> v a +from = fromTo +{-# INLINE from #-} + +-- | Same as @'fromTo'@ but the type applications are reversed +-- +-- >>> to @Kelvin (Celsius 0) +-- Kelvin 273.15 +-- +to :: forall v u a. FromTo u v a => u a -> v a +to = fromTo +{-# INLINE to #-} + +-- | A convenient operator for converting a unit before feeding it to a +-- function. +-- +-- >>> import Linear +-- >>> rotation (Radian th) = V2 (V2 (cos th) (- sin th)) (V2 (sin th) (cos th)) +-- >>> rotation $~ Degree 90 +-- V2 (V2 6.123031769111886e-17 (-1.0)) (V2 1.0 6.123031769111886e-17) +-- +($~) :: FromTo u v a => (v a -> b) -> u a -> b +f $~ x = f (fromTo x) +{-# INLINE ($~) #-} + +infixr 0 $~ + +-- | Same as @'($~)'@ but with arguments flipped. +-- +(~&) :: FromTo u v a => u a -> (v a -> b) -> b +(~&) = flip ($~) +{-# INLINE (~&) #-} + +infixl 1 ~& + +-------------------------------------------------------------------------------- + +-- | Unit that can be converted to their corresponding standard unit by +-- multiplication with a conversion factor. +-- +-- Instances must satisfy the following laws: +-- +-- * @'toBaseUnit' @u == 'quantity' ('unQuantity' q * 'factor' @u)@ +-- * @'fromBaseUnit' @u == 'quantity' (''unQuantity' q / 'factor' @u)@ +-- +class (ConvertibleUnit u a, Fractional a) => ConversionFactor u a where + {-# MINIMAL factor #-} + + -- | Multiplying a quantity of type @u a@ with @'factor'@ will convert it + -- to its corresponding base unit @BaseUnitOf u a@ + -- + -- >>> factor @Hour :: Double + -- 3600.0 + -- >>> factor @Celsius :: Double + -- 1.0 + -- >>> factor @(Kilo Meter ./. Hour) :: Double + -- 0.2777777777777778 + factor :: a + +instance Fractional a => ConvertibleUnit NoUnit a + +instance Fractional a => ConversionFactor NoUnit a where + factor = 1 + {-# INLINE factor #-} + +instance (Num a, ConversionFactor u a, ConversionFactor v a, IsUnit (BaseUnitOf (u .*. v))) + => ConvertibleUnit (u .*. v) a + +instance (Num a, ConversionFactor u a, ConversionFactor v a, IsUnit (BaseUnitOf (u .*. v))) + => ConversionFactor (u .*. v) a where + factor = factor @u * factor @v + {-# INLINE factor #-} + +instance (ConversionFactor u a, IsUnit (BaseUnitOf (u .^. n)), KnownInt n) + => ConvertibleUnit (u .^. n) a + +instance (ConversionFactor u a, IsUnit (BaseUnitOf (u .^. n)), KnownInt n) + => ConversionFactor (u .^. n) a where + factor = factor @u ^^ intVal (Proxy :: Proxy n) + {-# INLINE factor #-} + +-- | Convert a quantity to its corresponding base unit by multiplying it +-- by @'factor'@. +-- +-- >>> toBaseUnit' @Hour 1 +-- Second 3600.0 +-- >>> toBaseUnit' (Hour 1) +-- Second 3600.0 +-- >>> toBaseUnit' @(Kilo Meter ./. Hour) 36 +-- quantity @(Meter .*. Second .^- 1) 10.0 +-- >>> toBaseUnit' (Celsius 0) +-- Kelvin 0.0 +-- +toBaseUnit' :: forall u a. ConversionFactor u a + => u a -> BaseUnitOf u a +toBaseUnit' q = quantity (unQuantity q * factor @u) +{-# INLINE toBaseUnit' #-} + +-- | Convert a standard quantity to a unit @u@ by dividing it by +-- by @'factor'@. +-- +-- >>> fromBaseUnit' @Hour 1800 +-- Hour 0.5 +-- >>> fromBaseUnit' 1800 :: Hour Double +-- Hour 0.5 +-- >>> fromBaseUnit' @(Kilo Meter ./. Hour) 10 +-- quantity @(Kilo Meter .*. Hour .^- 1) 36.0 +-- >>> fromBaseUnit' @Celsius 0 +-- Celsius 0.0 +-- +fromBaseUnit' :: forall u a. ConversionFactor u a + => BaseUnitOf u a -> u a +fromBaseUnit' q = quantity (unQuantity q / factor @u) +{-# INLINE fromBaseUnit' #-} + +-- | A constraint that is satisfied when both units have the same dimension and +-- are such that @u@ can be converted to @v@ by using a conversion factor. +-- +type FromTo' u v a = (DimEq u v, ConversionFactor u a, ConversionFactor v a) + +-- | Conversion, using conversion factors, between two quantities with the same +-- dimension +-- +-- >>> fromTo' @Celsius @Kelvin 0 +-- Kelvin 0.0 +-- >>> fromTo' @(Milli Second) @Hour 1 +-- Hour 2.7777777777777776e-7 +-- >>> fromTo' (Milli (Second 1)) :: Hour Double +-- Hour 2.7777777777777776e-7 +-- >>> fromTo' @Turn @Degree (1/4) -- angle conversion +-- Degree 90.0 +-- >>> fromTo' @(Kilo Meter ./. Hour) @(Milli Meter ./. Milli Second) 36 +-- quantity @(Milli Meter .*. Milli Second .^- 1) 10.0 +-- +fromTo' :: forall u v a. + FromTo' u v a + => u a -> v a +fromTo' q = quantity (unQuantity q * (factor @u / factor @v)) +{-# INLINE fromTo' #-} + + + +-- | A mere synonym of @'fromTo''@ where it is more intuitive to use only one +-- type application. +-- +-- >>> from' @Celsius 0 :: Kelvin Double +-- Kelvin 0.0 +-- +from' :: FromTo' u v a => u a -> v a +from' = fromTo' +{-# INLINE from' #-} + +-- | Same as @'fromTo''@ but the type applications are reversed +-- +-- >>> to' @Kelvin (Celsius 0) +-- Kelvin 0.0 +-- +to' :: forall v u a. FromTo' u v a => u a -> v a +to' = fromTo' +{-# INLINE to' #-} + + diff --git a/src/Data/Units/Core/Prefix.hs b/src/Data/Units/Core/Prefix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Core/Prefix.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.Core.Prefix +-- Description : Unit prefix for a system of units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Provides a way to define prefixes for any system of units. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.Core.Prefix where + +import GHC.TypeError + +import Data.Units.Core.System +import Data.Units.Core.Convert + +-- | A unit prefix, like Kilo, Milli, etc. +type Prefix = Unit -> Unit + +-- | The application of a prefix to a unit must always be a unit. +class (forall (u :: Unit). IsUnit u => IsUnit (p u)) + => IsPrefix (p :: Prefix) + +instance (forall (u :: Unit). IsUnit u => IsUnit (p u)) + => IsPrefix (p :: Prefix) + +-- | A prefix that has a conversion factor. +-- +class (Fractional a, IsPrefix p) => PrefixFactor (p :: Prefix) a where + -- | Prefix conversion factor from the prefixed unit to the corresponding + -- standard unit + -- + -- >>> prefixFactor @Kilo + -- 1000.0 + -- + prefixFactor :: a + +-- | Prefixes that can be shown as a string, or as a type error message. +class IsPrefix p => ShowPrefix (p :: Prefix) where + {-# MINIMAL showPrefix | showsPrefixPrec #-} + + -- | Allows to print units in conversion error messages + -- + -- >>> type ShowPrefix Kilo = "k" + -- + type ShowPrefixType p :: ErrorMessage + + -- | Convert a prefix to a readable string + -- + -- @'showsPrefixPrec'@ should satisfy the law : + -- + -- @showsPrefixPrec d x r ++ s == showsPrec d x (r ++ s)@ + -- + showsPrefixPrec :: Int -> ShowS + showsPrefixPrec _ = (showPrefix @p ++) + + -- | Convert a prefix to a string representing its type. + -- + -- >>> showPrefix @Kilo + -- "Kilo" + -- + showPrefix :: String + showPrefix = showsPrefix @p "" + + -- | Same as @'showsPrefixPrec'@ but for pretty printing. + -- + -- @'prettysPrefixPrec'@ should satisfy the law : + -- + -- @prettysPrefixPrec d x r ++ s == prettysPrec d x (r ++ s)@ + -- + prettysPrefixPrec :: Int -> ShowS + prettysPrefixPrec _ = (prettyPrefix @p ++) + + -- | Same as @'showPrefix'@ but for pretty printing + -- + -- >>> prettyPrefix @Kilo + -- "k" + prettyPrefix :: String + prettyPrefix = prettysPrefix @p "" + +-- | Equivalent to 'showsPrefixPrec' with a precedence of 0. +showsPrefix :: forall p. ShowPrefix p => ShowS +showsPrefix = showsPrefixPrec @p 0 + +-- | Equivalent to 'prettysPrefixPrec' with a precedence of 0. +prettysPrefix :: forall p. ShowPrefix p => ShowS +prettysPrefix = prettysPrefixPrec @p 0 + + +-- | A prefix that can represent any prefix. +-- +-- This can be used with the `deriving via` mechanism to derive some of the +-- prefix instances. +-- +newtype MetaPrefix (p :: Prefix) (u :: Unit) a = MetaPrefix (p u a) + deriving Show via (MetaUnit (p u) a) + +instance PrefixFactor p a => PrefixFactor (MetaPrefix p) a where + prefixFactor = prefixFactor @p + {-# INLINE prefixFactor #-} + +instance + (PrefixFactor p a, ConversionFactor u a, BaseUnitOf (p u) ~ BaseUnitOf u) + => ConversionFactor (MetaPrefix p u) a where + factor = prefixFactor @p * factor @u + {-# INLINE factor #-} + +instance + (PrefixFactor p a, ConvertibleUnit u a, BaseUnitOf (p u) ~ BaseUnitOf u) + => ConvertibleUnit (MetaPrefix p u) a where + toBaseUnit (MetaPrefix a) = prefixToBaseUnit @p @u a + {-# INLINE toBaseUnit #-} + fromBaseUnit a = MetaPrefix $ prefixFromBaseUnit @p @u a + {-# INLINE fromBaseUnit #-} + +-- | Convert a prefixed unit to the corresponding standard unit. +-- +prefixToBaseUnit :: forall (p :: Prefix) (u :: Unit) a. + (PrefixFactor p a, ConvertibleUnit u a, BaseUnitOf (p u) ~ BaseUnitOf u) + => p u a -> BaseUnitOf u a +prefixToBaseUnit u = + toBaseUnit @u $ quantity @u (prefixFactor @p * unQuantity u) +{-# INLINE prefixToBaseUnit #-} + +-- | Convert a standard unit to the corresponding prefixed unit. +-- +prefixFromBaseUnit :: forall (p :: Prefix) (u :: Unit) a. + (PrefixFactor p a, ConvertibleUnit u a + , BaseUnitOf (p u) a ~ BaseUnitOf u a) + => BaseUnitOf (p u) a -> p u a +prefixFromBaseUnit a = quantity $ unQuantity (fromBaseUnit @u a) / prefixFactor @p +{-# INLINE prefixFromBaseUnit #-} + + +instance ShowPrefix p => ShowPrefix (MetaPrefix p) where + type ShowPrefixType (MetaPrefix p) = ShowPrefixType p + showsPrefixPrec = showsPrefixPrec @p + showPrefix = showPrefix @p + prettysPrefixPrec = prettysPrefixPrec @p + prettyPrefix = prettyPrefix @p + +instance (IsPrefix p, IsUnit u) + => IsUnit (MetaPrefix p u) where + type DimOf (MetaPrefix p u) = DimOf u + +instance (ShowPrefix p, ShowUnit u) + => ShowUnit (MetaPrefix p u) where + type ShowUnitType (MetaPrefix p u) = ShowPrefixType p :<>: ShowUnitType u + showsUnitPrec d = showParen (d > 10) $ + showsPrefix @p . showString " " . showsUnitPrec @u 11 + prettysUnitPrec d = showParen (d > 10) $ + prettysPrefix @p . prettysUnit @u + diff --git a/src/Data/Units/Core/System.hs b/src/Data/Units/Core/System.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Core/System.hs @@ -0,0 +1,914 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.Core.System +-- Description : System of units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Describe a system of units and their dimensions. +-- +-------------------------------------------------------------------------------- + +module Data.Units.Core.System + ( + -- * Dimensions + Dim + , DimId + , IsDim (..) + , ShowDim (..) + , prettysDim + , showsDim + , showDimOf + , prettyDimOf + , putDimOf + , NormalizeDim + + -- * Units + , Unit + , ShowUnit (..) + , prettysUnit + , showsUnit + , prettyUnitInfo + , putInfoU + , IsUnit (..) + + -- * Quantity + , quantity + , unQuantity + , showQuantity + , prettyQuantity + , putQuantity + , putInfoQ + + -- * Unit and dimension constructors + , NoDim (..) + , NoUnit (..) + , MetaUnit (..) + , type (.*.) (..) + , type (.^.) (..) + , type (.^+) + , type (.^-) + + + -- * Unit normalization + , BaseUnitOf + , NormalizeUnitL + , NormalizeUnitR + -- ** Normalization operators + -- *** Multiplication + , type (.*~) + , type (~*.) + , type (~*~) + -- *** Division + , type (./.) + , type (./~) + , type (~/.) + , type (~/~) + -- *** Exponentiation + , type (~^.) + , type (.^~) + , type (~^~) + ) + where + +import Data.Coerce +import Data.Kind +import Data.Proxy +import Data.Type.Ord +import Data.Type.Bool +import Data.Type.Equality +import GHC.TypeError +import GHC.TypeLits + +import Data.Type.Int + + +---------------------------------- Dimension ----------------------------------- + +-- | A unit dimension. +-- +-- Modeled as a newtype constructor, just like @'Unit'@. +-- +-- >>> type Speed = Length -/- Time +-- +type Dim = Type -> Type + +class (IsUnit (DimToUnit d), forall a. Coercible (d a) a) + => IsDim (d :: Dim) where + type DimToUnit d :: Unit + +-- | A dimension identifier. +-- +-- This identifiers allow to sort the units when computing the standard unit. +-- +-- >>> type instance DimId Length = 300 +-- +-- >>> :kind! BaseUnitOf (Second .^- 1 .*. Meter) +-- Meter .*. (Second .^. Neg 1) +-- +-- +-- Two different dimensions must have different identifiers. To make sure this +-- remains true, we maintain here an /exhaustive/ list of dimensions declared +-- in this package /and/ any package that depends on it. Please raise an issue +-- if you added a new dimension. +-- +-- [This package:] +-- +-- +----------------------------------------------------+----------------+ +-- | Dimension | Id | +-- +====================================================+================+ +-- | Reserved | 0 | +-- +----------------------------------------------------+----------------+ +-- | @'NoDim'@ | 1 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.AngleSI.System.Angle'@ | 1000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.Mass'@ | 2000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.Length'@ | 3000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.Time'@ | 4000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.ElectricCurrent'@ | 5000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.Temperature'@ | 6000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.AmountOfSubstance'@ | 7000 | +-- +----------------------------------------------------+----------------+ +-- | @'Data.Units.SI.System.LuminousIntensity'@ | 8000 | +-- +----------------------------------------------------+----------------+ +-- +type family DimId (d:: Dim) :: ZZ + +-- | Dimensions that can be shown as a string, or as a type error message. +-- +class ShowDim (d :: Dim) where + {-# MINIMAL showDim | showsDimPrec #-} + + -- | Allows to print dimensions in conversion error messages + -- + -- >>> type ShowDimType Length = "L" + -- + type ShowDimType d :: ErrorMessage + + -- | Convert a dimension to a readable string + -- + -- @'showsDimPrec'@ should satisfy the law : + -- + -- @showsDimPrec d x r ++ s == showsPrec d x (r ++ s)@ + showsDimPrec :: Int -> ShowS + showsDimPrec _ = (showDim @d ++) + + -- | Convert a dimension to a string representing its type. + -- + -- >>> showDim @(Length ./. Time) + -- "Length .*. Time.^-1" + showDim :: String + showDim = showsDim @d "" + + -- | Same as @'showsDimPrec'@ but for pretty printing. + -- + -- @'prettysDimPrec'@ should satisfy the law : + -- + -- @prettysDimPrec d x r ++ s == prettysPrec d x (r ++ s)@ + -- + prettysDimPrec :: Int -> ShowS + prettysDimPrec _ = (prettyDim @d ++) + + -- | Same as @'showDim'@ but for pretty printing + -- + -- >>> putStrLn $ prettyDim @(Kilo Meter ./. Second) + -- km.s⁻¹ + -- + prettyDim :: String + prettyDim = prettysDim @d "" + +-- | Equivalent to 'showsDimPrec' with a precedence of 0. +-- +showsDim :: forall d. ShowDim d => ShowS +showsDim = showsDimPrec @d 0 + +-- | Equivalent to 'prettysDimPrec' with a precedence of 0. +-- +prettysDim :: forall d. ShowDim d => ShowS +prettysDim = prettysDimPrec @d 0 + +-- | Show the dimension of a quantity. +-- +-- >>> showDimOf (quantity @(Kilo Meter ./. Second) 1) +-- "Length .*. Time.^-1" +-- +showDimOf :: forall u a. (IsUnit u, ShowDim (DimOf u)) => u a -> String +showDimOf _ = showDim @(DimOf u) + +-- | Same as 'showDimOf' but for pretty printing. +-- >>> putStrLn $ prettyDimOf (quantity @(Kilo Meter ./. Second) 1) +-- L.T⁻¹ +prettyDimOf :: forall u a. (IsUnit u, ShowDim (DimOf u)) => u a -> String +prettyDimOf _ = prettyDim @(DimOf u) + +-- | Print the dimension of a quantity. +-- +-- >>> putDimOf (quantity @(Kilo Meter ./. Second) 1) +-- L.T⁻¹ +-- +putDimOf :: forall u a. (IsUnit u, ShowDim (DimOf u)) => u a -> IO () +putDimOf = putStrLn . prettyDimOf + + + +-- | The dimension of non dimensional quantities +-- +newtype NoDim a = NoDim a + deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real + , RealFrac, RealFloat, Bounded, Enum, Semigroup, Monoid, Functor) + + +type instance DimId NoDim = Pos 1 + +instance ShowDim NoDim where + type ShowDimType NoDim = Text "NoDim" + showDim = "NoDim" + prettyDim = "NoDim" + + +type family CmpDim (d :: Dim) (e :: Dim) :: Ordering where + CmpDim (d .*. d') (e .*. e') = + If (CmpDim d e == 'EQ) (CmpDim d' e') (CmpDim d e) + CmpDim (d .*. d') e ='LT + CmpDim d (e .*. e') = 'GT + CmpDim (d .^. dn) (e .^. en) = + If (CmpDim d e == 'EQ) (CmpSigned dn en) (CmpDim d e) + CmpDim (d .^. dn) e = + If (CmpDim d e == 'EQ) (CmpSigned dn (Pos 1)) (CmpDim d e) + CmpDim d (e .^. en) = + If (CmpDim d e == 'EQ) (CmpSigned (Pos 1) en) (CmpDim d e) + CmpDim d e = CmpSigned (DimId d) (DimId e) + + +-------------------------- Dimension normalization --------------------------- + + +-- | Helper type family for defining DimOf for .*. and .^. +-- +type family DimOf' (u :: Unit) :: Dim where + DimOf' u = NormalizeDim (UnitToDim u) + +type family UnitToDim (u :: Unit) :: Dim where + UnitToDim (u .*. v) = UnitToDim u .*. UnitToDim v + UnitToDim (u .^. n) = UnitToDim u .^. n + UnitToDim u = DimOf u + +type NormalizeDim d = NormalizeFlatDim (Flatten d) + +type family Flatten u where + Flatten (u .*. v) = Flatten u .*. Flatten v + Flatten ((u .*. v) .^. n) = Flatten (u .^. n) .*. Flatten (v .^. n) + Flatten ((u .^. n) .^. m) = Flatten (u .^. Mul n m) + Flatten (u .^. n) = u .^. n + Flatten u = u + +type family NormalizeFlatDim d where + NormalizeFlatDim (d .*. NoDim) = NormalizeFlatDim d + NormalizeFlatDim (NoDim .*. e) = NormalizeFlatDim e + NormalizeFlatDim ((d .*. e) .*. f) = NormalizeFlatDim (d .*. (e .*. f)) + NormalizeFlatDim (d .*. e) = + InsertDim (NormalizeFlatDim d) (NormalizeFlatDim e) + NormalizeFlatDim (NoDim .^. n) = NoDim + NormalizeFlatDim (d .^. n) = NormalizeExpDim (d .^. n) + NormalizeFlatDim d = d + +type family InsertDim d e where + InsertDim NoDim e = e + InsertDim d NoDim = d + InsertDim d (e .*. f) = + InsertCmpDim (Compare (DimId d) (DimId e)) d (e .*. f) + InsertDim d e = + InsertCmpDim (Compare (DimId d) (DimId e)) d e + +type family InsertCmpDim cmp d v where + InsertCmpDim 'LT d (e .*. f) = d .*. e .*. f + InsertCmpDim 'GT d (e .*. f) = e .*. InsertDim d f + InsertCmpDim 'EQ d (e .*. f) = MulNoDim (MulPowDim d e) f + InsertCmpDim 'LT d e = d .*. e + InsertCmpDim 'GT d e = e .*. d + InsertCmpDim 'EQ d e = MulPowDim d e + +type family MulNoDim d e where + MulNoDim NoDim e = e + MulNoDim d NoDim = d + MulNoDim d e = d .*. e + +type family MulPowDim d e where + MulPowDim (d .^. n) (d .^. m) = NormalizeExpDim (d .^. Add n m) + MulPowDim d (d .^. m) = NormalizeExpDim (d .^. Add (Pos 1) m) + MulPowDim (d .^. n) d = NormalizeExpDim (d .^. Add n (Pos 1)) + MulPowDim d d = d .^. Pos 2 + MulPowDim d e = TypeError ( + Text "Failed to multiply two different units ‘" + :<>: ShowUnitType d + :<>: Text "’ and ‘" + :<>: ShowUnitType e + :<>: Text "’ with the same dimension ‘" + :<>: ShowDimType (DimOf d) + :<>: Text "’." + :$$: Text "Hint : Did you try to multiply via (.*.) two quantities with" + :$$: Text " the same dimension but different units ?" + :$$: Text "If so, you might want to use (~*-), (-*~) or (~*~) instead. " + ) + +type family NormalizeExpDim u where + NormalizeExpDim (u .^. Pos 1) = u + NormalizeExpDim (u .^. Zero) = NoDim + NormalizeExpDim u = u + + +------------------------------------ Units ------------------------------------- + +-- | A unit is represented by a newtype constructor. A quantity of some unit +-- @u@ is of type @u a@. +-- +type Unit = Type -> Type + +-- | Any unit must have a dimension. Additionally, a unit is a newtype +-- constructor : a quantity @u a@ can always be coerced to its magnitude @a@. +-- +class (forall a. Coercible (u a) a) => IsUnit (u :: Unit) where + type DimOf u :: Dim + +-- | Make a quantity out of any numerical value (called the /magnitude/ of that +-- quantity) +-- +-- >>> quantity @(Meter ./. Second) 1 +-- quantity @(Meter .*. Second .^- 1) 1 +quantity :: forall u a. IsUnit u => a -> u a +quantity = coerce +{-# INLINE quantity #-} + +-- | Get the magnitude of a quantity. +-- +-- @unQuantity (quantity @u a) === a @ +-- +unQuantity :: IsUnit u => u a -> a +unQuantity = coerce +{-# INLINE unQuantity #-} + +-- | Units that can be shown as a string, or as a type error message. +-- +class IsUnit u => ShowUnit (u :: Unit) where + {-# MINIMAL showUnit | showsUnitPrec #-} + + -- | Allows to print units in conversion error messages + -- + -- >>> type ShowUnit Meter = "m" + -- + type ShowUnitType u :: ErrorMessage + + -- | Convert a unit to a readable string + -- + -- @'showsUnitPrec'@ should satisfy the law : + -- + -- @showsUnitPrec d x r ++ s == showsPrec d x (r ++ s)@ + -- + showsUnitPrec :: Int -> ShowS + showsUnitPrec _ = (showUnit @u ++) + + -- | Convert a unit to a string representing its type. + -- + -- >>> showUnit @(Kilo Meter ./. Second) + -- "Kilo Meter .*. Second.^-1" + showUnit :: String + showUnit = showsUnit @u "" + + -- | Same as @'showsUnitPrec'@ but for pretty printing. + -- + prettysUnitPrec :: Int -> ShowS + prettysUnitPrec _ = (prettyUnit @u ++) + + -- | Same as @'showUnit'@ but for pretty printing + -- + -- >>> putStrLn $ prettyUnit @(Kilo Meter ./. Second) + -- km.s⁻¹ + -- + prettyUnit :: String + prettyUnit = prettysUnit @u "" + + +-- | Equivalent to 'showsUnitPrec' with a precedence of 0. +-- +showsUnit :: forall u. ShowUnit u => ShowS +showsUnit = showsUnitPrec @u 0 + +-- | Equivalent to 'prettysUnitPrec' with a precedence of 0. +-- +prettysUnit :: forall u. ShowUnit u => ShowS +prettysUnit = prettysUnitPrec @u 0 + +-- | Pretty print information about a unit, its dimension and its normalized +-- form. +-- +prettyUnitInfo :: forall u du nu. + ( du ~ DimOf u + , nu ~ BaseUnitOf u + , ShowUnit u + , ShowDim du + , ShowUnit nu + ) => String +prettyUnitInfo = + "Unit: " ++ showUnit @u ++ "\n" ++ + " abbr: " ++ prettyUnit @u ++ "\n" ++ + "Dimension: " ++ showDim @du ++ "\n" ++ + " abbr: " ++ prettyDim @du ++ "\n" ++ + "Normalized: " ++ showUnit @nu ++ "\n" ++ + " abbr: " ++ prettyUnit @nu ++ "\n" + +-- | Print information about a unit, its dimension and its normalized form. +-- +-- >>> putInfoU @Newton +-- Unit: Newton +-- abbr: N +-- Dimension: Mass .*. Length .*. Time.^-2 +-- abbr: M⋅L⋅T⁻² +-- Normalized: Kilo Gram .*. Meter .*. Second.^-2 +-- abbr: kg⋅m⋅s⁻² +-- +putInfoU :: forall u du nu. + ( du ~ DimOf u + , nu ~ BaseUnitOf u + , ShowUnit u + , ShowDim du + , ShowUnit nu + ) => IO () +putInfoU = putStr $ prettyUnitInfo @u + +-- | Same as 'prettyUnitInfo' but for quantities. +-- +prettyQuantityInfo :: forall u a. + ( ShowUnit u + , ShowDim (DimOf u) + , ShowUnit (BaseUnitOf u) + , Show a + ) => u a -> String +prettyQuantityInfo u = prettyUnitInfo @u ++ + "Magnitude: " ++ show (unQuantity u) ++ "\n" + +-- | Same as 'putInfoU' but for quantities. +-- +-- >>> putInfoQ (Newton 4) +-- Unit: Newton +-- abbr: N +-- Dimension: Mass .*. Length .*. Time.^-2 +-- abbr: M⋅L⋅T⁻² +-- Normalized: Kilo Gram .*. Meter .*. Second.^-2 +-- abbr: kg⋅m⋅s⁻² +-- Magnitude: 4 +putInfoQ :: forall u a. + ( ShowUnit u + , ShowDim (DimOf u) + , ShowUnit (BaseUnitOf u) + , Show a + ) => u a -> IO () +putInfoQ u = putStr $ prettyQuantityInfo @u u + + +-- | Same as 'showsUnitPrec' but for quantities. +-- +showsQuantityPrec :: forall u a. (ShowUnit u, Show a) => Int -> u a -> ShowS +showsQuantityPrec d u = showParen (d > 10) $ + showString "quantity @" . showsUnitPrec @u 11 . showString " " . + showsPrec 11 (unQuantity u) + +-- | Equivalent to 'showsQuantityPrec' with a precedence of 0. +-- +showsQuantity :: (ShowUnit u, Show a) => u a -> ShowS +showsQuantity = showsQuantityPrec 0 + +-- | Same as 'showUnit' but for quantities +-- +-- >>> showQuantity (quantity @(Kilo Meter ./. Second) 1) +-- "quantity @(Kilo Meter .*. Second.^-1) 1.0" +-- +showQuantity :: (ShowUnit u, Show a) => u a -> String +showQuantity u = showsQuantity u "" + +-- | Same as 'prettyUnit' but for quantities +-- +-- >>> putStrLn $ prettyQuantity (quantity @(Kilo Meter ./. Second) 1) +-- 1 km.s⁻¹ +-- +prettyQuantity :: forall u a. (ShowUnit u, Show a) => u a -> String +prettyQuantity u = show (unQuantity u) ++ " " ++ prettyUnit @u + +-- | Pretty print a quantity. +-- +-- >>> putQuantity (quantity @(Kilo Meter ./. Second) 1) +-- 1 km.s⁻¹ +putQuantity :: (Show a, ShowUnit u) => u a -> IO () +putQuantity = putStrLn . prettyQuantity + + +-------------------------------------------------------------------------------- + + +-- | A unit that can represent any unit. +-- +-- This can be used with the `deriving via` mechanism to derive some of the +-- unit instances. +-- +newtype MetaUnit (u :: Unit) a = MetaUnit a + deriving ( Eq, Ord, Num, Fractional, Floating, Real + , RealFrac, RealFloat, Bounded, Enum, Semigroup, Monoid, Functor) + +instance ShowUnit u => ShowUnit (MetaUnit u) where + type ShowUnitType (MetaUnit u) = ShowUnitType u + prettysUnitPrec = prettysUnitPrec @u + showsUnitPrec = showsUnitPrec @u + +instance (Show a, ShowUnit u) => Show (MetaUnit u a) where + showsPrec = showsQuantityPrec + +instance IsUnit u => IsUnit (MetaUnit u) where + type DimOf (MetaUnit u) = DimOf u + +-------------------------------------------------------------------------------- + +-- | A unit that has no dimension. +-- +-- @ +-- type MyHertz = NoUnit ./. Second +-- @ +-- +newtype NoUnit a = NoUnit a + deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real + , RealFrac, RealFloat, Functor) + +instance IsUnit NoUnit where + type DimOf NoUnit = NoDim + +instance IsDim NoDim where + type DimToUnit NoDim = NoUnit + + +-- | Multiplication of two units. +-- +-- @ +-- type MyForceMoment = Newton .*. Meter +-- @ +-- +newtype ((u :: Unit) .*. (v :: Unit)) a = MulUnit a + deriving ( Eq, Ord, Num, Fractional, Floating, Real + , RealFrac, RealFloat, Functor) + deriving Show via MetaUnit (u .*. v) a + +infixr 7 .*. + +instance (ShowUnit u, ShowUnit v) => ShowUnit (u .*. v) where + type ShowUnitType (u .*. v) = + ShowUnitType u + :<>: Text "⋅" :<>: ShowUnitType v + prettysUnitPrec d = showParen (d > 7) $ + prettysUnitPrec @u 7 . showString "⋅" . prettysUnitPrec @v 7 + showsUnitPrec d = showParen (d > 7) $ + showsUnitPrec @u 7 . showString " .*. " . showsUnitPrec @v 7 + +instance (ShowDim u, ShowDim v) => ShowDim (u .*. v) where + type ShowDimType (u .*. v) = + ShowDimType u + :<>: Text "⋅" :<>: ShowDimType v + prettysDimPrec d = showParen (d > 7) $ + prettysDimPrec @u 7 . showString "⋅" . prettysDimPrec @v 7 + showsDimPrec d = showParen (d > 7) $ + showsDimPrec @u 7 . showString " .*. " . showsDimPrec @v 7 + + +instance (IsUnit u, IsUnit v) => IsUnit (u .*. v) where + type DimOf (u .*. v) = DimOf' (u .*. v) + +instance (IsDim d, IsDim e) => IsDim (d .*. e) where + type DimToUnit (d .*. e) = DimToUnit d .*. DimToUnit e + + + +-------------------------------- Unit division --------------------------------- + +type family InverseUnit u where + InverseUnit (u .*. v) = InverseUnit u .*. InverseUnit v + InverseUnit (u .^. n) = NormalizeExp (u .^. Negate n) + InverseUnit NoUnit = NoUnit + InverseUnit u = u .^. Neg 1 + +-- | Division of two units. +-- +-- @ +-- type MySpeed a = (Meter ./. Second) a +-- type MyMolarEntropy a = (Joule ./. Mole .*. Kelvin) a +-- @ +-- +-- Notice that multiplication has priority over division. +-- +type family (u :: Unit) ./. (v :: Unit) :: Unit where + u ./. v = u .*. InverseUnit v + +infix 6 ./. + + +----------------------------- Unit exponentiation ------------------------------ + + +-- | Exponentiation of a unit +-- +-- @ +-- type Acceleration = Meter .*. Second .^. Neg 2 +-- @ +-- +newtype ((u :: Unit) .^. (n :: ZZ)) a = PowUnit a + deriving ( Eq, Ord, Num, Fractional, Floating, Real + , RealFrac, RealFloat, Functor) + deriving Show via MetaUnit (u .^. n) a +infix 8 .^. + +-- | Positive exponentiation of a unit +-- +-- @ +-- type Area = Meter .^+ 2 +-- @ +-- +type a .^+ b = a .^. Pos b +infix 8 .^+ + +-- | Negative exponentiation of a unit +-- +-- @ +-- type Hertz = Second .^- 1 +-- @ +-- +type a .^- b = a .^. Neg b +infix 8 .^- + +type instance DimId (d .^. n) = DimId d + +type family ShowIntExponent (n :: ZZ) :: ErrorMessage where + ShowIntExponent (Pos n) = + If (n <=? 9) (ShowDigitExponent n) (Text "^" :<>: ShowType n) + ShowIntExponent Zero = Text "⁰" + ShowIntExponent (Neg n) = + If (n <=? 9) (Text "⁻" :<>: ShowDigitExponent n) + (Text "^-" :<>: ShowType n) + +type family ShowDigitExponent (n :: Nat) :: ErrorMessage where + ShowDigitExponent 0 = Text "⁰" + ShowDigitExponent 1 = Text "¹" + ShowDigitExponent 2 = Text "²" + ShowDigitExponent 3 = Text "³" + ShowDigitExponent 4 = Text "⁴" + ShowDigitExponent 5 = Text "⁵" + ShowDigitExponent 6 = Text "⁶" + ShowDigitExponent 7 = Text "⁷" + ShowDigitExponent 8 = Text "⁸" + ShowDigitExponent 9 = Text "⁹" + +instance IsUnit u => IsUnit (u .^. n) where + type DimOf (u .^. n) = DimOf' (u .^. n) + +instance IsDim d => IsDim (d .^. n) where + type DimToUnit (d .^. n) = DimToUnit d .^. n + + +instance (ShowUnit u, KnownInt n) => ShowUnit (u .^. n) where + type ShowUnitType (u .^. n) = + ShowUnitType u :<>: ShowIntExponent n + prettysUnitPrec d = showParen (d >= 8) $ + prettysUnitPrec @u 8 . showString (toSuperscript <$> show (intVal (Proxy :: Proxy n))) + showsUnitPrec d = showParen (d >= 8) $ + if n >= 0 then + showsUnitPrec @u 8 . showString ".^+" . shows n + else + showsUnitPrec @u 8 . showString ".^-" . shows (-n) + where + n = intVal (Proxy :: Proxy n) + +instance (ShowDim u, KnownInt n) => ShowDim (u .^. n) where + type ShowDimType (u .^. n) = + ShowDimType u :<>: ShowIntExponent n + prettysDimPrec d = showParen (d >= 8) $ + prettysDimPrec @u 8 . showString (toSuperscript <$> show (intVal (Proxy :: Proxy n))) + showsDimPrec d = showParen (d >= 8) $ + if n >= 0 then + showsDimPrec @u 8 . showString ".^+" . shows n + else + showsDimPrec @u 8 . showString ".^-" . shows (-n) + where + n = intVal (Proxy :: Proxy n) + + +toSuperscript :: Char -> Char +toSuperscript '0' = '⁰' +toSuperscript '1' = '¹' +toSuperscript '2' = '²' +toSuperscript '3' = '³' +toSuperscript '4' = '⁴' +toSuperscript '5' = '⁵' +toSuperscript '6' = '⁶' +toSuperscript '7' = '⁷' +toSuperscript '8' = '⁸' +toSuperscript '9' = '⁹' +toSuperscript '+' = '⁺' +toSuperscript '-' = '⁻' +toSuperscript ')' = '⁾' +toSuperscript '(' = '⁽' +toSuperscript '=' = '⁼' +toSuperscript a = a + +------------------------------ Unit normalization ------------------------------ + +-- | Normalizes a unit by converting it to a product of exponentiations of base +-- units. +type BaseUnitOf u = DimToUnit (DimOf u) + +-- | Multiplies two units and normalizes the result. +-- +type (u :: Unit) ~*~ (v :: Unit) = BaseUnitOf (u .*. v) + +infixr 7 ~*~ + +-- | Divides two units and normalizes the result. +-- +type (u :: Unit) ~/~ (v :: Unit) = BaseUnitOf (u ./. v) + +infixr 6 ~/~ + +-- | Exponentiates a unit and normalizes the result. +-- +type (u :: Unit) ~^~ (n :: ZZ) = BaseUnitOf (u .^. n) + +infixr 8 ~^~ + + +type family MulNoUnit d e where + MulNoUnit NoUnit e = e + MulNoUnit d NoUnit = d + MulNoUnit d e = d .*. e + +type family NormalizeExp u where + NormalizeExp (u .^. Pos 1) = u + NormalizeExp (u .^. Zero) = NoUnit + NormalizeExp u = u + + +--------------------- Unit normalization left priority ---------------------- + +-- | Tries to normalize a unit without converting to base units. +-- +-- >>> :kind! NormalizeUnitR (Minute .*. Second) +-- Minute .^. Pos 2 +-- +type NormalizeUnitL u = NormalizeFlatUnitL (Flatten u) + +-- | Multiplies two units and use left weak normalization. +type (u :: Unit) .*~ (v :: Unit) = NormalizeUnitL (u .*. v) + +infixr 7 .*~ + +-- | Divides two units and use left weak normalization. +type (u :: Unit) ./~ (v :: Unit) = NormalizeUnitL (u ./. v) + +infixr 6 ./~ + +-- | Exponentiates a unit and use left weak normalization. +type (u :: Unit) .^~ (n :: ZZ) = NormalizeUnitL (u .^. n) + +infixr 8 .^~ + + +type family NormalizeFlatUnitL u where + NormalizeFlatUnitL (u .*. NoUnit) = NormalizeFlatUnitL u + NormalizeFlatUnitL (NoUnit .*. v) = NormalizeFlatUnitL v + NormalizeFlatUnitL ((u .*. v) .*. w) = NormalizeFlatUnitL (u .*. (v .*. w)) + NormalizeFlatUnitL (u .*. v) = + InsertUnitL (NormalizeFlatUnitL u) (NormalizeFlatUnitL v) + NormalizeFlatUnitL (NoUnit .^. n) = NoUnit + NormalizeFlatUnitL (u .^. n) = NormalizeExp (u .^. n) + NormalizeFlatUnitL u = u + +type family InsertUnitL u v where + InsertUnitL NoUnit v = v + InsertUnitL u NoUnit = u + InsertUnitL (u .*. v) w = + TypeError (Text + "Insert unit : Removing left association failed in NormalizeFlatUnitL") + InsertUnitL (u .^. n) (v .^. m .*. w) = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m .*. w) + InsertUnitL (u .^. n) (v .*. w) = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .*. w) + InsertUnitL (u .^. n) (v .^. m) = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m) + InsertUnitL (u .^. n) v = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) (u .^. n) v + InsertUnitL u (v .^. m .*. w) = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) u (v .^. m .*. w) + InsertUnitL u (v .*. w) = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) u (v .*. w) + InsertUnitL u (v .^. m) = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) u (v .^. m) + InsertUnitL u v = + InsertCmpL (CmpDim (DimOf u) (DimOf v)) u v + +type family InsertCmpL cmp u v where + InsertCmpL 'LT u (v .*. w) = u .*. v .*. w + InsertCmpL 'GT u (v .*. w) = v .*. InsertUnitL u w + InsertCmpL 'EQ u (v .*. w) = MulNoUnit (MulSameDimL u v) w + InsertCmpL 'LT u v = u .*. v + InsertCmpL 'GT u v = v .*. u + InsertCmpL 'EQ u v = MulSameDimL u v + +type family MulSameDimL u v where + MulSameDimL (u .^. n) (v .^. m) = NormalizeExp (u .^. Add n m) + MulSameDimL u (v .^. m) = NormalizeExp (u .^. Add (Pos 1) m) + MulSameDimL (u .^. n) v = NormalizeExp (u .^. Add n (Pos 1)) + MulSameDimL u v = u .^. Pos 2 + + + +---------------------- Unit normalization right priotiy ----------------------- + +-- The only difference with right is MulSameDim + + +-- | Tries to normalize a unit without converting to base units. When two units +-- have the same dimension, they will be collapsed to an exponentiation right +-- most unit. +-- +-- >>> :kind! NormalizeUnitR (Minute .*. Second) +-- Second .^. Pos 2 +-- +type NormalizeUnitR u = NormalizeFlatUnitR (Flatten u) + +-- | Same as @'(~*.)'@ but with priority to right most units +type (u :: Unit) ~*. (v :: Unit) = NormalizeUnitR (u .*. v) + +infixr 7 ~*. + +-- | Same as @'(~/.)'@ but with priority to right most units +type (u :: Unit) ~/. (v :: Unit) = NormalizeUnitR (u ./. v) + +infixr 7 ~/. + +-- | Same as @'(.^~)'@ but with priority to right most units +type (u :: Unit) ~^. (n :: ZZ) = NormalizeUnitR (u .^. n) + +infix 8 ~^. + + +type family NormalizeFlatUnitR u where + NormalizeFlatUnitR (u .*. NoUnit) = NormalizeFlatUnitR u + NormalizeFlatUnitR (NoUnit .*. v) = NormalizeFlatUnitR v + NormalizeFlatUnitR ((u .*. v) .*. w) = NormalizeFlatUnitR (u .*. (v .*. w)) + NormalizeFlatUnitR (u .*. v) = + InsertUnitR (NormalizeFlatUnitR u) (NormalizeFlatUnitR v) + NormalizeFlatUnitR (NoUnit .^. n) = NoUnit + NormalizeFlatUnitR (u .^. n) = NormalizeExp (u .^. n) + NormalizeFlatUnitR u = u + +type family InsertUnitR u v where + InsertUnitR NoUnit v = v + InsertUnitR u NoUnit = u + InsertUnitR (u .*. v) w = + TypeError (Text + "Insert unit : Removing left association failed in NormalizeFlatUnitR") + InsertUnitR (u .^. n) (v .^. m .*. w) = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m .*. w) + InsertUnitR (u .^. n) (v .*. w) = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .*. w) + InsertUnitR (u .^. n) (v .^. m) = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) (v .^. m) + InsertUnitR (u .^. n) v = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) (u .^. n) v + InsertUnitR u (v .^. m .*. w) = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) u (v .^. m .*. w) + InsertUnitR u (v .*. w) = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) u (v .*. w) + InsertUnitR u (v .^. m) = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) u (v .^. m) + InsertUnitR u v = + InsertCmpR (CmpDim (DimOf u) (DimOf v)) u v + +type family InsertCmpR cmp u v where + InsertCmpR 'LT u (v .*. w) = u .*. v .*. w + InsertCmpR 'GT u (v .*. w) = v .*. InsertUnitR u w + InsertCmpR 'EQ u (v .*. w) = MulNoUnit (MulSameDimR u v) w + InsertCmpR 'LT u v = u .*. v + InsertCmpR 'GT u v = v .*. u + InsertCmpR 'EQ u v = MulSameDimR u v + +type family MulSameDimR u v where + MulSameDimR (u .^. n) (v .^. m) = NormalizeExp (v .^. Add n m) + MulSameDimR u (v .^. m) = NormalizeExp (v .^. Add (Pos 1) m) + MulSameDimR (u .^. n) v = NormalizeExp (v .^. Add n (Pos 1)) + MulSameDimR u v = v .^. Pos 2 diff --git a/src/Data/Units/Core/TH.hs b/src/Data/Units/Core/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Core/TH.hs @@ -0,0 +1,438 @@ + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.Core.TH +-- Description : Template Haskell quasi quoter for unit declaration +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-------------------------------------------------------------------------------- + + +module Data.Units.Core.TH + ( -- * Units + mkUnit + , mkUnitNoFactor + , mkBaseUnit + -- * Dimensions + , mkDim + -- * Prefixes + , mkPrefix + ) + where + +import GHC.TypeError + +import Language.Haskell.TH + +import Data.Type.Int +import Data.Units.Core.System +import Data.Units.Core.Convert +import Data.Units.Core.Prefix + +------------------------------------ Units ------------------------------------- + +-- | List of derived class for a unit. +-- +deriveList :: [Name] +deriveList = + [''Eq + , ''Ord + , ''Num + , ''Fractional + , ''Floating + , ''Real + , ''RealFrac + , ''RealFloat + ] + +-- | List of derived classes for a unit. +-- +deriveListUnit :: [Name] +deriveListUnit = ''Show : deriveList + +-- | Make a newtype of the form +-- +-- @ +-- newtype Minute a = Minute a +-- deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real +-- , RealFrac, RealFloat) +-- @ +-- +mkUnitNewtype :: Quote m + => [Name] -> Name -> m Dec +mkUnitNewtype l unitName = + let a = varT (mkName "a") in + newtypeD + (cxt []) + unitName + [PlainTV (mkName "a") BndrReq] + Nothing + (normalC unitName + [bangType (bang noSourceUnpackedness noSourceStrictness) a]) + [ derivClause Nothing (conT <$> l)] + +-- | Make instance of the form +-- +-- @ +-- instance IsUnit Hour where +-- type DimOf Hour = Time +-- @ +-- +mkIsUnitInstance :: Quote m => Name -> Name -> m [Dec] +mkIsUnitInstance unitName dimName = [d| + instance IsUnit $(conT unitName) where + type DimOf $(conT unitName) = $(conT dimName) + |] + +-- | Make an instance of the form +-- +-- @ +-- instance ShowUnit Minute where +-- type ShowUnitType Minute = Text "min" +-- showUnit = "Minute" +-- prettyUnit = "min" +-- @ +-- +mkShowUnitInstance :: Quote m => Name -> String -> String -> m [Dec] +mkShowUnitInstance unitName unitStr prettyStr = [d| + instance ShowUnit $(conT unitName) where + type ShowUnitType $(conT unitName) = Text $(pure (LitT (StrTyLit prettyStr))) + showUnit = $(litE (StringL unitStr)) + prettyUnit = $(litE (StringL prettyStr)) + |] + + +-- | Make an instance of the form +-- +-- @ +-- instance Fractional a => ConversionFactor Minute a where +-- factor = 60 +-- @ +-- +mkConvFactorInstance :: Quote m => Name -> Rational -> m [Dec] +mkConvFactorInstance unitName fctr = [d| + instance Fractional a => ConversionFactor $(conT unitName) a where + factor = $(litE (RationalL fctr)) + |] + + +-- | Make an instance of the form +-- +-- @ +-- instance Fractional a => ConvertibleUnit Minute a +-- @ +-- +mkDefaultSigConvertibleInstance :: Quote m => Name -> m [Dec] +mkDefaultSigConvertibleInstance unitName = [d| + instance Fractional a => ConvertibleUnit $(conT unitName) a + |] + +-- | Make an instance of the form +-- +-- @ +-- instance Fractional a => ConvertibleUnit Meter a where +-- toBaseUnit = coerce +-- {-# INLINE toBaseUnit #-} +-- fromBaseUnit = coerce +-- {-# INLINE fromBaseUnit #-} +-- @ +-- +mkNormalConvertibleInstance :: Quote m => Name -> m [Dec] +mkNormalConvertibleInstance unitName = [d| + instance Fractional a => ConvertibleUnit $(conT unitName) a where + toBaseUnit = coerce + {-# INLINE toBaseUnit #-} + fromBaseUnit = coerce + {-# INLINE fromBaseUnit #-} + |] + + +-- | Make a unit that can be converted via a factor +-- +-- [Usage:] +-- +-- @ +-- \$(mkUnit "Minute" "min" ''Time 60) +-- @ +-- +mkUnit :: String -> String -> Name -> Rational -> Q [Dec] +mkUnit unitStr prettyStr dimName fctr = do + let unitName = mkName unitStr + newtypeDec <- mkUnitNewtype deriveListUnit unitName + isUnitDec <- mkIsUnitInstance unitName dimName + showUnitDec <- mkShowUnitInstance unitName unitStr prettyStr + convFactorDec <- mkConvFactorInstance unitName fctr + convUnitDec <- + if fctr == 1 then + mkNormalConvertibleInstance unitName + else + mkDefaultSigConvertibleInstance unitName + return $ + [newtypeDec] ++ isUnitDec ++ showUnitDec ++ convFactorDec ++ convUnitDec + +-- | Make a unit without declaring any conversion instances. +-- +-- Conversion instances must be added by hand. +-- +-- [Usage:] +-- +-- @ +-- \$(mkUnit \"Bel\" "B" ''NoUnit ) +-- @ +-- +mkUnitNoFactor :: String -> String -> Name -> Q [Dec] +mkUnitNoFactor unitStr prettyStr dimName = do + let unitName = mkName unitStr + newtypeDec <- mkUnitNewtype deriveListUnit unitName + isUnitDec <- mkIsUnitInstance unitName dimName + showUnitDec <- mkShowUnitInstance unitName unitStr prettyStr + return $ [newtypeDec] ++ isUnitDec ++ showUnitDec + + +-- | Make a base unit. +-- +-- In addition to calling 'mkUnit' with factor 1, this also makes an +-- instance of 'IsDim', which cannot be done in 'mkDim' since the base unit is +-- not yet declared. +-- +-- [Usage:] +-- +-- @ \$(mkBaseUnit "Second" "s" ''Time ) @ +-- +mkBaseUnit :: String -> String -> Name -> Q [Dec] +mkBaseUnit unitStr prettyStr dimName = do + let unitName = mkName unitStr + unitDec <- mkUnit unitStr prettyStr dimName 1 + isDimDec <- mkIsDimInstance dimName unitName + return $ unitDec ++ isDimDec + +---------------------------------- Dimensions ---------------------------------- + +-- | List of derived classes for a dimension. +-- +deriveListDim :: [Name] +deriveListDim = deriveListUnit + + +mkDimNewtype :: Quote m + => [Name] -> Name -> m Dec +mkDimNewtype = mkUnitNewtype + +-- | Make an instance of the form +-- +-- @ +-- instance IsDim Time where +-- type DimToUnit Time = Second +-- @ +-- +mkIsDimInstance :: Quote m => Name -> Name -> m [Dec] +mkIsDimInstance dimName unitName = [d| + instance IsDim $(conT dimName) where + type DimToUnit $(conT dimName) = $(conT unitName) + |] + +-- | Make a type instance of the form +-- +-- @ +-- type instance DimId Time = 400 +-- @ +-- +mkDimIdTypeInstance :: Quote m => Name -> Integer -> m [Dec] +mkDimIdTypeInstance dimName n = [d| + type instance DimId $(conT dimName) = Pos $(litT (numTyLit n)) + |] + +-- | Make a type instance of the form +-- +-- @ +-- instance ShowDim Minute where +-- type ShowDimType Minute = Text "min" +-- showDim = "Minute" +-- prettyDim = "min" +-- @ +-- +mkShowDimInstance :: Quote m => Name -> String -> String -> m [Dec] +mkShowDimInstance dimName dimStr prettyStr = [d| + instance ShowDim $(conT dimName) where + type ShowDimType $(conT dimName) = Text $(pure (LitT (StrTyLit prettyStr))) + showDim = $(litE (StringL dimStr)) + prettyDim = $(litE (StringL prettyStr)) + |] + +-- | Make a dimension. +-- +-- This will not declare an instance for 'IsDim', which is instead declared +-- using 'mkBaseUnit'. + +-- [Usage:] +-- +-- @ \$(mkDim "Time" "T" 400) @ +-- +mkDim :: String -> String -> Integer -> Q [Dec] +mkDim dimStr prettyStr n = do + let dimName = mkName dimStr + newtypeDec <- mkDimNewtype deriveListDim dimName + -- isDimDec <- mkIsDimInstance dimName unitName + dimIdDec <- mkDimIdTypeInstance dimName n + showDimDec <- mkShowDimInstance dimName dimStr prettyStr + return $ [newtypeDec] ++ dimIdDec ++ showDimDec + + + +----------------------------------- Prefixes ----------------------------------- + + + +-- | Make a newtype of the form: +-- +-- @ +-- newtype Milli (u :: Unit) a = Milli (u a) +-- deriving (Eq, Ord, Num, Fractional, Floating, Real +-- , RealFrac, RealFloat, Functor) +-- deriving Show via MetaPrefix Milli u a +-- deriving ShowUnit via MetaPrefix Milli u +-- @ +-- +mkPrefixNewtype :: Monad m => [Name] -> Name -> m Dec +mkPrefixNewtype l prefixName = pure $ + NewtypeD + [] + prefixName + [ KindedTV (mkName "u") BndrReq (ConT ''Unit) + , PlainTV (mkName "a") BndrReq + ] + Nothing + (NormalC prefixName + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , AppT (VarT (mkName "u")) (VarT (mkName "a")) + ) + ]) + [ DerivClause + (Just NewtypeStrategy) + (map ConT l) + , DerivClause + (Just (ViaStrategy viaType)) + [ConT ''Show] + , DerivClause + (Just (ViaStrategy viaTypeNoA)) + [ConT ''ShowUnit] + ] + where + viaType = + foldl AppT (ConT ''MetaPrefix) + [ ConT prefixName + , VarT (mkName "u") + , VarT (mkName "a") + ] + + viaTypeNoA = + foldl AppT (ConT ''MetaPrefix) + [ ConT prefixName + , VarT (mkName "u") + ] + +-- | Make a deriving instance of the form +-- +-- @ +-- deriving via MetaPrefix Milli u instance IsUnit u => IsUnit (Milli u ) +-- @ +-- +mkPrefixIsUnitInstance :: Name -> Q [Dec] +mkPrefixIsUnitInstance prefixName = [d| + deriving via MetaPrefix $(conT prefixName) u instance IsUnit u => IsUnit ($(conT prefixName) u) + |] + +-- | Make an instance of the form +-- +-- @ +-- instance ShowPrefix Milli where +-- type ShowPrefixType Milli = Text "m" +-- showPrefix = "Milli" +-- prettyPrefix = "m" +-- @ +-- +mkShowPrefixInstance :: Quote m => Name -> String -> String -> m [Dec] +mkShowPrefixInstance prefixName prefixStr prettyStr = [d| + instance ShowPrefix $(conT prefixName) where + type ShowPrefixType $(conT prefixName) = Text $(pure (LitT (StrTyLit prettyStr))) + showPrefix = $(litE (StringL prefixStr)) + prettyPrefix = $(litE (StringL prettyStr)) + |] + +-- | Make an instance of the form +-- +-- @ +-- instance Fractional a => PrefixFactor Kilo a where +-- prefixFactor = 1000 +-- {-# INLINE prefixFactor #-} +-- +mkPrefixFactorInstance :: Name -> Rational -> Q [Dec] +mkPrefixFactorInstance prefixName fctr = [d| + instance Fractional a => PrefixFactor $(conT prefixName) a where + prefixFactor = $(litE (RationalL fctr)) + {-# INLINE prefixFactor #-} + |] + +-- | Make an instance of the form +-- +-- @ +-- instance ConversionFactor u a => ConversionFactor (Milli u) a where +-- factor = factor @(MetaPrefix Milli u) +-- {-# INLINE factor #-} +-- @ +-- +mkPrefixConvFactorInstance :: Name -> Q [Dec] +mkPrefixConvFactorInstance prefixName = [d| + instance ConversionFactor u a => ConversionFactor ($(conT prefixName) u) a where + factor = factor @(MetaPrefix $(conT prefixName) u) + {-# INLINE factor #-} + |] + +-- | Make an instance of the form +-- +-- @ +-- instance (ConvertibleUnit u a, Fractional a) +-- => ConvertibleUnit (Milli u) a where +-- toBaseUnit = prefixToBaseUnit +-- {-# INLINE toBaseUnit #-} +-- fromBaseUnit = prefixFromBaseUnit +-- {-# INLINE fromBaseUnit #-} +-- @ +-- +mkPrefixConvUnitInstance :: Name -> Q [Dec] +mkPrefixConvUnitInstance prefixName = [d| + instance (ConvertibleUnit u a, Fractional a) + => ConvertibleUnit ($(conT prefixName) u) a where + toBaseUnit = prefixToBaseUnit + {-# INLINE toBaseUnit #-} + fromBaseUnit = prefixFromBaseUnit + {-# INLINE fromBaseUnit #-} + |] + +-- | Make a unit prefix. +-- +-- [Usage:] +-- +-- @ +-- \$(mkPrefix "Kilo" "k" 1000) +-- @ +-- +mkPrefix :: String -> String -> Rational -> Q [Dec] +mkPrefix prefixStr prettyStr fctr = do + let prefixName = mkName prefixStr + newtypeDec <- mkPrefixNewtype deriveList prefixName + isUnitDec <- mkPrefixIsUnitInstance prefixName + showPrefixDec <- mkShowPrefixInstance prefixName prefixStr prettyStr + factorDec <- mkPrefixFactorInstance prefixName fctr + convFactorDec <- mkPrefixConvFactorInstance prefixName + convUnitDec <- mkPrefixConvUnitInstance prefixName + return $ [newtypeDec] ++ isUnitDec ++ showPrefixDec + ++ factorDec ++ convFactorDec ++ convUnitDec + + + diff --git a/src/Data/Units/Imperial.hs b/src/Data/Units/Imperial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Imperial.hs @@ -0,0 +1,6 @@ +module Data.Units.Imperial + (module Data.Units.Imperial.Length + ) where + +import Data.Units.Imperial.Length + diff --git a/src/Data/Units/Imperial/Area.hs b/src/Data/Units/Imperial/Area.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Imperial/Area.hs @@ -0,0 +1,20 @@ +module Data.Units.Imperial.Area + ( Acre(..) + , Perch(..) + , Rood(..) + ) where + +import Data.Units.Core +import Data.Units.SI + +-- | Area in acres. +-- +$(mkUnit "Acre" "ac" ''Area $ (1200 / 3937)^ (2 :: Integer) * 43560) + +-- | Area in perches. +-- +$(mkUnit "Perch" "perch" ''Area $ (1200 / 3937)^ (2 :: Integer) * 1089 / 4) + +-- | Area in roods. +-- +$(mkUnit "Rood" "ro" ''Area $ (1200 / 3937)^ (2 :: Integer) * 10890) diff --git a/src/Data/Units/Imperial/Length.hs b/src/Data/Units/Imperial/Length.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Imperial/Length.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Units.Imperial.Length + ( Twip(..) + , Thou(..) + , Barleycorn(..) + , Inch(..) + , Hand(..) + , Foot(..) + , Yard(..) + , Chain(..) + , Furlong(..) + , Mile(..) + , League(..) + , Fathom(..) + , Cable(..) + , NauticalMile(..) + , Link(..) + , Rod(..) + ) where + +import Data.Units.Core +import Data.Units.SI + + +-- | Length in feet. +$(mkUnit "Foot" "ft" ''Length $ 1200 / 3937) + +-- | Length in twips. +$(mkUnit "Twip" "twip" ''Length $ 1200 / 3937 / 17280) + +-- | Length in thous. +$(mkUnit "Thou" "th" ''Length $ 1200 / 3937 / 12000) + +-- | Length in barleycorns. +$(mkUnit "Barleycorn" "barleycorn" ''Length $ 1200 / 3937 / 36) + +-- | Length in inches. +$(mkUnit "Inch" "in" ''Length $ 1200 / 3937 / 12) + +-- | Length in hands. +$(mkUnit "Hand" "hh" ''Length $ 1200 / 3937 / 3) + +-- | Length in yards. +$(mkUnit "Yard" "yd" ''Length $ 1200 / 3937 * 3) + +-- | Length in chains. +$(mkUnit "Chain" "ch" ''Length $ 1200 / 3937 * 66) + +-- | Length in furlongs. +$(mkUnit "Furlong" "fur" ''Length $ 1200 / 3937 * 660) + +-- | Length in miles. +$(mkUnit "Mile" "mi" ''Length $ 1200 / 3937 * 5280) + +-- | Length in leagues. +$(mkUnit "League" "lea" ''Length $ 1200 / 3937 * 15840) + +-- | Length in fathoms. +$(mkUnit "Fathom" "ftm" ''Length $ 1200 / 3937 * 6.0761) + +-- | Length in cables. +$(mkUnit "Cable" "cable" ''Length $ 1200 / 3937 * 607.61) + +-- | Length in nautical miles. +$(mkUnit "NauticalMile" "nmi" ''Length $ 1200 / 3937 * 60761 / 10) + +-- | Length in links. +$(mkUnit "Link" "lnk" ''Length $ 1200 / 3937 * 66 / 100) + +-- | Length in rods. +$(mkUnit "Rod" "rod" ''Length $ 1200 / 3937 * 66 / 4) diff --git a/src/Data/Units/NonSI.hs b/src/Data/Units/NonSI.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonSI.hs @@ -0,0 +1,10 @@ +module Data.Units.NonSI + ( module Data.Units.NonSI.Temperature + , module Data.Units.NonSI.Frequency + , module Data.Units.NonSI.Time + ) + where + +import Data.Units.NonSI.Temperature +import Data.Units.NonSI.Frequency +import Data.Units.NonSI.Time diff --git a/src/Data/Units/NonSI/Area.hs b/src/Data/Units/NonSI/Area.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonSI/Area.hs @@ -0,0 +1,7 @@ +module Data.Units.NonSI.Area + ( module Data.Units.Imperial.Area + , module Data.Units.UsCustomary.Area + ) where + +import Data.Units.Imperial.Area +import Data.Units.UsCustomary.Area diff --git a/src/Data/Units/NonSI/Frequency.hs b/src/Data/Units/NonSI/Frequency.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonSI/Frequency.hs @@ -0,0 +1,68 @@ +module Data.Units.NonSI.Frequency where + +import Control.Exception +import Data.Word +import Data.Fixed +import GHC.TypeLits +import Data.Proxy + +import Data.Units.Core +import Data.Units.SI.System + +-- | Frequency in Tone Equal Temperament. +newtype Tet (b :: Nat) (offs :: ZZ) a = Tet a + deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real + , RealFrac, RealFloat) + +instance (Floating a, KnownNat b, KnownInt offs) + => ConvertibleUnit (Tet b offs) a where + toBaseUnit (Tet a) = quantity $ 440 * 2 ** ((a + offs) / b) + where + b = fromIntegral $ natVal (Proxy :: Proxy b) + offs = fromIntegral (intVal (Proxy :: Proxy offs)) / 100 + fromBaseUnit a = Tet $ b * logBase 2 (unQuantity a/ 440) - offs + where + b = fromIntegral $ natVal (Proxy :: Proxy b) + offs = fromIntegral (intVal (Proxy :: Proxy offs)) / 100 + +instance IsUnit (Tet b offs) where + type DimOf (Tet b offs) = Time .^- 1 + +instance (KnownNat b, KnownInt offs) => ShowUnit (Tet b offs) where + type ShowUnitType (Tet b offs) = + Text "tet{b=" :<>: ShowType b + :<>: Text ",offs=" :<>: ShowType offs :<>: Text "}" + showsUnitPrec d = showParen (d > 10) $ + showString "Tet " . shows (natVal (Proxy :: Proxy b)) + . showString " " + . shows (intVal (Proxy :: Proxy offs)) + prettysUnitPrec d = showParen (d > 10) $ + showString "tet " . shows (natVal (Proxy :: Proxy b)) + . showString " " + . shows (intVal (Proxy :: Proxy offs)) + + +type MidiPitch = Tet 12 (Neg 6900) + +data PitchException = OutOfMidiRange + +instance Exception PitchException + +instance Show PitchException where + show OutOfMidiRange = "A linear pitch is either negative or higher than 127,\ + \ and therefore cannot be converted to MIDI" + +safeDecomposePitchCents :: Real a => Tet b offs a -> Maybe (Word8, a) +safeDecomposePitchCents n = + if n >= 128 || n < 0 then + Nothing + else + Just (divMod' (unQuantity n) 1) + +decomposePitchCents :: Real a => Tet b offs a-> (Word8, a) +decomposePitchCents n = + if n >= 128 || n < 0 then + throw OutOfMidiRange + else + divMod' (unQuantity n) 1 + diff --git a/src/Data/Units/NonSI/Length.hs b/src/Data/Units/NonSI/Length.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonSI/Length.hs @@ -0,0 +1,7 @@ +module Data.Units.NonSI.Length + ( module Data.Units.UsCustomary.Length + , module Data.Units.Imperial.Length + ) where + +import Data.Units.UsCustomary.Length +import Data.Units.Imperial.Length diff --git a/src/Data/Units/NonSI/Temperature.hs b/src/Data/Units/NonSI/Temperature.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonSI/Temperature.hs @@ -0,0 +1,23 @@ +module Data.Units.NonSI.Temperature + ( Data.Units.SI.Derived.Celsius (..) + , Fahrenheit(..) + ) where + +import Data.Units.Core +import Data.Units.SI +import Data.Units.SI.Derived + + +-- | Thermodynamic temperature in Fahrenheit degrees. +$(mkUnitNoFactor "Fahrenheit" "°F" ''Temperature) + +instance Fractional a => ConversionFactor Fahrenheit a where + factor = 5 / 9 + {-# INLINE factor #-} + +instance Fractional a => ConvertibleUnit Fahrenheit a where + toBaseUnit (Fahrenheit x) = Kelvin ((x + 459.67) * 5 / 9) + {-# INLINE toBaseUnit #-} + + fromBaseUnit (Kelvin x) = Fahrenheit (x * 9 / 5 - 459.67) + {-# INLINE fromBaseUnit #-} diff --git a/src/Data/Units/NonSI/Time.hs b/src/Data/Units/NonSI/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonSI/Time.hs @@ -0,0 +1,30 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.NonSI.Time +-- Description : Non standard time units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Non standard time units. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.NonSI.Time + ( module Data.Units.NonSI.Time + ) where + +import Data.Units.Core +import Data.Units.SI + +-- | Time in minutes. +$(mkUnit "Minute" "min" ''Time 60) + +-- | Time in hours. +$(mkUnit "Hour" "hr" ''Time 3600) + + diff --git a/src/Data/Units/NonStd.hs b/src/Data/Units/NonStd.hs deleted file mode 100644 --- a/src/Data/Units/NonStd.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Data.Units.NonStd - ( module Data.Units.NonStd.Temperature - , module Data.Units.NonStd.Frequency - , module Data.Units.NonStd.Time - ) - where - -import Data.Units.NonStd.Temperature -import Data.Units.NonStd.Frequency -import Data.Units.NonStd.Time diff --git a/src/Data/Units/NonStd/Frequency.hs b/src/Data/Units/NonStd/Frequency.hs deleted file mode 100644 --- a/src/Data/Units/NonStd/Frequency.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Data.Units.NonStd.Frequency where - -import Control.Exception -import Data.Word -import Data.Fixed -import GHC.TypeLits -import Data.Proxy - -import Data.Units.Base -import Data.Units.SI.System - --- | Frequency in Tone Equal Temperament --- -newtype Tet (b :: Nat) (offs :: ZZ) a = Tet a - deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real - , RealFrac, RealFloat) - -instance (Floating a, KnownNat b, KnownInt offs) - => ConvertibleUnit (Tet b offs) a where - toBaseUnit (Tet a) = quantity $ 440 * 2 ** ((a + offs) / b) - where - b = fromIntegral $ natVal (Proxy :: Proxy b) - offs = fromIntegral (intVal (Proxy :: Proxy offs)) / 100 - fromBaseUnit a = Tet $ b * logBase 2 (unQuantity a/ 440) - offs - where - b = fromIntegral $ natVal (Proxy :: Proxy b) - offs = fromIntegral (intVal (Proxy :: Proxy offs)) / 100 - -instance IsUnit (Tet b offs) where - type DimOf (Tet b offs) = Time .^- 1 - -instance (KnownNat b, KnownInt offs) => ShowUnit (Tet b offs) where - type ShowUnitType (Tet b offs) = - Text "tet{b=" :<>: ShowType b - :<>: Text ",offs=" :<>: ShowType offs :<>: Text "}" - showsUnitPrec d = showParen (d > 10) $ - showString "Tet " . shows (natVal (Proxy :: Proxy b)) - . showString " " - . shows (intVal (Proxy :: Proxy offs)) - prettysUnitPrec d = showParen (d > 10) $ - showString "tet " . shows (natVal (Proxy :: Proxy b)) - . showString " " - . shows (intVal (Proxy :: Proxy offs)) - - -type MidiPitch = Tet 12 (Neg 6900) - -data PitchException = OutOfMidiRange - -instance Exception PitchException - -instance Show PitchException where - show OutOfMidiRange = "A linear pitch is either negative or higher than 127,\ - \ and therefore cannot be converted to MIDI" - -safeDecomposePitchCents :: Real a => Tet b offs a -> Maybe (Word8, a) -safeDecomposePitchCents n = - if n >= 128 || n < 0 then - Nothing - else - Just (divMod' (unQuantity n) 1) - -decomposePitchCents :: Real a => Tet b offs a-> (Word8, a) -decomposePitchCents n = - if n >= 128 || n < 0 then - throw OutOfMidiRange - else - divMod' (unQuantity n) 1 - diff --git a/src/Data/Units/NonStd/Temperature.hs b/src/Data/Units/NonStd/Temperature.hs deleted file mode 100644 --- a/src/Data/Units/NonStd/Temperature.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Data.Units.NonStd.Temperature - ( Data.Units.SI.Derived.Celsius (..) - , Fahrenheit(..) - ) where - -import Data.Units.Base -import Data.Units.SI -import Data.Units.SI.Derived - - --- | Thermodynamic temperature in Fahrenheit degrees --- -$(mkUnitNoFactor "Fahrenheit" "°F" ''Temperature) - -instance Fractional a => ConversionFactor Fahrenheit a where - factor = 5 / 9 - {-# INLINE factor #-} - -instance Fractional a => ConvertibleUnit Fahrenheit a where - toBaseUnit (Fahrenheit x) = Kelvin ((x + 459.67) * 5 / 9) - {-# INLINE toBaseUnit #-} - - fromBaseUnit (Kelvin x) = Fahrenheit (x * 9 / 5 - 459.67) - {-# INLINE fromBaseUnit #-} diff --git a/src/Data/Units/NonStd/Time.hs b/src/Data/Units/NonStd/Time.hs deleted file mode 100644 --- a/src/Data/Units/NonStd/Time.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.NonStd.Time --- Description : Non standard time units --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Non standard time units. --- --------------------------------------------------------------------------------- - - -module Data.Units.NonStd.Time - ( module Data.Units.NonStd.Time - ) where - -import Data.Units.Base.TH -import Data.Units.SI - --- | Time quantity in minutes --- -$(mkUnit "Minute" "min" ''Time 60) - --- | Time quantity in hours --- -$(mkUnit "Hour" "hr" ''Time 3600) - - diff --git a/src/Data/Units/SI/Derived/Angle.hs b/src/Data/Units/SI/Derived/Angle.hs --- a/src/Data/Units/SI/Derived/Angle.hs +++ b/src/Data/Units/SI/Derived/Angle.hs @@ -32,7 +32,7 @@ import Data.Fixed import Data.Coerce -import Data.Units.Base +import Data.Units.Core import Data.Units.SI.System import Data.Units.SI.Derived.NonAngle @@ -42,8 +42,7 @@ -- type Angle = NormalizeDim (Length ./. Length) --- | An angle in radians. --- +-- | Angle in radians. $(mkUnit "Radian" "rad" ''Angle 1) -- | The solid angle derived dimension in SI. Equal to @@ -52,8 +51,7 @@ -- type SolidAngle = NormalizeDim (Angle .^+ 2) --- | A solid angle in steradians. --- +-- | Solid angle in steradians. $(mkUnit "Steradian" "sr" ''SolidAngle 1) -- | Normalize an angle to the range ]-pi, pi] @@ -69,8 +67,7 @@ -- type LuminousFlux = NormalizeDim (LuminousIntensity .*. SolidAngle) --- | Luminous flux in lumens --- +-- | Luminous flux in lumens. $(mkUnit "Lumen" "lm" ''LuminousFlux 1) -- | Illuminance quantity. Equal to @@ -79,6 +76,5 @@ -- type Illuminance = NormalizeDim (LuminousFlux ./. Area) --- | Illuminance in lux --- +-- | Illuminance in lux. $(mkUnit "Lux" "lx" ''Illuminance 1) diff --git a/src/Data/Units/SI/Derived/NonAngle.hs b/src/Data/Units/SI/Derived/NonAngle.hs --- a/src/Data/Units/SI/Derived/NonAngle.hs +++ b/src/Data/Units/SI/Derived/NonAngle.hs @@ -71,7 +71,7 @@ ) where -import Data.Units.Base +import Data.Units.Core import Data.Units.SI.System type Area = Length .^+ 2 @@ -79,14 +79,12 @@ type Frequency = Time .^- 1 --- | Frequency in hertz --- +-- | Frequency in hertz. $(mkUnit "Hertz" "Hz" ''Frequency 1) type Radioactivity = Time .^- 1 --- | Radioactivity in becquerels --- +-- | Radioactivity in becquerels. $(mkUnit "Becquerel" "Bq" ''Radioactivity 1) -- | Speed quantity. Equal to @@ -103,8 +101,7 @@ -- type Force = NormalizeDim (Mass .*. Acceleration) --- | Force in newtons --- +-- | Force in newtons. $(mkUnit "Newton" "N" ''Force 1) -- | Pressure quantity. Equal to @@ -114,8 +111,7 @@ type Pressure = NormalizeDim (Force ./. (Length .^+ 2)) type Stress = Pressure --- | Pressure in pascals --- +-- | Pressure in pascals. $(mkUnit "Pascal" "Pa" ''Pressure 1) -- | Energy quantity. Equal to @@ -126,8 +122,7 @@ type Work = Energy type Heat = Energy --- | Energy in joules --- +-- | Energy in joules. $(mkUnit "Joule" "J" ''Energy 1) -- | Power quantity. Equal to @@ -139,8 +134,7 @@ type Power = NormalizeDim (Energy ./. Time) type RadiantFlux = Power --- | Power in watts --- +-- | Power in watts. $(mkUnit "Watt" "W" ''Power 1) -- | Electric charge quantity. Equal to @@ -150,7 +144,7 @@ type ElectricCharge = NormalizeDim (Time .*. Current) type QuantityOfElectricity = ElectricCharge - +-- | Electric charge in coulombs. $(mkUnit "Coulomb" "C" ''ElectricCharge 1) -- | Electric voltage quantity. Equal to @@ -161,6 +155,7 @@ type ElectricPotential = Voltage type ElectromotiveForce = Voltage +-- | Electric potential (voltage) in volts. $(mkUnit "Volt" "V" ''Voltage 1) -- | Electric capacitance quantity. Equal to @@ -169,6 +164,7 @@ -- type Capacitance = NormalizeDim (ElectricCharge ./. Voltage) +-- | Electric capacitance in farads. $(mkUnit "Farad" "F" ''Capacitance 1) -- | Electric resistance quantity. Equal to @@ -179,6 +175,7 @@ type Impedance = Resistance type Reactance = Resistance +-- | Electric resistance in ohms. $(mkUnit "Ohm" "Ω" ''Resistance 1) -- | Electric conductance quantity. Equal to @@ -187,6 +184,7 @@ -- type Conductance = NormalizeDim (Current ./. Voltage) +-- | Electric conductance in siemens. $(mkUnit "Siemens" "S" ''Conductance 1) -- | Magnetic flux quantity. Equal to @@ -195,6 +193,7 @@ -- type MagneticFlux = NormalizeDim (Voltage .*. Time) +-- | Magnetic flux in webers. $(mkUnit "Weber" "Wb" ''MagneticFlux 1) -- | Magnetic induction quantity. Equal to @@ -204,6 +203,7 @@ type MagneticInduction = NormalizeDim (MagneticFlux ./. (Length .^+ 2)) type MagneticFluxDensity = MagneticInduction +-- | Magnetic induction (magnetic flux density) in teslas. $(mkUnit "Tesla" "T" ''MagneticInduction 1) -- | Inductance quantity. Equal to @@ -212,10 +212,10 @@ type Inductance = NormalizeDim (MagneticFlux ./. Current) +-- | Inductance in henrys. $(mkUnit "Henry" "H" ''Inductance 1) --- | Thermodynamic temperature in Celsius degrees --- +-- | Thermodynamic temperature in Celsius degrees. $(mkUnitNoFactor "Celsius" "°C" ''Temperature) instance Fractional a => ConversionFactor Celsius a where @@ -236,12 +236,10 @@ type AbsorbedDose = NormalizeDim (Energy ./. Mass) type EquivalentDose = AbsorbedDose --- | Absorbed dose in grays --- +-- | Absorbed dose in grays. $(mkUnit "Gray" "Gy" ''AbsorbedDose 1) --- | Dose equivalent in sieverts --- +-- | Dose equivalent in sieverts. $(mkUnit "Sievert" "Sv" ''EquivalentDose 1) -- | Catalytic activity quantity. Equal to @@ -250,6 +248,5 @@ -- type CatalyticActivity = NormalizeDim (AmountOfSubstance ./. Time) --- | Catalytic activity in katal --- +-- | Catalytic activity in katals. $(mkUnit "Katal" "kat" ''CatalyticActivity 1) diff --git a/src/Data/Units/SI/NonSI.hs b/src/Data/Units/SI/NonSI.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/NonSI.hs @@ -0,0 +1,30 @@ + + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.NonSI +-- Description : Non standard units in the SI dimensions +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-------------------------------------------------------------------------------- + +module Data.Units.SI.NonSI + ( module Data.Units.NonSI + , module Data.Units.SI.NonSI.Angle + , module Data.Units.SI.Derived + , module Data.Units.SI.Prefixes + , module Data.Units.SI.System + ) +where + +import Data.Units.NonSI +import Data.Units.SI.NonSI.Angle +import Data.Units.SI.Derived +import Data.Units.SI.Prefixes +import Data.Units.SI.System + diff --git a/src/Data/Units/SI/NonSI/Angle.hs b/src/Data/Units/SI/NonSI/Angle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/NonSI/Angle.hs @@ -0,0 +1,47 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.NonSI.Angle +-- Description : Dimensionless non standard angle units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Dimensionless non standard angle units. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.SI.NonSI.Angle where + +import Data.Units.Core + +-- | Angle in degrees. +$(mkUnitNoFactor "Degree" "°" ''NoDim) + +-- | Angle in complete turns (also called cycles or revolutions). +$(mkUnitNoFactor "Turn" "tr" ''NoDim) + +-- | Angle in gradians. +$(mkUnitNoFactor "Gradian" "grad" ''NoDim) + +instance Floating a => ConvertibleUnit Degree a + +instance Floating a => ConversionFactor Degree a where + factor = pi / 180 + {-# INLINE factor #-} + +instance Floating a => ConvertibleUnit Turn a + +instance Floating a => ConversionFactor Turn a where + factor = 2 * pi + {-# INLINE factor #-} + +instance Floating a => ConvertibleUnit Gradian a + +instance Floating a => ConversionFactor Gradian a where + factor = pi / 200 + {-# INLINE factor #-} + diff --git a/src/Data/Units/SI/NonStd.hs b/src/Data/Units/SI/NonStd.hs deleted file mode 100644 --- a/src/Data/Units/SI/NonStd.hs +++ /dev/null @@ -1,24 +0,0 @@ - - --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.SI.NonStd --- Description : Non standard units in the SI dimensions --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : stable --- Portability : non-portable (GHC extensions) --- --------------------------------------------------------------------------------- - -module Data.Units.SI.NonStd - ( module Data.Units.NonStd - , module Data.Units.SI.NonStd.Angle - ) -where - -import Data.Units.NonStd -import Data.Units.SI.NonStd.Angle - diff --git a/src/Data/Units/SI/NonStd/Angle.hs b/src/Data/Units/SI/NonStd/Angle.hs deleted file mode 100644 --- a/src/Data/Units/SI/NonStd/Angle.hs +++ /dev/null @@ -1,54 +0,0 @@ --------------------------------------------------------------------------------- --- | --- --- Module : Data.Units.SI.NonStd.Angle --- Description : Dimensionless non standard angle units --- Copyright : (c) Alice Rixte 2025 --- License : BSD 3 --- Maintainer : alice.rixte@u-bordeaux.fr --- Stability : unstable --- Portability : non-portable (GHC extensions) --- --- Dimensionless non standard angle units. --- --------------------------------------------------------------------------------- - - -module Data.Units.SI.NonStd.Angle where - -import Data.Units.Base - --- | Angle in degrees. --- -$(mkUnitNoFactor "Degree" "°" ''NoDim) - --- | Angle in complete turns (also called cycles or revolutions) --- --- See https://en.wikipedia.org/wiki/Turn_(angle) --- -$(mkUnitNoFactor "Turn" "tr" ''NoDim) - --- | Angle in gradians --- --- See https://en.wikipedia.org/wiki/Gradian --- -$(mkUnitNoFactor "Gradian" "grad" ''NoDim) - -instance Floating a => ConvertibleUnit Degree a - -instance Floating a => ConversionFactor Degree a where - factor = pi / 180 - {-# INLINE factor #-} - -instance Floating a => ConvertibleUnit Turn a - -instance Floating a => ConversionFactor Turn a where - factor = 2 * pi - {-# INLINE factor #-} - -instance Floating a => ConvertibleUnit Gradian a - -instance Floating a => ConversionFactor Gradian a where - factor = pi / 200 - {-# INLINE factor #-} - diff --git a/src/Data/Units/SI/Prefixes.hs b/src/Data/Units/SI/Prefixes.hs --- a/src/Data/Units/SI/Prefixes.hs +++ b/src/Data/Units/SI/Prefixes.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | @@ -46,7 +43,7 @@ , Quecca (..) ) where -import Data.Units.Base +import Data.Units.Core -- | SI prefix for 10⁻³⁰ -- diff --git a/src/Data/Units/SI/System.hs b/src/Data/Units/SI/System.hs --- a/src/Data/Units/SI/System.hs +++ b/src/Data/Units/SI/System.hs @@ -32,7 +32,7 @@ ) where import Data.Coerce -import Data.Units.Base +import Data.Units.Core import Data.Units.SI.Prefixes -- +--------------------------------------+-----------------+ diff --git a/src/Data/Units/UsCustomary.hs b/src/Data/Units/UsCustomary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/UsCustomary.hs @@ -0,0 +1,5 @@ +module Data.Units.UsCustomary + ( module Data.Units.UsCustomary.Length + ) where + +import Data.Units.UsCustomary.Length diff --git a/src/Data/Units/UsCustomary/Area.hs b/src/Data/Units/UsCustomary/Area.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/UsCustomary/Area.hs @@ -0,0 +1,5 @@ +module Data.Units.UsCustomary.Area + ( Acre(..) + ) where + +import Data.Units.Imperial.Area (Acre(..)) diff --git a/src/Data/Units/UsCustomary/Length.hs b/src/Data/Units/UsCustomary/Length.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/UsCustomary/Length.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Units.UsCustomary.Length +-- Reexport the imperial units that are also used in US customary within the US +-- customary modules + ( Mil + , Point + , Pica + , Data.Units.Imperial.Length.Twip + , Data.Units.Imperial.Length.Inch + , Data.Units.Imperial.Length.Foot + , Data.Units.Imperial.Length.Yard + , Data.Units.Imperial.Length.Mile + , Data.Units.Imperial.Length.League + , Data.Units.Imperial.Length.Fathom + , Data.Units.Imperial.Length.Cable + , Data.Units.Imperial.Length.NauticalMile + ) where + +import Data.Units.Core +import Data.Units.SI +import Data.Units.Imperial.Length + + +-- | Length in mils. +$(mkUnit "Mil" "mil" ''Length $ 1200 / 3937 / 12 / 1000) + +-- | Length in points. +$(mkUnit "Point" "p" ''Length $ 1200 / 3937 / 12 / 72) + +-- | Length in picas. +$(mkUnit "Pica" "P" ''Length $ 1200 / 3937 / 12 / 72 * 12) diff --git a/test/Data/Epsilon.hs b/test/Data/Epsilon.hs deleted file mode 100644 --- a/test/Data/Epsilon.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Data.Epsilon - ( MkEpsilon (..) - , aboutEqual - , isApproxId - , module Linear.Epsilon - ) where - -import Foreign.C.Types (CFloat, CDouble) -import Linear.Epsilon - --- | Provides a near-zero quantity -class MkEpsilon a where - -- | A near-zero quantity - epsilon :: a - --- | ε = 1e-6 -instance MkEpsilon Float where - epsilon = 1e-6 - --- | ε = 1e-12 -instance MkEpsilon Double where - epsilon = 1e-12 - --- | ε = 1e-6 -instance MkEpsilon CFloat where - epsilon = 1e-6 - --- | ε = 1e-12 -instance MkEpsilon CDouble where - epsilon = 1e-12 - - --- | Equality up to epsilon --- --- @'aboutEqual' a b@ is true iff @|a - b| < ε@ -aboutEqual :: Epsilon a => a -> a -> Bool -aboutEqual a b = nearZero (a - b) - -isApproxId :: Epsilon a => (a -> a) -> a -> Bool -isApproxId f a = aboutEqual (f a) a diff --git a/test/Data/Type/IntSpec.hs b/test/Data/Type/IntSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Type/IntSpec.hs @@ -0,0 +1,13 @@ +module Data.Type.IntSpec where + +import Test.Hspec +import Test.QuickCheck + +import Data.Type.Int + +spec :: Spec +spec = do + describe "Data.Type.Int" $ do + it "Singleton converts properly" $ do + property $ \ (i :: Integer) -> + withSomeSZZ i fromSZZ == i diff --git a/test/Data/Units/Base/ArithmeticProp.hs b/test/Data/Units/Base/ArithmeticProp.hs deleted file mode 100644 --- a/test/Data/Units/Base/ArithmeticProp.hs +++ /dev/null @@ -1,454 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} - -module Data.Units.Base.ArithmeticProp where - -import Data.Coerce - -import Test.QuickCheck -import Test.Hspec - -import Data.Epsilon - -import Data.Units - -import Data.Units.Base.ConvertProp - - -------------------------- Num and fractional instances ------------------------- - -addNumProp :: forall u a. - ( IsUnit u, Floating (u a) - , Show a, Epsilon a, Floating a, Eq a, Arbitrary a) => Property -addNumProp = property (\ (a :: a) (b :: a) -> - a + b + pi == - coerce (coerce a + coerce b + pi :: u a) - ) - -divNumProp :: forall u a. - ( IsUnit u, Fractional (u a) - , Show a, Epsilon a, Fractional a, Eq a, Arbitrary a) - => Property -divNumProp = property (\ (a :: a) (b :: a) -> b == 0 || - a / b == - coerce (coerce a / coerce b :: u a)) - -floatingSpec :: forall u a. - ( IsUnit u, Floating (u a), ShowUnit u - , Show a, Epsilon a, Floating a, Eq a, Arbitrary a - ) - => Spec -floatingSpec = it ("Floating instance for " ++ showUnit @u ) $ - addNumProp @u @a .&&. divNumProp @u @a - - --------------------------- Arithmetic same dimension --------------------------- - - - -addRight :: forall u v a. - ( FromTo' v u a - ) - => a -> a -> a -addRight u v = coerce $ (coerce u :: u a) .+~ (coerce v :: v a) - -addRightProp :: forall u v a. - ( FromTo' v u a - , DimEq u v - , Show a, Epsilon a, Arbitrary a - ) - => Property -addRightProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) + b :: a) - (addRight @u @v a b)) - -addRightSpec :: forall u v a. - ( FromTo' v u a - , DimEq u v - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) => Spec -addRightSpec = it (showUnit @u ++ " .+~ " ++ showUnit @v) - $ addRightProp @u @v @a - -addLeft :: forall u v a. - ( FromTo' u v a - ) - => a -> a -> a -addLeft u v = coerce $ (coerce u :: u a) ~+. (coerce v :: v a) - -addLeftProp :: forall u v a. - ( FromTo' u v a - , DimEq u v - , Show a, Epsilon a, Arbitrary a - ) - => Property -addLeftProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) + b :: a) - (addLeft @u @v a b)) - -addLeftSpec :: forall u v a. - ( FromTo' u v a - , DimEq u v - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) => Spec -addLeftSpec = it (showUnit @u ++ " ~+. " ++ showUnit @v) - $ addLeftProp @u @v @a - - -addSame :: forall u v a. - FromTo' u v a - => a -> a -> a -addSame u v = coerce $ (coerce u :: u a) ~+~ (coerce v :: v a) - -addSameProp :: forall u v a. - ( FromTo' u v a - , DimEq u v - , Show a, Epsilon a, Arbitrary a - ) - => Property -addSameProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) + b :: a) - (addSame @u @v a b)) - -addSameSpec :: forall u v a. - ( FromTo' u v a - , DimEq u v - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) => Spec -addSameSpec = it (showUnit @u ++ " ~+~ " ++ showUnit @v) - $ addSameProp @u @v @a - ---------------------------------- Subtraction ---------------------------------- - -subRight :: forall u v a. - ( FromTo' v u a - ) - => a -> a -> a -subRight u v = coerce $ (coerce u :: u a) .-~ (coerce v :: v a) - -subRightProp :: forall u v a. - ( FromTo' v u a - , DimEq u v - , Show a, Epsilon a, Arbitrary a - ) - => Property -subRightProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) - b :: a) - (subRight @u @v a b)) - -subRightSpec :: forall u v a. - ( FromTo' v u a - , DimEq u v - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) => Spec -subRightSpec = it (showUnit @u ++ " .-~ " ++ showUnit @v) - $ subRightProp @u @v @a - -subLeft :: forall u v a. - ( FromTo' u v a - ) - => a -> a -> a -subLeft u v = coerce $ (coerce u :: u a) ~-. (coerce v :: v a) - -subLeftProp :: forall u v a. - ( FromTo' u v a - , DimEq u v - , Show a, Epsilon a, Arbitrary a - ) - => Property -subLeftProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) - b :: a) - (subLeft @u @v a b)) - -subLeftSpec :: forall u v a. - ( FromTo' u v a - , DimEq u v - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) => Spec -subLeftSpec = it (showUnit @u ++ " ~-. " ++ showUnit @v) - $ subLeftProp @u @v @a - - -subSame :: forall u v a. - FromTo' u v a - => a -> a -> a -subSame u v = coerce $ (coerce u :: u a) ~-~ (coerce v :: v a) - -subSameProp :: forall u v a. - ( FromTo' u v a - , DimEq u v - , Show a, Epsilon a, Arbitrary a - ) - => Property -subSameProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) - b :: a) - (subSame @u @v a b)) - -subSameSpec :: forall u v a. - ( FromTo' u v a - , DimEq u v - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) => Spec -subSameSpec = it (showUnit @u ++ " ~-~ " ++ showUnit @v) - $ subSameProp @u @v @a - - --------------------------------- Multiplication -------------------------------- - -mulSame :: forall u v a u2 . - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - ) - => a -> a -> a -mulSame u v = coerce $ (coerce u :: u a) ~*~ (coerce v :: v a) - -mulSameProp :: forall u v a u2 . - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - , Show a, Epsilon a, Arbitrary a - ) - => Property -mulSameProp = property (\(a :: a) (b :: a) -> - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) * b :: a) - (mulSame @u @v a b)) - -mulSameSpec :: forall u v a u2 . - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Arbitrary a - ) - => Spec -mulSameSpec = it (showUnit @u ++ " ~*~ " ++ showUnit @v) - $ mulSameProp @u @v @a - -divSame :: forall u v a u2 . - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - ) - => a -> a -> a -divSame u v = coerce $ (coerce u :: u a) ~/~ (coerce v :: v a) - -divSameProp :: forall u v a u2 . - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - , Show a, Epsilon a, Eq a, Arbitrary a - ) - => Property -divSameProp = property (\(a :: a) (b :: a) -> b == 0 || - aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) / b :: a) - (divSame @u @v a b)) - -divSameSpec :: forall u v a u2 . - ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 - , DimEq u v - , ConversionFactor u a, ConversionFactor v a - , ShowUnit u, ShowUnit v - , Show a, Epsilon a, Eq a, Arbitrary a - ) - => Spec -divSameSpec = it (showUnit @u ++ " ~/~ " ++ showUnit @v) - $ divSameProp @u @v @a - ------------------- Arithmetic with two different dimensions ------------------- - --- mulRight :: forall u v a u2. --- ( u2 ~ BaseUnitOf' (u .^+ 2) , IsUnit u2 --- , DimEq u v --- , FromTo' v u a --- ) --- => a -> a -> a --- mulRight u v = coerce $ (coerce u :: u a) .*~ (coerce v :: v a) - --- mulRightProp :: forall u v a u2. --- ( u2 ~ BaseUnitOf' (u .^+ 2) , IsUnit u2 --- , DimEq u v --- , FromTo' v u a --- , Show a, Epsilon a, Arbitrary a --- ) --- => Property --- mulRightProp = property (\(a :: a) (b :: a) -> --- aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) * b :: a) --- (mulRight @u @v a b)) - --- mulRightSpec :: forall u v a u2. --- ( u2 ~ BaseUnitOf' (u .^+ 2) , IsUnit u2 --- , DimEq u v --- , FromTo' v u a --- , ShowUnit u, ShowUnit v --- , Show a, Epsilon a, Arbitrary a --- ) => Spec --- mulRightSpec = it (showUnit @u ++ " .*~ " ++ showUnit @v) --- $ mulRightProp @u @v @a - --- mulLeft :: forall u v a v2. --- ( v2 ~ BaseUnitOf' (v .^+ 2), IsUnit v2 --- , DimEq v u --- , FromTo' u v a --- ) --- => a -> a -> a --- mulLeft u v = coerce $ (coerce u :: u a) ~*. (coerce v :: v a) - --- mulLeftProp :: forall u v a v2. --- ( v2 ~ BaseUnitOf' (v .^+ 2), IsUnit v2 --- , DimEq v u --- , FromTo' u v a --- , Show a, Epsilon a, Arbitrary a --- ) --- => Property --- mulLeftProp = property (\(a :: a) (b :: a) -> --- aboutEqual (coerce (fromTo' (coerce a :: u a) :: v a) * b :: a) --- (mulLeft @u @v a b)) - --- mulLeftSpec :: forall u v a v2. --- ( v2 ~ BaseUnitOf' (v .^+ 2), IsUnit v2 --- , DimEq v u --- , FromTo' u v a --- , ShowUnit u, ShowUnit v --- , Show a, Epsilon a, Arbitrary a --- ) => Spec --- mulLeftSpec = it (showUnit @u ++ " ~*. " ++ showUnit @v) --- $ mulLeftProp @u @v @a - - -mulDiffDim :: forall u v a. - ( ConversionFactor u a, ConversionFactor v a) - => a -> a -> a -mulDiffDim u v = coerce $ (coerce u :: u a) .*. (coerce v :: v a) - -mulDiffDimProp :: forall u v a. - ( ConversionFactor u a, ConversionFactor v a - , ConversionFactor (u .*. v) a - , Arbitrary a, Show a, Epsilon a - ) - => Property -mulDiffDimProp = - property (\a b -> aboutEqual (a * b) (mulDiffDim @u @v @a a b) ) - .&&. toFromProp @(u .*. v) @a - -mulDiffDimSpec :: forall u v a. - ( ConversionFactor u a, ConversionFactor v a - , ConversionFactor (u .*. v) a - , Arbitrary a, Show a, Epsilon a - , ShowUnit u, ShowUnit v - ) - => Spec -mulDiffDimSpec = it (showUnit @u ++ " .*. " ++ showUnit @v) - $ mulDiffDimProp @u @v @a - -divDiffDim :: forall u v a. - ( IsUnit u, IsUnit v, IsUnit (u ./. v) - , Fractional a - ) - => a -> a -> a -divDiffDim u v = coerce $ (coerce u :: u a) ./. (coerce v :: v a) - -divDiffDimProp :: forall u v a. - ( IsUnit u, IsUnit v, IsUnit (u ./. v) - , ConversionFactor (u ./. v) a - , IsUnit (u ./. v) - , Arbitrary a, Show a, Epsilon a, Eq a, Fractional a - ) - => Property -divDiffDimProp = - property (\a b -> b == 0 || aboutEqual (a / b) (divDiffDim @u @v @a a b) ) - .&&. toFromProp @(u ./. v) @a - -divDiffDimSpec :: forall u v a. - (IsUnit u, IsUnit v, IsUnit (u ./. v) - , ConversionFactor (u ./. v) a - , IsUnit (u ./. v) - , Arbitrary a, Show a, Epsilon a, Eq a, Fractional a - , ShowUnit u, ShowUnit v - ) - => Spec -divDiffDimSpec = it (showUnit @u ++ " ./. " ++ showUnit @v) - $ divDiffDimProp @u @v @a - --------------------------------- Exponentiation -------------------------------- - -exp2 :: forall u a. - ConversionFactor u a - => a -> a -exp2 u = coerce $ (coerce u :: u a) .^. pos2 - -expm1 :: forall u a. - ConversionFactor u a - => a -> a -expm1 u = coerce $ (coerce u :: u a) .^. neg1 - -exp2Prop :: forall u a. - ( ConversionFactor u a - , Arbitrary a, Show a, Epsilon a - ) - => Property -exp2Prop = - property (\a -> aboutEqual (a * a) (exp2 @u @a a)) - -expm1Prop :: forall u a. - ( ConversionFactor u a - , Arbitrary a, Show a, Eq a, Epsilon a - ) - => Property -expm1Prop = - property (\a -> a == 0 || aboutEqual (1 / a) (expm1 @u @a a)) - -expSpec :: forall u a. - ( ConversionFactor u a - , ShowUnit u - , Arbitrary a, Show a, Eq a, Epsilon a - ) - => Spec -expSpec = it (showUnit @u ++ " .^+ 2 ," ++ showUnit @u ++ " .^- 1") $ - exp2Prop @u @a .&&. expm1Prop @u @a - -exp2Conv :: forall u a. - ConversionFactor u a - => a -> a -exp2Conv u = coerce $ (coerce u :: u a) ~^~ pos2 - -expm1Conv :: forall u a. - ConversionFactor u a - => a -> a -expm1Conv u = coerce $ (coerce u :: u a) ~^~ neg1 - -exp2ConvProp :: forall u a. - ( ConversionFactor u a - , Arbitrary a, Show a, Epsilon a - ) - => Property -exp2ConvProp = - property (\a -> aboutEqual - (coerce (toBaseUnit' (coerce a :: u a)) ^^ (2 :: Int)) (exp2Conv @u @a a)) - -expm1ConvProp :: forall u a. - ( ConversionFactor u a - , Arbitrary a, Show a, Eq a, Epsilon a - ) - => Property -expm1ConvProp = - property (\a -> a == 0 || - aboutEqual (coerce (toBaseUnit' (coerce a :: u a)) ^^ (-1 :: Int)) (expm1Conv @u @a a)) - - -expConvSpec :: forall u a. - ( ConversionFactor u a - , ShowUnit u - , Arbitrary a, Show a, Eq a, Epsilon a - ) - => Spec -expConvSpec = it (showUnit @u ++ "~^~ pos2 ," ++ showUnit @u ++ "~^~ neg1") $ - exp2ConvProp @u @a .&&. expm1ConvProp @u @a - diff --git a/test/Data/Units/Base/ConvertProp.hs b/test/Data/Units/Base/ConvertProp.hs deleted file mode 100644 --- a/test/Data/Units/Base/ConvertProp.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --- {-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE TypeApplications #-} - -module Data.Units.Base.ConvertProp where - - -import Data.Coerce - -import Data.Epsilon - -import Test.QuickCheck -import Test.Hspec - -import Data.Units - ------------------------------------- toFrom ------------------------------------ - -toFrom :: forall u a. - (ConvertibleUnit u a) - => a -> a -toFrom a = coerce - (toBaseUnit (fromBaseUnit @u (coerce a :: BaseUnitOf u a) :: u a) - :: BaseUnitOf u a) - -toFromProp :: forall u a. - ( ConvertibleUnit u a - , Arbitrary a, Show a, Epsilon a - ) - => Property -toFromProp = property (isApproxId (toFrom @u @a)) - -toFromSpec :: forall u a. - ( ShowUnit u - , ConvertibleUnit u a - , Arbitrary a, Show a, Epsilon a - ) - => Spec -toFromSpec = - it ("toFrom " ++ showUnit @u) (toFromProp @u @a) - - ------------------------------------- fromTo ------------------------------------ - -fromToRoundtrip :: forall u v a. - ( IsUnit u, IsUnit v - , FromTo u v a, FromTo v u a - ) - => a -> a -fromToRoundtrip a = coerce (fromTo (fromTo (coerce a :: u a) :: v a) :: u a) - -fromToProp :: forall u v a. - ( ShowUnit u, ShowUnit v - , FromTo u v a, FromTo v u a - , Arbitrary a, Show a, Epsilon a - ) - => Property -fromToProp = property $ isApproxId (fromToRoundtrip @u @v @a) - -fromToSpec :: forall u v a. - ( ShowUnit u, ShowUnit v - , FromTo u v a, FromTo v u a - , Arbitrary a, Show a, Epsilon a - ) - => Spec -fromToSpec = - it ("From `" ++ showUnit @u ++ "` to `" ++ showUnit @v ++ "`") - $ fromToProp @u @v @a - -fromToAssert :: forall a u v. - ( Show (u a), Show (v a) - , FromTo u v a - , FromTo v u a - , Arbitrary a, ShowUnit u, ShowUnit v, Show a, Epsilon a - ) - => u a -> v a -> Spec -fromToAssert u v = - it ("`" ++ prettyQuantity u ++ "` should be `" ++ prettyQuantity v ++ "`") $ - aboutEqual (coerce (fromTo u :: v a) :: a) (coerce v :: a) - && aboutEqual (coerce (fromTo v :: u a) :: a) (coerce u :: a) - `shouldBe` True - - ------------------------------------ fromTo' ------------------------------------ - -fromToRoundtrip' :: forall u v a. - ( FromTo' u v a, FromTo' v u a) - => a -> a -fromToRoundtrip' a = coerce (fromTo' (fromTo' (coerce a :: u a) :: v a) :: u a) - -fromToProp' :: forall u v a. - ( ShowUnit u, ShowUnit v - , FromTo' u v a, FromTo' v u a - , Arbitrary a, Show a, Epsilon a - ) - => Property -fromToProp' = property $ isApproxId (fromToRoundtrip' @u @v @a) - - -fromToSpec' :: forall u v a. - ( ShowUnit u, ShowUnit v - , FromTo' u v a, FromTo' v u a - , Arbitrary a, Show a, Epsilon a - ) - => Spec -fromToSpec' = - it ("From' `" ++ showUnit @u ++ "` to' `" ++ showUnit @v ++ "`") - $ fromToProp' @u @v @a diff --git a/test/Data/Units/BaseProp.hs b/test/Data/Units/BaseProp.hs deleted file mode 100644 --- a/test/Data/Units/BaseProp.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} - -module Data.Units.BaseProp - ( module Data.Units.Base.ArithmeticProp - , module Data.Units.Base.ConvertProp - , module Data.Units.BaseProp - ) - where - -import Data.Units.Base.ArithmeticProp -import Data.Units.Base.ConvertProp - -import Test.QuickCheck -import Test.Hspec - -import Data.Epsilon - -import Data.Units - -sameDimSpec :: forall u a. - (IsUnit u, Floating (u a), ShowUnit u - , Show a, Epsilon a, Floating a, Eq a, Arbitrary a - , FromTo' u u a - , DimEq u u - , IsUnit (NormalizeUnitL (u .^+ 2)) - , IsUnit (BaseUnitOf u) - ) - => Spec -sameDimSpec = describe ("Unit " ++ showUnit @u) $ do - floatingSpec @u @a - addLeftSpec @u @u @a - addRightSpec @u @u @a - addSameSpec @u @u @a - subLeftSpec @u @u @a - subRightSpec @u @u @a - subSameSpec @u @u @a - mulSameSpec @u @u @a - -- mulLeftSpec @u @u @a - -- mulRightSpec @u @u @a - divSameSpec @u @u @a - expSpec @u @a - expConvSpec @u @a - diff --git a/test/Data/Units/Core/ArithmeticProp.hs b/test/Data/Units/Core/ArithmeticProp.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/Core/ArithmeticProp.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Units.Core.ArithmeticProp where + +import Data.Coerce + +import Test.QuickCheck +import Test.Hspec + +import Data.AEq + +import Data.Units + +import Data.Units.Core.ConvertProp + + +------------------------- Num and fractional instances ------------------------- + +addNumProp :: forall u a. + ( IsUnit u, Floating (u a) + , Show a, AEq a, Floating a, Eq a, Arbitrary a) => Property +addNumProp = property (\ (a :: a) (b :: a) -> + a + b + pi == + coerce (coerce a + coerce b + pi :: u a) + ) + +divNumProp :: forall u a. + ( IsUnit u, Fractional (u a) + , Show a, AEq a, Fractional a, Eq a, Arbitrary a) + => Property +divNumProp = property (\ (a :: a) (b :: a) -> b == 0 || + a / b == + coerce (coerce a / coerce b :: u a)) + +floatingSpec :: forall u a. + ( IsUnit u, Floating (u a), ShowUnit u + , Show a, AEq a, Floating a, Eq a, Arbitrary a + ) + => Spec +floatingSpec = it ("Floating instance for " ++ showUnit @u ) $ + addNumProp @u @a .&&. divNumProp @u @a + + +-------------------------- Arithmetic same dimension --------------------------- + + + +addRight :: forall u v a. + ( FromTo' v u a + ) + => a -> a -> a +addRight u v = coerce $ (coerce u :: u a) .+~ (coerce v :: v a) + +addRightProp :: forall u v a. + ( FromTo' v u a + , DimEq u v + , Show a, AEq a, Arbitrary a + ) + => Property +addRightProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) + b :: a) + ~== addRight @u @v a b + ) + +addRightSpec :: forall u v a. + ( FromTo' v u a + , DimEq u v + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) => Spec +addRightSpec = it (showUnit @u ++ " .+~ " ++ showUnit @v) + $ addRightProp @u @v @a + +addLeft :: forall u v a. + ( FromTo' u v a + ) + => a -> a -> a +addLeft u v = coerce $ (coerce u :: u a) ~+. (coerce v :: v a) + +addLeftProp :: forall u v a. + ( FromTo' u v a + , DimEq u v + , Show a, AEq a, Arbitrary a + ) + => Property +addLeftProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) + b :: a) + ~== addLeft @u @v a b + ) + +addLeftSpec :: forall u v a. + ( FromTo' u v a + , DimEq u v + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) => Spec +addLeftSpec = it (showUnit @u ++ " ~+. " ++ showUnit @v) + $ addLeftProp @u @v @a + + +addSame :: forall u v a. + FromTo' u v a + => a -> a -> a +addSame u v = coerce $ (coerce u :: u a) ~+~ (coerce v :: v a) + +addSameProp :: forall u v a. + ( FromTo' u v a + , DimEq u v + , Show a, AEq a, Arbitrary a + ) + => Property +addSameProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) + b :: a) + ~== addSame @u @v a b) + +addSameSpec :: forall u v a. + ( FromTo' u v a + , DimEq u v + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) => Spec +addSameSpec = it (showUnit @u ++ " ~+~ " ++ showUnit @v) + $ addSameProp @u @v @a + +--------------------------------- Subtraction ---------------------------------- + +subRight :: forall u v a. + ( FromTo' v u a + ) + => a -> a -> a +subRight u v = coerce $ (coerce u :: u a) .-~ (coerce v :: v a) + +subRightProp :: forall u v a. + ( FromTo' v u a + , DimEq u v + , Show a, AEq a, Arbitrary a + ) + => Property +subRightProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) - b :: a) + ~== subRight @u @v a b + ) + +subRightSpec :: forall u v a. + ( FromTo' v u a + , DimEq u v + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) => Spec +subRightSpec = it (showUnit @u ++ " .-~ " ++ showUnit @v) + $ subRightProp @u @v @a + +subLeft :: forall u v a. + ( FromTo' u v a + ) + => a -> a -> a +subLeft u v = coerce $ (coerce u :: u a) ~-. (coerce v :: v a) + +subLeftProp :: forall u v a. + ( FromTo' u v a + , DimEq u v + , Show a, AEq a, Arbitrary a + ) + => Property +subLeftProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) - b :: a) + ~== subLeft @u @v a b + ) + +subLeftSpec :: forall u v a. + ( FromTo' u v a + , DimEq u v + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) => Spec +subLeftSpec = it (showUnit @u ++ " ~-. " ++ showUnit @v) + $ subLeftProp @u @v @a + + +subSame :: forall u v a. + FromTo' u v a + => a -> a -> a +subSame u v = coerce $ (coerce u :: u a) ~-~ (coerce v :: v a) + +subSameProp :: forall u v a. + ( FromTo' u v a + , DimEq u v + , Show a, AEq a, Arbitrary a + ) + => Property +subSameProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) - b :: a) + ~== subSame @u @v a b + ) + +subSameSpec :: forall u v a. + ( FromTo' u v a + , DimEq u v + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) => Spec +subSameSpec = it (showUnit @u ++ " ~-~ " ++ showUnit @v) + $ subSameProp @u @v @a + + +-------------------------------- Multiplication -------------------------------- + +mulSame :: forall u v a u2 . + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + ) + => a -> a -> a +mulSame u v = coerce $ (coerce u :: u a) ~*~ (coerce v :: v a) + +mulSameProp :: forall u v a u2 . + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + , Show a, AEq a, Arbitrary a + ) + => Property +mulSameProp = property (\(a :: a) (b :: a) -> + (coerce (fromTo' (coerce a :: u a) :: v a) * b :: a) + ~== mulSame @u @v a b + ) + +mulSameSpec :: forall u v a u2 . + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + , ShowUnit u, ShowUnit v + , Show a, AEq a, Arbitrary a + ) + => Spec +mulSameSpec = it (showUnit @u ++ " ~*~ " ++ showUnit @v) + $ mulSameProp @u @v @a + +divSame :: forall u v a u2 . + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + ) + => a -> a -> a +divSame u v = coerce $ (coerce u :: u a) ~/~ (coerce v :: v a) + +divSameProp :: forall u v a u2 . + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + , Show a, AEq a, Eq a, Arbitrary a + ) + => Property +divSameProp = property (\(a :: a) (b :: a) -> b == 0 || + (coerce (fromTo' (coerce a :: u a) :: v a) / b :: a) + ~== divSame @u @v a b + ) + +divSameSpec :: forall u v a u2 . + ( u2 ~ BaseUnitOf u .^+ 2, IsUnit u2 + , DimEq u v + , ConversionFactor u a, ConversionFactor v a + , ShowUnit u, ShowUnit v + , Show a, AEq a, Eq a, Arbitrary a + ) + => Spec +divSameSpec = it (showUnit @u ++ " ~/~ " ++ showUnit @v) + $ divSameProp @u @v @a + +------------------ Arithmetic with two different dimensions ------------------- + +-- mulRight :: forall u v a u2. +-- ( u2 ~ BaseUnitOf' (u .^+ 2) , IsUnit u2 +-- , DimEq u v +-- , FromTo' v u a +-- ) +-- => a -> a -> a +-- mulRight u v = coerce $ (coerce u :: u a) .*~ (coerce v :: v a) + +-- mulRightProp :: forall u v a u2. +-- ( u2 ~ BaseUnitOf' (u .^+ 2) , IsUnit u2 +-- , DimEq u v +-- , FromTo' v u a +-- , Show a, AEq a, Arbitrary a +-- ) +-- => Property +-- mulRightProp = property (\(a :: a) (b :: a) -> +-- (coerce (fromTo' (coerce a :: u a) :: v a) * b :: a) +-- ~== mulRight @u @v a b +-- ) + +-- mulRightSpec :: forall u v a u2. +-- ( u2 ~ BaseUnitOf' (u .^+ 2) , IsUnit u2 +-- , DimEq u v +-- , FromTo' v u a +-- , ShowUnit u, ShowUnit v +-- , Show a, AEq a, Arbitrary a +-- ) => Spec +-- mulRightSpec = it (showUnit @u ++ " .*~ " ++ showUnit @v) +-- $ mulRightProp @u @v @a + +-- mulLeft :: forall u v a v2. +-- ( v2 ~ BaseUnitOf' (v .^+ 2), IsUnit v2 +-- , DimEq v u +-- , FromTo' u v a +-- ) +-- => a -> a -> a +-- mulLeft u v = coerce $ (coerce u :: u a) ~*. (coerce v :: v a) + +-- mulLeftProp :: forall u v a v2. +-- ( v2 ~ BaseUnitOf' (v .^+ 2), IsUnit v2 +-- , DimEq v u +-- , FromTo' u v a +-- , Show a, AEq a, Arbitrary a +-- ) +-- => Property +-- mulLeftProp = property (\(a :: a) (b :: a) -> +-- (coerce (fromTo' (coerce a :: u a) :: v a) * b :: a) +-- ~== mulLeft @u @v a b +-- ) + +-- mulLeftSpec :: forall u v a v2. +-- ( v2 ~ BaseUnitOf' (v .^+ 2), IsUnit v2 +-- , DimEq v u +-- , FromTo' u v a +-- , ShowUnit u, ShowUnit v +-- , Show a, AEq a, Arbitrary a +-- ) => Spec +-- mulLeftSpec = it (showUnit @u ++ " ~*. " ++ showUnit @v) +-- $ mulLeftProp @u @v @a + + +mulDiffDim :: forall u v a. + ( ConversionFactor u a, ConversionFactor v a) + => a -> a -> a +mulDiffDim u v = coerce $ (coerce u :: u a) .*. (coerce v :: v a) + +mulDiffDimProp :: forall u v a. + ( ConversionFactor u a, ConversionFactor v a + , ConversionFactor (u .*. v) a + , Arbitrary a, Show a, AEq a + ) + => Property +mulDiffDimProp = + property (\a b -> a * b ~== mulDiffDim @u @v @a a b) + .&&. toFromProp @(u .*. v) @a + +mulDiffDimSpec :: forall u v a. + ( ConversionFactor u a, ConversionFactor v a + , ConversionFactor (u .*. v) a + , Arbitrary a, Show a, AEq a + , ShowUnit u, ShowUnit v + ) + => Spec +mulDiffDimSpec = it (showUnit @u ++ " .*. " ++ showUnit @v) + $ mulDiffDimProp @u @v @a + +divDiffDim :: forall u v a. + ( IsUnit u, IsUnit v, IsUnit (u ./. v) + , Fractional a + ) + => a -> a -> a +divDiffDim u v = coerce $ (coerce u :: u a) ./. (coerce v :: v a) + +divDiffDimProp :: forall u v a. + ( IsUnit u, IsUnit v, IsUnit (u ./. v) + , ConversionFactor (u ./. v) a + , IsUnit (u ./. v) + , Arbitrary a, Show a, AEq a, Eq a, Fractional a + ) + => Property +divDiffDimProp = + property (\a b -> b == 0 || a / b ~== divDiffDim @u @v @a a b) + .&&. toFromProp @(u ./. v) @a + +divDiffDimSpec :: forall u v a. + (IsUnit u, IsUnit v, IsUnit (u ./. v) + , ConversionFactor (u ./. v) a + , IsUnit (u ./. v) + , Arbitrary a, Show a, AEq a, Eq a, Fractional a + , ShowUnit u, ShowUnit v + ) + => Spec +divDiffDimSpec = it (showUnit @u ++ " ./. " ++ showUnit @v) + $ divDiffDimProp @u @v @a + +-------------------------------- Exponentiation -------------------------------- + +exp2 :: forall u a. + ConversionFactor u a + => a -> a +exp2 u = coerce $ (coerce u :: u a) .^. pos2 + +expm1 :: forall u a. + ConversionFactor u a + => a -> a +expm1 u = coerce $ (coerce u :: u a) .^. neg1 + +exp2Prop :: forall u a. + ( ConversionFactor u a + , Arbitrary a, Show a, AEq a + ) + => Property +exp2Prop = + property (\a -> a * a ~== exp2 @u @a a) + +expm1Prop :: forall u a. + ( ConversionFactor u a + , Arbitrary a, Show a, Eq a, AEq a + ) + => Property +expm1Prop = + property (\a -> a == 0 || 1 / a ~== expm1 @u @a a) + +expSpec :: forall u a. + ( ConversionFactor u a + , ShowUnit u + , Arbitrary a, Show a, Eq a, AEq a + ) + => Spec +expSpec = it (showUnit @u ++ " .^+ 2 ," ++ showUnit @u ++ " .^- 1") $ + exp2Prop @u @a .&&. expm1Prop @u @a + +exp2Conv :: forall u a. + ConversionFactor u a + => a -> a +exp2Conv u = coerce $ (coerce u :: u a) ~^~ pos2 + +expm1Conv :: forall u a. + ConversionFactor u a + => a -> a +expm1Conv u = coerce $ (coerce u :: u a) ~^~ neg1 + +exp2ConvProp :: forall u a. + ( ConversionFactor u a + , Arbitrary a, Show a, AEq a + ) + => Property +exp2ConvProp = + property (\a -> + coerce (toBaseUnit' (coerce a :: u a)) ^^ (2 :: Int) ~== exp2Conv @u @a a) + +expm1ConvProp :: forall u a. + ( ConversionFactor u a + , Arbitrary a, Show a, Eq a, AEq a + ) + => Property +expm1ConvProp = + property (\a -> a == 0 || + coerce (toBaseUnit' (coerce a :: u a)) ^^ (-1 :: Int) ~== expm1Conv @u @a a) + + +expConvSpec :: forall u a. + ( ConversionFactor u a + , ShowUnit u + , Arbitrary a, Show a, Eq a, AEq a + ) + => Spec +expConvSpec = it (showUnit @u ++ "~^~ pos2 ," ++ showUnit @u ++ "~^~ neg1") $ + exp2ConvProp @u @a .&&. expm1ConvProp @u @a + diff --git a/test/Data/Units/Core/ConvertProp.hs b/test/Data/Units/Core/ConvertProp.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/Core/ConvertProp.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-- {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Units.Core.ConvertProp where + + +import Data.Coerce + +import Data.AEq + +import Test.QuickCheck +import Test.Hspec + +import Data.Units + +isApproxId :: AEq a => (a -> a) -> a -> Bool +isApproxId f a = f a ~== a + +------------------------------------ toFrom ------------------------------------ + +toFrom :: forall u a. + (ConvertibleUnit u a) + => a -> a +toFrom a = coerce + (toBaseUnit (fromBaseUnit @u (coerce a :: BaseUnitOf u a) :: u a) + :: BaseUnitOf u a) + +toFromProp :: forall u a. + ( ConvertibleUnit u a + , Arbitrary a, Show a, AEq a + ) + => Property +toFromProp = property (isApproxId (toFrom @u @a)) + +toFromSpec :: forall u a. + ( ShowUnit u + , ConvertibleUnit u a + , Arbitrary a, Show a, AEq a + ) + => Spec +toFromSpec = + it ("toFrom " ++ showUnit @u) (toFromProp @u @a) + + +------------------------------------ fromTo ------------------------------------ + +fromToRoundtrip :: forall u v a. + ( IsUnit u, IsUnit v + , FromTo u v a, FromTo v u a + ) + => a -> a +fromToRoundtrip a = coerce (fromTo (fromTo (coerce a :: u a) :: v a) :: u a) + +fromToProp :: forall u v a. + ( ShowUnit u, ShowUnit v + , FromTo u v a, FromTo v u a + , Arbitrary a, Show a, AEq a + ) + => Property +fromToProp = property $ isApproxId (fromToRoundtrip @u @v @a) + +fromToSpec :: forall u v a. + ( ShowUnit u, ShowUnit v + , FromTo u v a, FromTo v u a + , Arbitrary a, Show a, AEq a + ) + => Spec +fromToSpec = + it ("From `" ++ showUnit @u ++ "` to `" ++ showUnit @v ++ "`") + $ fromToProp @u @v @a + +fromToAssert :: forall a u v. + ( Show (u a), Show (v a) + , FromTo u v a + , FromTo v u a + , Arbitrary a, ShowUnit u, ShowUnit v, Show a, AEq a + ) + => u a -> v a -> Spec +fromToAssert u v = + it ("`" ++ prettyQuantity u ++ "` should be `" ++ prettyQuantity v ++ "`") $ + (coerce (fromTo u :: v a) :: a) ~== (coerce v :: a) + && (coerce (fromTo v :: u a) :: a) ~== (coerce u :: a) + `shouldBe` True + + +----------------------------------- fromTo' ------------------------------------ + +fromToRoundtrip' :: forall u v a. + ( FromTo' u v a, FromTo' v u a) + => a -> a +fromToRoundtrip' a = coerce (fromTo' (fromTo' (coerce a :: u a) :: v a) :: u a) + +fromToProp' :: forall u v a. + ( ShowUnit u, ShowUnit v + , FromTo' u v a, FromTo' v u a + , Arbitrary a, Show a, AEq a + ) + => Property +fromToProp' = property $ isApproxId (fromToRoundtrip' @u @v @a) + + +fromToSpec' :: forall u v a. + ( ShowUnit u, ShowUnit v + , FromTo' u v a, FromTo' v u a + , Arbitrary a, Show a, AEq a + ) + => Spec +fromToSpec' = + it ("From' `" ++ showUnit @u ++ "` to' `" ++ showUnit @v ++ "`") + $ fromToProp' @u @v @a diff --git a/test/Data/Units/CoreProp.hs b/test/Data/Units/CoreProp.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/CoreProp.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Units.CoreProp + ( module Data.Units.Core.ArithmeticProp + , module Data.Units.Core.ConvertProp + , module Data.Units.CoreProp + ) + where + +import Data.Units.Core.ArithmeticProp +import Data.Units.Core.ConvertProp + +import Test.QuickCheck +import Test.Hspec + +import Data.AEq + +import Data.Units + +sameDimSpec :: forall u a. + (IsUnit u, Floating (u a), ShowUnit u + , Show a, AEq a, Floating a, Eq a, Arbitrary a + , FromTo' u u a + , DimEq u u + , IsUnit (NormalizeUnitL (u .^+ 2)) + , IsUnit (BaseUnitOf u) + ) + => Spec +sameDimSpec = describe ("Unit " ++ showUnit @u) $ do + floatingSpec @u @a + addLeftSpec @u @u @a + addRightSpec @u @u @a + addSameSpec @u @u @a + subLeftSpec @u @u @a + subRightSpec @u @u @a + subSameSpec @u @u @a + mulSameSpec @u @u @a + -- mulLeftSpec @u @u @a + -- mulRightSpec @u @u @a + divSameSpec @u @u @a + expSpec @u @a + expConvSpec @u @a + diff --git a/test/Data/Units/NonSI/AngleSpec.hs b/test/Data/Units/NonSI/AngleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonSI/AngleSpec.hs @@ -0,0 +1,30 @@ +module Data.Units.NonSI.AngleSpec where + +import Test.Hspec + +import qualified Data.Units.SI.Derived.Angle as SI +import qualified Data.Units.SI.NonSI.Angle as SI +import qualified Data.Units.AngleSI.System as A +import qualified Data.Units.AngleSI.NonSI.Angle as A + +import Data.Units.Core.ConvertProp + +spec :: Spec +spec = do + describe "Angle" $ do + toFromSpec @SI.Radian @Double + toFromSpec @SI.Degree @Double + toFromSpec @SI.Turn @Double + toFromSpec @SI.Gradian @Double + toFromSpec @A.Radian @Double + toFromSpec @A.Degree @Double + toFromSpec @A.Turn @Double + toFromSpec @A.Gradian @Double + fromToAssert @Double (SI.Radian pi) (SI.Degree 180) + fromToAssert @Double (SI.Degree 90) (SI.Gradian 100) + fromToAssert @Double (SI.Turn (1 / 4)) (SI.Degree 90) + fromToAssert @Double (SI.Radian (pi/4)) (SI.Turn (1 / 8)) + fromToAssert @Double (A.Radian pi) (A.Degree 180) + fromToAssert @Double (A.Degree 90) (A.Gradian 100) + fromToAssert @Double (A.Turn (1 / 4)) (A.Degree 90) + fromToAssert @Double (A.Radian (pi/4)) (A.Turn (1 / 8)) diff --git a/test/Data/Units/NonSI/AreaSpec.hs b/test/Data/Units/NonSI/AreaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonSI/AreaSpec.hs @@ -0,0 +1,25 @@ +module Data.Units.NonSI.AreaSpec where + +import Test.Hspec + +import Data.Units.Core.ConvertProp +import Data.Units.Core.System +import Data.Units.Imperial.Area +import Data.Units.SI + +type SquareMeter = (Meter .^+ 2) Double + +spec :: Spec +spec = do + describe "Area" $ do + toFromSpec @Acre @Double + fromToAssert @Double (1 :: SquareMeter) (Acre $ 1 / ((1200 / 3937)^2 * 43560)) + fromToAssert @Double (Acre 1) ((1200 / 3937)^2 * 43560 :: SquareMeter) + + toFromSpec @Perch @Double + fromToAssert @Double (1 :: SquareMeter) (Perch $ 1 / ((1200 / 3937)^2 * 1089 / 4)) + fromToAssert @Double (Perch 1) ((1200 / 3937)^2 * 1089 / 4 :: SquareMeter) + + toFromSpec @Rood @Double + fromToAssert @Double (1 :: SquareMeter) (Rood $ 1 / ((1200 / 3937)^2 * 10890)) + fromToAssert @Double (Rood 1) ((1200 / 3937)^2 * 10890 :: SquareMeter) diff --git a/test/Data/Units/NonSI/FrequencySpec.hs b/test/Data/Units/NonSI/FrequencySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonSI/FrequencySpec.hs @@ -0,0 +1,17 @@ +module Data.Units.NonSI.FrequencySpec where + +import Test.Hspec + +import Data.Units.SI +import Data.Units.NonSI.Frequency + +import Data.Units.Core.ConvertProp + +spec :: Spec +spec = do + describe "Frequency" $ do + fromToAssert @Double (69 :: MidiPitch Double) (Hertz 440) + it "decomposePitchCents, detune < 1" $ do + + decomposePitchCents (123.5 :: MidiPitch Double) `shouldBe` (123, 0.5) + diff --git a/test/Data/Units/NonSI/LengthSpec.hs b/test/Data/Units/NonSI/LengthSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonSI/LengthSpec.hs @@ -0,0 +1,131 @@ +module Data.Units.NonSI.LengthSpec where + +import Test.Hspec + +import Data.Units.NonSI.Length +import Data.Units.SI + +import Data.Units.Core.ConvertProp + +spec :: Spec +spec = do + describe "Length" $ do + toFromSpec @Foot @Double + fromToAssert @Double (Meter 1) (Foot $ 1 / (1200 / 3937)) + fromToAssert @Double (Foot 1) (Meter $ 1200 / 3937) + + toFromSpec @Twip @Double + fromToAssert @Double (Meter 1) (Twip $ 1 / (1200 / 3937 / 17280)) + fromToAssert @Double (Twip 1) (Meter $ 1200 / 3937 / 17280) + + toFromSpec @Thou @Double + fromToAssert @Double (Meter 1) (Thou $ 1 / (1200 / 3937 / 12000)) + fromToAssert @Double (Thou 1) (Meter $ 1200 / 3937 / 12000) + + toFromSpec @Barleycorn @Double + fromToAssert @Double (Meter 1) (Barleycorn $ 1 / (1200 / 3937 / 36)) + fromToAssert @Double (Barleycorn 1) (Meter $ 1200 / 3937 / 36) + + toFromSpec @Inch @Double + fromToAssert @Double (Meter 1) (Inch $ 1 / (1200 / 3937 / 12)) + fromToAssert @Double (Inch 1) (Meter $ 1200 / 3937 / 12) + + toFromSpec @Hand @Double + fromToAssert @Double (Meter 1) (Hand $ 1 / (1200 / 3937 / 3)) + fromToAssert @Double (Hand 1) (Meter $ 1200 / 3937 / 3) + + toFromSpec @Yard @Double + fromToAssert @Double (Meter 1) (Yard $ 1 / (1200 / 3937 * 3)) + fromToAssert @Double (Yard 1) (Meter $ 1200 / 3937 * 3) + + toFromSpec @Chain @Double + fromToAssert @Double (Meter 1) (Chain $ 1 / (1200 / 3937 * 66)) + fromToAssert @Double (Chain 1) (Meter $ 1200 / 3937 * 66) + + toFromSpec @Furlong @Double + fromToAssert @Double (Meter 1) (Furlong $ 1 / (1200 / 3937 * 660)) + fromToAssert @Double (Furlong 1) (Meter $ 1200 / 3937 * 660) + + toFromSpec @Mile @Double + fromToAssert @Double (Meter 1) (Mile $ 1 / (1200 / 3937 * 5280)) + fromToAssert @Double (Mile 1) (Meter $ 1200 / 3937 * 5280) + + toFromSpec @League @Double + fromToAssert @Double (Meter 1) (League $ 1 / (1200 / 3937 * 15840)) + fromToAssert @Double (League 1) (Meter $ 1200 / 3937 * 15840) + + toFromSpec @Fathom @Double + fromToAssert @Double (Meter 1) (Fathom $ 1 / (1200 / 3937 * 6.0761)) + fromToAssert @Double (Fathom 1) (Meter $ 1200 / 3937 * 6.0761) + + toFromSpec @Cable @Double + fromToAssert @Double (Meter 1) (Cable $ 1 / (1200 / 3937 * 607.61)) + fromToAssert @Double (Cable 1) (Meter $ 1200 / 3937 * 607.61) + + toFromSpec @NauticalMile @Double + fromToAssert @Double (Meter 1) (NauticalMile $ 1 / (1200 / 3937 * 60761 / 10)) + fromToAssert @Double (NauticalMile 1) (Meter $ 1200 / 3937 * 60761 / 10) + + toFromSpec @Link @Double + fromToAssert @Double (Meter 1) (Link $ 1 / (1200 / 3937 * 66 / 100)) + fromToAssert @Double (Link 1) (Meter $ 1200 / 3937 * 66 / 100) + + toFromSpec @Rod @Double + fromToAssert @Double (Meter 1) (Rod $ 1 / (1200 / 3937 * 66 / 4)) + fromToAssert @Double (Rod 1) (Meter $ 1200 / 3937 * 66 / 4) + + toFromSpec @Thou @Double + fromToAssert @Double (Meter 1) (Thou $ 1 / (1200 / 3937 / 12000)) + fromToAssert @Double (Thou 1) (Meter $ 1200 / 3937 / 12000) + + toFromSpec @Barleycorn @Double + fromToAssert @Double (Meter 1) (Barleycorn $ 1 / (1200 / 3937 / 36)) + fromToAssert @Double (Barleycorn 1) (Meter $ 1200 / 3937 / 36) + + toFromSpec @Inch @Double + fromToAssert @Double (Meter 1) (Inch $ 1 / (1200 / 3937 / 12)) + fromToAssert @Double (Inch 1) (Meter $ 1200 / 3937 / 12) + + toFromSpec @Hand @Double + fromToAssert @Double (Meter 1) (Hand $ 1 / (1200 / 3937 / 3)) + fromToAssert @Double (Hand 1) (Meter $ 1200 / 3937 / 3) + + toFromSpec @Yard @Double + fromToAssert @Double (Meter 1) (Yard $ 1 / (1200 / 3937 * 3)) + fromToAssert @Double (Yard 1) (Meter $ 1200 / 3937 * 3) + + toFromSpec @Chain @Double + fromToAssert @Double (Meter 1) (Chain $ 1 / (1200 / 3937 * 66)) + fromToAssert @Double (Chain 1) (Meter $ 1200 / 3937 * 66) + + toFromSpec @Furlong @Double + fromToAssert @Double (Meter 1) (Furlong $ 1 / (1200 / 3937 * 660)) + fromToAssert @Double (Furlong 1) (Meter $ 1200 / 3937 * 660) + + toFromSpec @Mile @Double + fromToAssert @Double (Meter 1) (Mile $ 1 / (1200 / 3937 * 5280)) + fromToAssert @Double (Mile 1) (Meter $ 1200 / 3937 * 5280) + + toFromSpec @League @Double + fromToAssert @Double (Meter 1) (League $ 1 / (1200 / 3937 * 15840)) + fromToAssert @Double (League 1) (Meter $ 1200 / 3937 * 15840) + + toFromSpec @Fathom @Double + fromToAssert @Double (Meter 1) (Fathom $ 1 / (1200 / 3937 * 6.0761)) + fromToAssert @Double (Fathom 1) (Meter $ 1200 / 3937 * 6.0761) + + toFromSpec @Cable @Double + fromToAssert @Double (Meter 1) (Cable $ 1 / (1200 / 3937 * 607.61)) + fromToAssert @Double (Cable 1) (Meter $ 1200 / 3937 * 607.61) + + toFromSpec @NauticalMile @Double + fromToAssert @Double (Meter 1) (NauticalMile $ 1 / (1200 / 3937 * 60761 / 10)) + fromToAssert @Double (NauticalMile 1) (Meter $ 1200 / 3937 * 60761 / 10) + + toFromSpec @Link @Double + fromToAssert @Double (Meter 1) (Link $ 1 / (1200 / 3937 * 66 / 100)) + fromToAssert @Double (Link 1) (Meter $ 1200 / 3937 * 66 / 100) + + toFromSpec @Rod @Double + fromToAssert @Double (Meter 1) (Rod $ 1 / (1200 / 3937 * 66 / 4)) + fromToAssert @Double (Rod 1) (Meter $ 1200 / 3937 * 66 / 4) diff --git a/test/Data/Units/NonSI/TemperatureSpec.hs b/test/Data/Units/NonSI/TemperatureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonSI/TemperatureSpec.hs @@ -0,0 +1,18 @@ +module Data.Units.NonSI.TemperatureSpec where + +import Test.Hspec + +import Data.Units.NonSI.Temperature +import Data.Units.SI + +import Data.Units.Core.ConvertProp + +spec :: Spec +spec = do + describe "Temperature" $ do + toFromSpec @Celsius @Double + toFromSpec @Fahrenheit @Double + toFromSpec @Kelvin @Double + fromToAssert @Double (Celsius 0) (Kelvin 273.15) + fromToAssert @Double (Fahrenheit 32) (Celsius 0) + fromToAssert @Double (Fahrenheit 212) (Kelvin 373.15) diff --git a/test/Data/Units/NonSI/TimeSpec.hs b/test/Data/Units/NonSI/TimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonSI/TimeSpec.hs @@ -0,0 +1,13 @@ +module Data.Units.NonSI.TimeSpec where + +import Test.Hspec + +import Data.Units.NonSI.Time +import Data.Units.Core.ConvertProp + +spec :: Spec +spec = do + describe "Angle" $ do + toFromSpec @Minute @Double + toFromSpec @Hour @Double + fromToAssert @Double (Hour 1) (Minute 60) diff --git a/test/Data/Units/NonStd/AngleSpec.hs b/test/Data/Units/NonStd/AngleSpec.hs deleted file mode 100644 --- a/test/Data/Units/NonStd/AngleSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Data.Units.NonStd.AngleSpec where - -import Test.Hspec - -import qualified Data.Units.SI.Derived.Angle as SI -import qualified Data.Units.SI.NonStd.Angle as SI -import qualified Data.Units.AngleSI.System as A -import qualified Data.Units.AngleSI.NonStd.Angle as A - -import Data.Units.Base.ConvertProp - -spec :: Spec -spec = do - describe "Angle" $ do - toFromSpec @SI.Radian @Double - toFromSpec @SI.Degree @Double - toFromSpec @SI.Turn @Double - toFromSpec @SI.Gradian @Double - toFromSpec @A.Radian @Double - toFromSpec @A.Degree @Double - toFromSpec @A.Turn @Double - toFromSpec @A.Gradian @Double - fromToAssert @Double (SI.Radian pi) (SI.Degree 180) - fromToAssert @Double (SI.Degree 90) (SI.Gradian 100) - fromToAssert @Double (SI.Turn (1 / 4)) (SI.Degree 90) - fromToAssert @Double (SI.Radian (pi/4)) (SI.Turn (1 / 8)) - fromToAssert @Double (A.Radian pi) (A.Degree 180) - fromToAssert @Double (A.Degree 90) (A.Gradian 100) - fromToAssert @Double (A.Turn (1 / 4)) (A.Degree 90) - fromToAssert @Double (A.Radian (pi/4)) (A.Turn (1 / 8)) diff --git a/test/Data/Units/NonStd/FrequencySpec.hs b/test/Data/Units/NonStd/FrequencySpec.hs deleted file mode 100644 --- a/test/Data/Units/NonStd/FrequencySpec.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Data.Units.NonStd.FrequencySpec where - -import Test.Hspec - -import Data.Units.SI -import Data.Units.NonStd.Frequency - -import Data.Units.Base.ConvertProp - -spec :: Spec -spec = do - describe "Frequency" $ do - fromToAssert @Double (69 :: MidiPitch Double) (Hertz 440) - it "decomposePitchCents, detune < 1" $ do - - decomposePitchCents (123.5 :: MidiPitch Double) `shouldBe` (123, 0.5) - diff --git a/test/Data/Units/NonStd/TemperatureSpec.hs b/test/Data/Units/NonStd/TemperatureSpec.hs deleted file mode 100644 --- a/test/Data/Units/NonStd/TemperatureSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Data.Units.NonStd.TemperatureSpec where - -import Test.Hspec - -import Data.Units.NonStd.Temperature -import Data.Units.SI - -import Data.Units.Base.ConvertProp - -spec :: Spec -spec = do - describe "Temperature" $ do - toFromSpec @Celsius @Double - toFromSpec @Fahrenheit @Double - toFromSpec @Kelvin @Double - fromToAssert @Double (Celsius 0) (Kelvin 273.15) - fromToAssert @Double (Fahrenheit 32) (Celsius 0) - fromToAssert @Double (Fahrenheit 212) (Kelvin 373.15) diff --git a/test/Data/Units/NonStd/TimeSpec.hs b/test/Data/Units/NonStd/TimeSpec.hs deleted file mode 100644 --- a/test/Data/Units/NonStd/TimeSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Data.Units.NonStd.TimeSpec where - -import Test.Hspec - -import Data.Units.NonStd.Time -import Data.Units.Base.ConvertProp - -spec :: Spec -spec = do - describe "Angle" $ do - toFromSpec @Minute @Double - toFromSpec @Hour @Double - fromToAssert @Double (Hour 1) (Minute 60) diff --git a/test/Data/Units/SI/PrefixSpec.hs b/test/Data/Units/SI/PrefixSpec.hs --- a/test/Data/Units/SI/PrefixSpec.hs +++ b/test/Data/Units/SI/PrefixSpec.hs @@ -4,7 +4,7 @@ import Data.Units -import Data.Units.BaseProp +import Data.Units.CoreProp spec :: Spec spec = do diff --git a/test/Data/Units/SI/SystemSpec.hs b/test/Data/Units/SI/SystemSpec.hs --- a/test/Data/Units/SI/SystemSpec.hs +++ b/test/Data/Units/SI/SystemSpec.hs @@ -4,7 +4,7 @@ import Data.Units -import Data.Units.BaseProp +import Data.Units.CoreProp spec :: Spec spec = do