diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `tiles` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2025, Alice Rixte + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,174 @@ +# convert-units + +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/AliceRixte/convert-units/LICENSE) [![Hackage](https://img.shields.io/hackage/v/convert-units.svg)](https://hackage.haskell.org/package/convert-units) [![Nightly](https://www.stackage.org/package/convert-units/badge/nightly)](https://www.stackage.org/nightly/package/convert-units) [![LTS](https://www.stackage.org/package/convert-units/badge/lts)](https://www.stackage.org/lts/package/convert-units) + +A Haskell library to convert between units, that will statically check the dimensions of the units being converted. + +Conversions are usually as fast as manual multiplication by a conversion factor, thanks to heavy use of inlining. + +## Usage + +You will need the `TypeApplications` extension: + +``` haskell +>>> :set -XTypeApplications +``` + +### Convert between units + +You can use `to` or `fromTo` for conversions: +``` haskell +>>> t = Hour 8 +>>> to @Minute t +Minute 480.0 + +>>> fromTo @Hour @Minute 8 +Minute 480.0 +``` + +User-friendly static errors when trying to convert between incompatible dimensions: + +```haskell +>>> fromTo @Minute @Meter 1 +• Cannot convert unit ‘min’ to unit ‘m’ because their dimensions do not match. + Dimension of ‘min’ is: T + Dimension of ‘m’ is: L +``` + +There are two sorts of unit conversions: + +1. The regular ones +``` haskell +>>> fromTo @Celsius @Kelvin 0 +Kelvin 273.15 +``` + +2. Conversion that only takes the conversion factor into account (and not potential offsets): +``` haskell +>>> fromTo' @Celsius @Kelvin 0 +Kelvin 0.0 +``` + +### Pretty printing + +``` haskell +>>> putQuantity (Celsius 25) +25 °C +>>> putQuantity (quantity @(Kilo Meter ./. Hour) 130) +130 km⋅hr⁻¹ +``` + +Get info about some unit: + +``` haskell +>>> 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⁻² +``` + +### Unit arithmetics + +Multiplication by a scalar: + +``` haskell +>>> 2 * Meter 4 +Meter 8 +``` + +You can multiply or divide two units: + +``` haskell +>>> putQuantity $ Newton 1 .*. Meter 2 +2 N⋅m +``` + +``` haskell +>>> v = Kilo (Meter 10) ./. Hour 2 +>>> putQuantity v +5.0 km⋅hr⁻¹ +>>> putQuantity $ to @(Meter ./. Second) v +1.3888888888888888 m⋅s⁻¹ +``` + +Automatically simplify units by converting the right unit : +``` haskell +>>> putQuantity $ Kilo (Meter 2) .*~ Meter 3 +6.0e-3 km² +``` + +or the left unit: + +``` haskell +>>> putQuantity $ Kilo (Meter 2) ~*. Meter 3 +6000.0 m² +``` + +### Convert to and from SI base units + +``` haskell +>>> v = toBaseUnit (quantity @(Kilo Meter ./. Hour) 36) +>>> putQuantity v +10.0 m⋅s⁻¹ +``` + +### Make your own units, prefixes and dimensions + +Make a new dimension with its associated base unit: + +``` haskell +$(mkDim "Angle" "A" 1000) +$(mkBaseUnit "Radian" "rad" ''Angle) +``` + +Make a new unit convertible by multiplying with some factor: +``` haskell +$(mkUnit "Minute" "min" ''Time 60) +``` + +Make a new prefix: + +``` haskell +$(mkPrefix "Micro" "µ" 1e-6) +``` + +Make a new unit with special conversion: + +``` haskell +$(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 #-} +``` + +## Comparison with other Haskell unit libraries + +There are other excellent units libraries out there, the two most used being: +- [dimensional](https://hackage.haskell.org/package/dimensional) +- [units](https://hackage.haskell.org/package/units) + +Compared to these two libraries, `convert-units` offers + +* Greater flexibility for conversions that do not use conversion factors, for instance for logarithmic units (see logarithmic pitch units in `Data.Unit.NonStd.Frequency` for instance) +* The possibility to add dimensions, such as `Angle`, `Information` (not yet implemented, see this [wikipedia article](https://en.wikipedia.org/wiki/Quantities_of_information)), and so on ... + +| Feature | convert-units | dimensional | units | +|---------------------------------------|:------------:|:-----------:|:-----:| +| Static dimension checking | ✅ | ✅ | ✅ | +| Custom unit | ✅ | ✅ | ✅ | +| Custom prefixes | ✅ | ✅ | ✅ | +| Custom dimensions | ✅ | ❌ | ❌ | +| Pretty-printing units | ✅ | ✅ | ✅ | +| Offset-aware conversions (e.g. °C/K) | ✅ | ✅ | ❌ | +| Any conversion | ✅ | ❌ | ❌ | diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE DataKinds#-} +{-# LANGUAGE TypeOperators#-} + +{-# OPTIONS_GHC -ddump-to-file #-} + +module Main (main) where + +import Criterion.Main + +import Data.Units + +mkBench f n = bench (show n) $ nf f n + +iterations :: [Int] +iterations = [10, 100, 1000] + + +kmphTomps :: Int -> Double +kmphTomps n = iterate + (unQuantity . fromTo @(Kilo Meter ./. Hour) @(Meter ./. Second) . quantity) + 5 !! n + +multConv :: Int -> Double +multConv n = iterate (*3.6) (5 :: Double) !! n + +-- | Check ddump to see it inlines correctly +u :: (.^-) Second 1 Double +u = fromTo (1415 :: Hertz Double) + +-- main :: IO() +-- main = print u + +main :: IO() +main = do + defaultMain [ + bgroup "~>" [ + bgroup "kmph ~> mps" (fmap (mkBench kmphTomps) iterations) + , bgroup "mult" (fmap (mkBench multConv) iterations) + ] + ] diff --git a/convert-units.cabal b/convert-units.cabal new file mode 100644 --- /dev/null +++ b/convert-units.cabal @@ -0,0 +1,158 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: convert-units +version: 0 +synopsis: Arithmetic and type checked conversions between units. +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 +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/AliceRixte/convert-units + +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.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.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.Prefixes + Data.Units.SI.System + other-modules: + Paths_convert_units + autogen-modules: + Paths_convert_units + hs-source-dirs: + src + default-extensions: + TypeApplications + StandaloneDeriving + DerivingVia + GeneralizedNewtypeDeriving + TypeOperators + PolyKinds + ScopedTypeVariables + DataKinds + TypeFamilies + FlexibleInstances + UndecidableInstances + MultiParamTypeClasses + FlexibleContexts + TemplateHaskell + ghc-options: -Wall -threaded + build-depends: + base >=4.18 && <5 + , template-haskell >=2.21.0 + default-language: Haskell2010 + +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.Units.SI.PrefixSpec + Data.Units.SI.SystemSpec + Paths_convert_units + autogen-modules: + Paths_convert_units + hs-source-dirs: + test + default-extensions: + TypeApplications + StandaloneDeriving + DerivingVia + GeneralizedNewtypeDeriving + TypeOperators + PolyKinds + ScopedTypeVariables + DataKinds + TypeFamilies + FlexibleInstances + UndecidableInstances + MultiParamTypeClasses + FlexibleContexts + TemplateHaskell + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.14 + , base >=4.18 && <5 + , convert-units + , hspec >=2.11 + , linear + , template-haskell >=2.21.0 + default-language: Haskell2010 + +benchmark convert-units-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_convert_units + autogen-modules: + Paths_convert_units + hs-source-dirs: + benchmark + default-extensions: + TypeApplications + StandaloneDeriving + DerivingVia + GeneralizedNewtypeDeriving + TypeOperators + PolyKinds + ScopedTypeVariables + DataKinds + TypeFamilies + FlexibleInstances + UndecidableInstances + MultiParamTypeClasses + FlexibleContexts + 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 diff --git a/src/Data/Type/Int.hs b/src/Data/Type/Int.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Int.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE ExistentialQuantification #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Type.Int +-- Description : Type-level integers +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- Type level integers. +-- +-------------------------------------------------------------------------------- + + +module Data.Type.Int + ( module Data.Type.Int + ) where + +import GHC.TypeLits +import Data.Type.Ord +import Data.Type.Equality +import Data.Type.Bool + +import Data.Proxy + +-- | Add a sign to any type +-- +data Signed a = Pos a | Neg a | Zero + +-- | Type integers +-- +-- ZZ represents the mathematical font for the set of integers +type ZZ = Signed Nat + + + +type instance Compare (a :: Signed k) (b :: Signed k) = CmpSigned a b + +type family IsPos (a :: ZZ) :: Bool where + IsPos (Pos a) = 'True + IsPos b = 'False + +-- | Compare Signed kinds when those kinds are comparable. +type family CmpSigned a b where + CmpSigned (Neg a) (Neg b) = FlipOrdering (Compare a b) + CmpSigned (Neg a) b = 'LT + CmpSigned Zero (Neg a) = 'GT + CmpSigned Zero Zero = 'EQ + CmpSigned Zero (Pos a) = 'GT + CmpSigned (Pos a) (Pos b) = Compare a b + CmpSigned (Pos a) b = 'GT + +-- | Always use @Zero@ instead of @Pos 0@ or @Neg 0@. +type family NormalizeInt (a :: ZZ) :: ZZ where + NormalizeInt (Pos 0) = Zero + NormalizeInt (Neg 0) = Zero + NormalizeInt n = n + + +-- | Reverse the order of an Ordering +-- +-- This should be declared in to Data.Type.Ord in base +type family FlipOrdering (o :: Ordering) :: Ordering where + FlipOrdering 'LT = 'GT + FlipOrdering 'EQ = 'EQ + FlipOrdering 'GT = 'LT + + +-- | Absolute value +-- +type family Abs (a :: ZZ) :: Nat where + Abs (Pos a) = a + Abs (Neg a) = a + Abs Zero = 0 + +-- | Unary negation +-- +type family Negate (a :: ZZ) :: ZZ where + Negate (Pos a) = Neg a + Negate (Neg a) = Pos a + Negate Zero = Zero + + +-- | Utility family for Add +-- +type family AddCmp (cmp :: Ordering) (a :: ZZ) (b :: ZZ) where + AddCmp _ a Zero = a + AddCmp _ Zero b = b + AddCmp _ (Pos a) (Pos b) = Pos (a + b) + AddCmp _ (Neg a) (Neg b) = Neg (a + b) + AddCmp EQ _ _ = Zero + AddCmp LT (Pos a) (Neg b) = Neg (b - a) + AddCmp GT (Pos a) (Neg b) = Pos (a - b) + AddCmp LT (Neg a) (Pos b) = Pos (b - a) + AddCmp GT (Neg a) (Pos b) = Neg (a - b) + +-- | Addition +type family Add (a :: ZZ) (b :: ZZ) :: ZZ where + Add a b = AddCmp (Compare (Abs a) (Abs b)) a b + +-- | Subtraction +type family Sub (a :: ZZ) (b :: ZZ) :: ZZ where + Sub a b = Add a (Negate b) + +-- | Multiplication +type family Mul (a :: ZZ) (b :: ZZ) :: ZZ where + Mul a Zero = a + Mul Zero b = b + Mul (Pos a) (Pos b) = Pos (a * b) + Mul (Pos a) (Neg b) = Neg (a * b) + Mul (Neg a) (Pos b) = Neg (a * b) + Mul (Neg a) (Neg b) = Pos (a * b) + + +-- | Exponentiation +type family Pow (a :: ZZ) (n :: Nat) :: ZZ where + Pow Zero 0 = Pos 1 -- Following Nat from Base : 0^0 :: Natural = 1 + Pow Zero n = Zero + Pow (Pos a) n = Pos (a ^ n) + Pow (Neg a) n = If (Mod n 2 == 0) (Pos (a^n)) (Neg (a^n)) + + +-- | Gives the integer associated to a type-level integer. +class KnownInt (r :: ZZ) where + -- | Reify a type integer to an integer. + intVal :: proxy r -> Integer + +instance KnownInt Zero where + intVal _ = 0 + +instance KnownNat n => KnownInt (Pos n) where + intVal _ = natVal (Proxy :: Proxy n) + +instance KnownNat n => KnownInt (Neg n) where + intVal _ = -natVal (Proxy :: Proxy n) + + diff --git a/src/Data/Type/Int/Proxy.hs b/src/Data/Type/Int/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Int/Proxy.hs @@ -0,0 +1,42 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/Units.hs @@ -0,0 +1,9 @@ +module Data.Units + ( module Data.Units.Base + , module Data.Units.SI + , module Data.Units.SI.NonStd + ) where + +import Data.Units.Base +import Data.Units.SI +import Data.Units.SI.NonStd diff --git a/src/Data/Units/AngleSI.hs b/src/Data/Units/AngleSI.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI.hs @@ -0,0 +1,37 @@ + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.AngleSI.Angle +-- Description : SI with an angle dimension @A@ +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- There is an ongoing debate about including Angle as a dimension of its own, +-- see for instance +-- +-- * [On the dimension of angles and their +-- units](https://iopscience.iop.org/article/10.1088/1681-7575/ac7bc2/pdf) , +-- Peter J Mohr /et all/, in Metrologia +-- * [Angles are inherently neither length ratios nor +-- dimensionless](https://iopscience.iop.org/article/10.1088/1681-7575/ab27d7/pdf), +-- Paul Quincey /et all/, in Metrologia +-- +-- This module adds an Angle dimension to the SI system. To use dimensionless +-- angles, see "Data.Units.SI". +-- +-------------------------------------------------------------------------------- + +module Data.Units.AngleSI + ( module Data.Units.AngleSI.System + , module Data.Units.AngleSI.Derived + , module Data.Units.SI.Prefixes + + ) where + +import Data.Units.AngleSI.System +import Data.Units.AngleSI.Derived +import Data.Units.SI.Prefixes diff --git a/src/Data/Units/AngleSI/Derived.hs b/src/Data/Units/AngleSI/Derived.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI/Derived.hs @@ -0,0 +1,63 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.AngleSI.Derived +-- Description : Dimensionless angles +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- This module defines SI derived units that use angles, where angles have a +-- dimension @`A`@. +-- +-- See "Data.Units.SI.Derived.Angle" for an equivalent of this where angles are +-- dimensionless. +-- +-------------------------------------------------------------------------------- + +module Data.Units.AngleSI.Derived + ( module Data.Units.SI.Derived.NonAngle + , SolidAngle + , Steradian (..) + , LuminousFlux + , Lumen (..) + , Illuminance + , Lux (..) + ) + where + +import Data.Coerce + +import Data.Units.Base +import Data.Units.AngleSI.System +import Data.Units.SI.Derived.NonAngle + + +-- | Solid angle quantity. +type SolidAngle = Angle .^+ 2 + +-- | A solid angle in steradians. +-- +$(mkUnit "Steradian" "sr" ''SolidAngle 1) + +-- | Luminous flux quantity. Equal to +-- +-- @ 'Angle'.^+2 .*. 'LuminousIntensity'@ +-- +type LuminousFlux = NormalizeDim (LuminousIntensity .*. SolidAngle) + +-- | Luminous flux in lumens +-- +$(mkUnit "Lumen" "lm" ''LuminousFlux 1) + +-- | Illuminance quantity. Equal to +-- +-- @ 'Angle'.^+2 .*. 'Length'.^-2 .*. 'LuminousIntensity' @ +-- +type Illuminance = NormalizeDim (LuminousFlux ./. Area) + +-- | Illuminance in lux +-- +$(mkUnit "Lux" "lx" ''Illuminance 1) diff --git a/src/Data/Units/AngleSI/NonStd.hs b/src/Data/Units/AngleSI/NonStd.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI/NonStd.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI/NonStd/Angle.hs @@ -0,0 +1,65 @@ + +-------------------------------------------------------------------------------- +-- | +-- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/AngleSI/System.hs @@ -0,0 +1,50 @@ + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.AngleSI.System +-- Description : SI unit system with dimensional angles of dimension A +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- This module defines radians as the standard unit for the angle (`@A@`) +-- dimension. +-- +-- See "Data.Units.SI.Angle" for dimensionless radians and steradians. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.AngleSI.System + ( module Data.Units.SI.System + , Angle (..) + , Radian (..) + , normalizeRadians + ) + where + +import Data.Fixed +import Data.Coerce + +import Data.Units.Base +import Data.Units.SI.System + +-- | The angle dimension, denotated @A@. +-- +$(mkDim "Angle" "A" 1000) + + +-- | An angle in radians. +-- +$(mkBaseUnit "Radian" "rad" ''Angle) + +-- | Normalize an angle to the range ]-pi, pi] +normalizeRadians :: (RealFrac a, Floating a) => Radian a -> Radian a +normalizeRadians x = if xmod > pi then xmod - twoPi else xmod + where + twoPi = 2 * pi + xmod = x `mod'` twoPi + diff --git a/src/Data/Units/Base.hs b/src/Data/Units/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/Base.hs @@ -0,0 +1,27 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/Base/Arithmetic.hs @@ -0,0 +1,393 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/Base/Convert.hs @@ -0,0 +1,393 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/Base/Prefix.hs @@ -0,0 +1,166 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/Base/System.hs @@ -0,0 +1,916 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/Base/TH.hs @@ -0,0 +1,441 @@ + +{-# 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/NonStd.hs b/src/Data/Units/NonStd.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonStd.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonStd/Frequency.hs @@ -0,0 +1,69 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonStd/Temperature.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/NonStd/Time.hs @@ -0,0 +1,36 @@ +{-# 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.hs b/src/Data/Units/SI.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI.hs @@ -0,0 +1,25 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.AngleSI.Angle +-- Description : International 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 standard units for the International System of Units (abbreviated +-- SI). +-- +-------------------------------------------------------------------------------- + +module Data.Units.SI + ( module Data.Units.SI.System + , module Data.Units.SI.Prefixes + , module Data.Units.SI.Derived + ) where + +import Data.Units.SI.System +import Data.Units.SI.Prefixes +import Data.Units.SI.Derived diff --git a/src/Data/Units/SI/Derived.hs b/src/Data/Units/SI/Derived.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/Derived.hs @@ -0,0 +1,24 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.Derived +-- Description : Derived units and dimensions for the International System of Units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-- Derived units and dimensions for the International System of Units. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.SI.Derived + ( module Data.Units.SI.Derived.Angle + , module Data.Units.SI.Derived.NonAngle + ) + where + +import Data.Units.SI.Derived.Angle +import Data.Units.SI.Derived.NonAngle diff --git a/src/Data/Units/SI/Derived/Angle.hs b/src/Data/Units/SI/Derived/Angle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/Derived/Angle.hs @@ -0,0 +1,84 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.Derived.Angle +-- Description : Dimensionless angles +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : unstable +-- Portability : non-portable (GHC extensions) +-- +-- This module defines radians and steradians as derived dimensionless units. +-- +-- See "Data.Units.AngleSI" for radians and steradians in an angle +-- dimension `@A@`. +-- +-------------------------------------------------------------------------------- + +module Data.Units.SI.Derived.Angle + ( Angle + , Radian (..) + , normalizeRadians + , SolidAngle + , Steradian (..) + , LuminousFlux + , Lumen (..) + , Illuminance + , Lux (..) + ) + where + +import Data.Fixed +import Data.Coerce + +import Data.Units.Base +import Data.Units.SI.System +import Data.Units.SI.Derived.NonAngle + +-- | The angle derived dimension in SI. Equal to +-- +-- @'NoDim'@ +-- +type Angle = NormalizeDim (Length ./. Length) + +-- | An angle in radians. +-- +$(mkUnit "Radian" "rad" ''Angle 1) + +-- | The solid angle derived dimension in SI. Equal to +-- +-- @'NoDim'@ +-- +type SolidAngle = NormalizeDim (Angle .^+ 2) + +-- | A solid angle in steradians. +-- +$(mkUnit "Steradian" "sr" ''SolidAngle 1) + +-- | Normalize an angle to the range ]-pi, pi] +normalizeRadians :: (RealFrac a, Floating a) => Radian a -> Radian a +normalizeRadians x = if xmod > pi then xmod - twoPi else xmod + where + twoPi = 2 * pi + xmod = x `mod'` twoPi + +-- | Luminous flux quantity. Equal to +-- +-- @ 'LuminousIntensity'@ +-- +type LuminousFlux = NormalizeDim (LuminousIntensity .*. SolidAngle) + +-- | Luminous flux in lumens +-- +$(mkUnit "Lumen" "lm" ''LuminousFlux 1) + +-- | Illuminance quantity. Equal to +-- +-- @ 'Length'.^-2 .*. 'LuminousIntensity' @ +-- +type Illuminance = NormalizeDim (LuminousFlux ./. Area) + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/Derived/NonAngle.hs @@ -0,0 +1,255 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.System +-- Description : SI derived units not containing angles. +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-- Derived units and dimensions for the International System of Units that do +-- not contain angles. +-- +-- This follows the wikipedia page https://en.wikipedia.org/wiki/SI_derived_unit. +-- +-------------------------------------------------------------------------------- + + +module Data.Units.SI.Derived.NonAngle + ( -- * Official derived units from SI + Celsius (..) + , Area + , Volume + , Frequency + , Hertz (..) + , Radioactivity + , Becquerel (..) + , Speed + , Acceleration + , Force + , Newton (..) + , Pressure + , Pascal (..) + , Stress + , Energy + , Joule (..) + , Work + , Heat + , Power + , RadiantFlux + , Watt (..) + , ElectricCharge + , Coulomb (..) + , QuantityOfElectricity + , Voltage + , Volt (..) + , ElectricPotential + , ElectromotiveForce + , Capacitance + , Farad (..) + , Resistance + , Ohm (..) + , Impedance + , Reactance + , Conductance + , Siemens (..) + , MagneticFlux + , Weber (..) + , MagneticInduction + , MagneticFluxDensity + , Tesla (..) + , Inductance + , Henry (..) + , EquivalentDose + , AbsorbedDose + , Gray (..) + , Sievert (..) + , CatalyticActivity + , Katal (..) + ) + where + +import Data.Units.Base +import Data.Units.SI.System + +type Area = Length .^+ 2 +type Volume = Length .^+ 3 + +type Frequency = Time .^- 1 + +-- | Frequency in hertz +-- +$(mkUnit "Hertz" "Hz" ''Frequency 1) + +type Radioactivity = Time .^- 1 + +-- | Radioactivity in becquerels +-- +$(mkUnit "Becquerel" "Bq" ''Radioactivity 1) + +-- | Speed quantity. Equal to +-- +-- @'Length' .*. 'Time'.^-1@ +-- +type Speed = NormalizeDim (Length ./. Time) + +type Acceleration = NormalizeDim (Length ./. Time .^+ 2) + +-- | Acceleration quantity. Equal to +-- +-- @'Length' .*. 'Time'.^-2@ +-- +type Force = NormalizeDim (Mass .*. Acceleration) + +-- | Force in newtons +-- +$(mkUnit "Newton" "N" ''Force 1) + +-- | Pressure quantity. Equal to +-- +-- @'Mass' .*. 'Length'.^-1 .*. 'Time'.^-2@ +-- +type Pressure = NormalizeDim (Force ./. (Length .^+ 2)) +type Stress = Pressure + +-- | Pressure in pascals +-- +$(mkUnit "Pascal" "Pa" ''Pressure 1) + +-- | Energy quantity. Equal to +-- +-- @ 'Mass' .*. 'Length'.^+2 .*. 'Time'.^-2@ +-- +type Energy = NormalizeDim (Length .*. Force) +type Work = Energy +type Heat = Energy + +-- | Energy in joules +-- +$(mkUnit "Joule" "J" ''Energy 1) + +-- | Power quantity. Equal to +-- +-- @ 'Mass' .*. 'Length'.^+2 .*. 'Time'.^-3 @ +-- + + +type Power = NormalizeDim (Energy ./. Time) +type RadiantFlux = Power + +-- | Power in watts +-- +$(mkUnit "Watt" "W" ''Power 1) + +-- | Electric charge quantity. Equal to +-- +-- @ 'Time' .*. 'Current'@ +-- +type ElectricCharge = NormalizeDim (Time .*. Current) +type QuantityOfElectricity = ElectricCharge + + +$(mkUnit "Coulomb" "C" ''ElectricCharge 1) + +-- | Electric voltage quantity. Equal to +-- +-- @ 'Mass' .*. 'Length'.^+2 .*. 'Time'.^-3 .*. 'Current'.^-1@ +-- +type Voltage = NormalizeDim (Power ./. Current) +type ElectricPotential = Voltage +type ElectromotiveForce = Voltage + +$(mkUnit "Volt" "V" ''Voltage 1) + +-- | Electric capacitance quantity. Equal to +-- +-- @'Mass'.^-1 .*. 'Length'.^-2 .*. 'Time'.^+4 .*. 'Current'.^+2@. +-- +type Capacitance = NormalizeDim (ElectricCharge ./. Voltage) + +$(mkUnit "Farad" "F" ''Capacitance 1) + +-- | Electric resistance quantity. Equal to +-- +-- @ 'Mass' .*. 'Length'.^+2 .*. 'Time'.^-3 .*. 'Current'.^-2@ +-- +type Resistance = NormalizeDim (Voltage ./. Current) +type Impedance = Resistance +type Reactance = Resistance + +$(mkUnit "Ohm" "Ω" ''Resistance 1) + +-- | Electric conductance quantity. Equal to +-- +-- @ Mass.^-1 .*. Length.^-2 .*. Time.^+3 .*. Current.^+2 @ +-- +type Conductance = NormalizeDim (Current ./. Voltage) + +$(mkUnit "Siemens" "S" ''Conductance 1) + +-- | Magnetic flux quantity. Equal to +-- +-- @ 'Mass' .*. 'Length'.^+2 .*. 'Time'.^-2 .*. 'Current'.^-1@ +-- +type MagneticFlux = NormalizeDim (Voltage .*. Time) + +$(mkUnit "Weber" "Wb" ''MagneticFlux 1) + +-- | Magnetic induction quantity. Equal to +-- +-- @ 'Mass' .*. 'Time'.^-2 .*. 'Current'.^-1@ +-- +type MagneticInduction = NormalizeDim (MagneticFlux ./. (Length .^+ 2)) +type MagneticFluxDensity = MagneticInduction + +$(mkUnit "Tesla" "T" ''MagneticInduction 1) + +-- | Inductance quantity. Equal to +-- +-- @ 'Mass' .*. 'Length'.^+2 .*. 'Time'.^-2 .*. 'Current'.^-2@ + +type Inductance = NormalizeDim (MagneticFlux ./. Current) + +$(mkUnit "Henry" "H" ''Inductance 1) + +-- | Thermodynamic temperature in Celsius degrees +-- +$(mkUnitNoFactor "Celsius" "°C" ''Temperature) + +instance Fractional a => ConversionFactor Celsius a where + factor = 1 + {-# INLINE factor #-} + +instance Fractional a => ConvertibleUnit Celsius a where + toBaseUnit (Celsius x) = Kelvin (x + 273.15) + {-# INLINE toBaseUnit #-} + + fromBaseUnit (Kelvin x) = Celsius (x - 273.15) + {-# INLINE fromBaseUnit #-} + +-- | Absorbed dose quantity. Equal to +-- +-- @ 'Length'.^+2 .*. 'Time'.^-2 @ +-- +type AbsorbedDose = NormalizeDim (Energy ./. Mass) +type EquivalentDose = AbsorbedDose + +-- | Absorbed dose in grays +-- +$(mkUnit "Gray" "Gy" ''AbsorbedDose 1) + +-- | Dose equivalent in sieverts +-- +$(mkUnit "Sievert" "Sv" ''EquivalentDose 1) + +-- | Catalytic activity quantity. Equal to +-- +-- @ 'Time'.^-1 .*. 'AmountOfSubstance' @ +-- +type CatalyticActivity = NormalizeDim (AmountOfSubstance ./. Time) + +-- | Catalytic activity in katal +-- +$(mkUnit "Katal" "kat" ''CatalyticActivity 1) diff --git a/src/Data/Units/SI/NonStd.hs b/src/Data/Units/SI/NonStd.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/NonStd.hs @@ -0,0 +1,24 @@ + + +-------------------------------------------------------------------------------- +-- | +-- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/NonStd/Angle.hs @@ -0,0 +1,54 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/Prefixes.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TemplateHaskell #-} + +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.Prefixes +-- Description : Prefixes of the International System of Units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-- Prefixes for the International System of Units (abbreviated SI). +-- +-------------------------------------------------------------------------------- + +module Data.Units.SI.Prefixes + ( Quecto (..) + , Ronto (..) + , Yocto (..) + , Zepto (..) + , Atto (..) + , Femto (..) + , Pico (..) + , Nano (..) + , Micro (..) + , Milli (..) + , Centi (..) + , Deci (..) + , Deca (..) + , Hecto (..) + , Kilo (..) + , Mega (..) + , Giga (..) + , Tera (..) + , Peta (..) + , Exa (..) + , Zetta (..) + , Yotta (..) + , Ronna (..) + , Quecca (..) + ) where + +import Data.Units.Base + +-- | SI prefix for 10⁻³⁰ +-- +$(mkPrefix "Quecto" "q" 1e-30) + +-- | SI prefix for 10⁻²⁷ +-- +$(mkPrefix "Ronto" "r" 1e-27) + +-- | SI prefix for 10⁻²⁴ +-- +$(mkPrefix "Yocto" "y" 1e-24) + +-- | SI prefix for 10⁻²¹ +-- +$(mkPrefix "Zepto" "z" 1e-21) + +-- | SI prefix for 10⁻¹⁸ +-- +$(mkPrefix "Atto" "a" 1e-18) + +-- | SI prefix for 10⁻¹⁵ +-- +$(mkPrefix "Femto" "f" 1e-15) + +-- | SI prefix for 10⁻¹² +-- +$(mkPrefix "Pico" "p" 1e-12) + +-- | SI prefix for 10⁻⁹ +-- +$(mkPrefix "Nano" "n" 1e-9) + +-- | SI prefix for 10⁻⁶ +-- +$(mkPrefix "Micro" "µ" 1e-6) + +-- | SI prefix for 10⁻³ +-- +$(mkPrefix "Milli" "m" 1e-3) + +-- | SI prefix for 10⁻² +-- +$(mkPrefix "Centi" "c" 1e-2) + +-- | SI prefix for 10⁻¹ +-- +$(mkPrefix "Deci" "d" 1e-1) + +-- | SI prefix for 10¹ +-- +$(mkPrefix "Deca" "da" 1e1) + +-- | SI prefix for 10² +-- +$(mkPrefix "Hecto" "h" 1e2) + +-- | SI prefix for 10³ +-- +$(mkPrefix "Kilo" "k" 1e3) + +-- | SI prefix for 10⁶ +-- +$(mkPrefix "Mega" "M" 1e6) + +-- | SI prefix for 10⁹ +-- +$(mkPrefix "Giga" "G" 1e9) + +-- | SI prefix for 10¹² +-- +$(mkPrefix "Tera" "T" 1e12) + +-- | SI prefix for 10¹⁵ +-- +$(mkPrefix "Peta" "P" 1e15) + +-- | SI prefix for 10¹⁸ +-- +$(mkPrefix "Exa" "E" 1e18) + +-- | SI prefix for 10²¹ +-- +$(mkPrefix "Zetta" "Z" 1e21) + +-- | SI prefix for 10²⁴ +-- +$(mkPrefix "Yotta" "Y" 1e24) + +-- | SI prefix for 10²⁷ +-- +$(mkPrefix "Ronna" "R" 1e27) + +-- | SI prefix for 10³⁰ +-- +$(mkPrefix "Quecca" "Q" 1e30) diff --git a/src/Data/Units/SI/System.hs b/src/Data/Units/SI/System.hs new file mode 100644 --- /dev/null +++ b/src/Data/Units/SI/System.hs @@ -0,0 +1,174 @@ +-------------------------------------------------------------------------------- +-- | +-- +-- Module : Data.Units.SI.System +-- Description : Base units and dimensions of the International System of Units +-- Copyright : (c) Alice Rixte 2025 +-- License : BSD 3 +-- Maintainer : alice.rixte@u-bordeaux.fr +-- Stability : stable +-- Portability : non-portable (GHC extensions) +-- +-- Base units and dimensions of the International System of Units (abbreviated +-- SI). +-- +-------------------------------------------------------------------------------- + +module Data.Units.SI.System + ( Mass (..) + , Gram (..) + , Length (..) + , Meter (..) + , Time (..) + , Second (..) + , Temperature (..) + , Kelvin (..) + , AmountOfSubstance (..) + , Mole (..) + , Current (..) + , Ampere (..) + , LuminousIntensity (..) + , Candela (..) + ) where + +import Data.Coerce +import Data.Units.Base +import Data.Units.SI.Prefixes + +-- +--------------------------------------+-----------------+ +-- | Dimension | Id | +-- +======================================+=================+ +-- | Reserved | 0 | +-- +======================================+=================+ +-- | @'NoDim'@ | 1 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.AngleSI.Angle.Angle'@ | 1000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.Mass'@ | 2000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.Length'@ | 3000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.Time'@ | 4000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.ElectricCurrent'@ | 5000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.Temperature'@ | 6000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.AmountOfSubstance'@ | 7000 | +-- +--------------------------------------+-----------------+ +-- | @'Data.Units.SI.LuminousIntensity'@ | 8000 | +-- +--------------------------------------+-----------------+ + +-- | The mass dimension, denotated @M@ in SI. +-- +-- This may contain a mass quantity with unspecified unit. +-- +$(mkDim "Mass" "M" 2000) + + +-- | A quantity in grams, denotated @g@ in SI. +-- +-- Notice that the base unit for the mass dimension is @'Kilo' 'Gram'@, not +-- @'Gram'@. +-- +-- This is correctly taken into account by this library: +-- +-- >>> from (Gram 8) +-- quantity @(Kilo Gram) 8.0e-3 +-- >>> :kind! BaseUnitOf Gram +-- BaseUnitOf Gram :: * -> * +-- = Kilo Gram +-- +$(mkUnitNoFactor "Gram" "g" ''Mass) + +instance Fractional a => ConvertibleUnit Gram a + +instance Fractional a => ConversionFactor Gram a where + factor = 1e-3 + {-# INLINE factor #-} + +instance IsDim Mass where + type DimToUnit Mass = Kilo Gram + +-- | The length dimension, denotated @L@ in SI. +-- +-- This may contain a length quantity with unspecified unit. +-- +$(mkDim "Length" "L" 3000) + +-- | A quantity in meters, denotated @m@ in SI. +-- +-- This is the base unit of the length dimension in the SI system. +-- +$(mkBaseUnit "Meter" "m" ''Length) + + +-- | The time dimension, denotated @T@ in SI. +-- +-- This may contain a length quantity with unspecified unit. +-- +$(mkDim "Time" "T" 4000) + + +-- | A quantity in seconds, denotated @s@ in SI. +-- +-- This is the base unit of the time dimension in the SI system. +-- +$(mkBaseUnit "Second" "s" ''Time) + +-- | The electric current dimension, denotated @I@ in SI. +-- +-- This may contain an electric current quantity with unspecified unit. +-- +$(mkDim "Current" "I" 5000) + + +-- | A quantity in amperes, denotated @A@ in SI. +-- +-- This is the base unit of the electric current dimension in the SI +-- system. +-- +$(mkBaseUnit "Ampere" "A" ''Current) + +-- | The thermodynamic temperature dimension, denotated @Θ@ in SI. +-- +-- This may contain a temperature quantity with unspecified unit. +-- +$(mkDim "Temperature" "Θ" 6000) + + +-- | A quantity in Kelvin, denotated @K@ in SI. +-- +-- This is the base unit of the thermodynamic temperature dimension in the SI +-- system. +-- +$(mkBaseUnit "Kelvin" "K" ''Temperature) + +-- | The amount of substance dimension, denotated @N@ in SI. +-- +-- This may contain an amount of substance quantity with unspecified unit. +-- +$(mkDim "AmountOfSubstance" "N" 7000) + + +-- | A quantity in moles, denotated @mol@ in SI. +-- +-- This is the base unit of the amount of substance dimension in the SI +-- system. +-- +$(mkBaseUnit "Mole" "mol" ''AmountOfSubstance) + + +-- | The luminous intensity dimension, denotated @J@ in SI. +-- +-- This may contain a luminous intensity quantity with unspecified unit. +-- +$(mkDim "LuminousIntensity" "J" 8000) + +-- | A quantity in candelas, denotated @cd@ in SI. +-- +-- This is the base unit of the luminous intensity dimension in the SI +-- system. +-- +$(mkBaseUnit "Candela" "cd" ''LuminousIntensity) + diff --git a/test/Data/Epsilon.hs b/test/Data/Epsilon.hs new file mode 100644 --- /dev/null +++ b/test/Data/Epsilon.hs @@ -0,0 +1,40 @@ +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/Units/Base/ArithmeticProp.hs b/test/Data/Units/Base/ArithmeticProp.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/Base/ArithmeticProp.hs @@ -0,0 +1,454 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Data/Units/Base/ConvertProp.hs @@ -0,0 +1,109 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Data/Units/BaseProp.hs @@ -0,0 +1,45 @@ +{-# 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/NonStd/AngleSpec.hs b/test/Data/Units/NonStd/AngleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonStd/AngleSpec.hs @@ -0,0 +1,30 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonStd/FrequencySpec.hs @@ -0,0 +1,17 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonStd/TemperatureSpec.hs @@ -0,0 +1,18 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Data/Units/NonStd/TimeSpec.hs @@ -0,0 +1,13 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Data/Units/SI/PrefixSpec.hs @@ -0,0 +1,85 @@ +module Data.Units.SI.PrefixSpec (spec) where + +import Test.Hspec + +import Data.Units + +import Data.Units.BaseProp + +spec :: Spec +spec = do + describe "Prefix" $ do + describe "Quecto" $ do + toFromSpec @(Quecto Meter) @Double + toFromSpec @(Quecto Meter .^- 1) @Double + describe "Ronto" $ do + toFromSpec @(Ronto Meter) @Double + toFromSpec @(Ronto Meter .^- 1) @Double + describe "Yocto" $ do + toFromSpec @(Yocto Meter) @Double + toFromSpec @(Yocto Meter .^- 1) @Double + describe "Zepto" $ do + toFromSpec @(Zepto Meter) @Double + toFromSpec @(Zepto Meter .^- 1) @Double + describe "Atto" $ do + toFromSpec @(Atto Meter) @Double + toFromSpec @(Atto Meter .^- 1) @Double + describe "Femto" $ do + toFromSpec @(Femto Meter) @Double + toFromSpec @(Femto Meter .^- 1) @Double + describe "Pico" $ do + toFromSpec @(Pico Meter) @Double + toFromSpec @(Pico Meter .^- 1) @Double + describe "Nano" $ do + toFromSpec @(Nano Meter) @Double + toFromSpec @(Nano Meter .^- 1) @Double + describe "Micro" $ do + toFromSpec @(Micro Meter) @Double + toFromSpec @(Micro Meter .^- 1) @Double + describe "Milli" $ do + toFromSpec @(Milli Meter) @Double + toFromSpec @(Milli Meter .^- 1) @Double + describe "Centi" $ do + toFromSpec @(Centi Meter) @Double + toFromSpec @(Centi Meter .^- 1) @Double + describe "Deci" $ do + toFromSpec @(Deci Meter) @Double + toFromSpec @(Deci Meter .^- 1) @Double + describe "Deca" $ do + toFromSpec @(Deca Meter) @Double + toFromSpec @(Deca Meter .^- 1) @Double + describe "Hecto" $ do + toFromSpec @(Hecto Meter) @Double + toFromSpec @(Hecto Meter .^- 1) @Double + describe "Kilo" $ do + fromToSpec @(Kilo Meter) @(Milli Meter) @Double + fromToSpec' @(Kilo Meter) @(Milli Meter) @Double + toFromSpec @(Kilo Meter) @Double + toFromSpec @(Kilo Meter .^- 1) @Double + describe "Mega" $ do + toFromSpec @(Mega Meter) @Double + toFromSpec @(Mega Meter .^- 1) @Double + describe "Giga" $ do + toFromSpec @(Giga Meter) @Double + toFromSpec @(Giga Meter .^- 1) @Double + describe "Tera" $ do + toFromSpec @(Tera Meter) @Double + toFromSpec @(Tera Meter .^- 1) @Double + describe "Peta" $ do + toFromSpec @(Peta Meter) @Double + toFromSpec @(Peta Meter .^- 1) @Double + describe "Exa" $ do + toFromSpec @(Exa Meter) @Double + toFromSpec @(Exa Meter .^- 1) @Double + describe "Zetta" $ do + toFromSpec @(Zetta Meter) @Double + toFromSpec @(Zetta Meter .^- 1) @Double + describe "Yotta" $ do + toFromSpec @(Yotta Meter) @Double + toFromSpec @(Yotta Meter .^- 1) @Double + describe "Ronna" $ do + toFromSpec @(Ronna Meter) @Double + toFromSpec @(Ronna Meter .^- 1) @Double + describe "Quecca" $ do + toFromSpec @(Quecca Meter) @Double + toFromSpec @(Quecca Meter .^- 1) @Double diff --git a/test/Data/Units/SI/SystemSpec.hs b/test/Data/Units/SI/SystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Units/SI/SystemSpec.hs @@ -0,0 +1,21 @@ +module Data.Units.SI.SystemSpec (spec) where + +import Test.Hspec + +import Data.Units + +import Data.Units.BaseProp + +spec :: Spec +spec = do + describe "Units" $ do + sameDimSpec @Meter @Double + toFromSpec @Gram @Double + toFromSpec @Meter @Double + toFromSpec @Second @Double + toFromSpec @Ampere @Double + toFromSpec @Kelvin @Double + toFromSpec @Mole @Double + toFromSpec @Candela @Double + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}