diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for `checked-literals` + +## 0.1.0.0 -- 2026-02-28 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2026, Martijn Bastiaan + +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. + +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,232 @@ +`checked-literals` is a GHC plugin that rewrites your programs such that you get a type error +whenever you use a literal that doesn't fit the target type. It works in any context, mono- +or polymorphic. It mostly makes sense in context of custom number types, such as +[clash-lang](https://clash-lang.org/)'s`Unsigned`, `Signed`, and `Index`. + +- [How to use](#how-to-use) +- [How it works](#how-it-works) + - [Integer Literals](#integer-literals) + - [Rational Literals](#rational-literals) + - [Examples](#examples) + - [Out-of-bound, positive literal in monomorphic context](#out-of-bound-positive-literal-in-monomorphic-context) + - [Out-of-bound, negative literal in monomorphic context](#out-of-bound-negative-literal-in-monomorphic-context) + - [Inexact rational literal in monomorphic context](#inexact-rational-literal-in-monomorphic-context) + - [Polymorphic rational context with `UFixed 0 f`](#polymorphic-rational-context-with-ufixed-0-f) + - [Polymorphic context](#polymorphic-context) + - [Polymorphic context with `Unsigned n`](#polymorphic-context-with-unsigned-n) +- [FAQ](#faq) + - [Why not rely on GHC's builtin warnings?](#why-not-rely-on-ghcs-builtin-warnings) + - [Couldn't you only insert for types you recognize?](#couldnt-you-only-insert-for-types-you-recognize) + - [Couldn't you write this as a core-to-core plugin?](#couldnt-you-write-this-as-a-core-to-core-plugin) + - [Couldn't you write this as a type-checker plugin?](#couldnt-you-write-this-as-a-type-checker-plugin) + - [Why not a warning?](#why-not-a-warning) + - [What about `Float`/`Double`?](#what-about-floatdouble) + +# How to use +Add `checked-literals` to your library's `build-depends` and `-fplugin=CheckedLiterals` to its +`ghc-options`, like this: + +```yaml +library + [..] + + build-depends: + [..] + checked-literals + + ghc-options: -fplugin=CheckedLiterals +``` + +# TODO +- [ ] Test in larger ecosystems (bittide?) +- [ ] Release on Hackage +- [ ] Implement in `clash-prelude` +- [ ] Investigate use of "if instance exist" hackery to get better error messages in completely polymorphic settings? (Low priority, IMO.) + +# How it works + +## Integer Literals +Every positive integer literal is rewritten as `checkedPositiveIntegerLiteral @lit lit` and every +negative integer literal is rewritten as `checkedNegativeIntegerLiteral @lit (-lit)`. The `checked` +functions themselves act as `id`, but insert a `Checked{Positive,Negative}IntegerLiteral lit a` +constraint where `a` is the type of the literal (possibly polymorphic). Every instance of +this class should insert a constraint that's checkable by the type checkers. For example, +an instance of `Word8` might look like: + +```haskell +instance (lit <= 255) => CheckedPositiveIntegerLiteral lit Word8 +``` + +## Rational Literals +Rational literals undergo a very similar rewrite, but use `CheckedPositiveRationalLiteral` and +`CheckedNegativeRationalLiteral` instead. This allows instances to reject both out-of-bounds +values and values that would require rounding. + +## Examples +### Out-of-bound, positive literal in monomorphic context +```haskell +x :: Word8 +x = 259 +``` + +```haskell +error: [GHC-64725] + • Literal 259 is out of bounds. + Word8 has bounds: [0 .. 255]. + Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check. + • In the expression: checkedPositiveIntegerLiteral @259 259 + In an equation for ‘exampleWord8’: + x = checkedPositiveIntegerLiteral @259 259 + | +9 | x = 259 + | ^^^ +``` + +### Out-of-bound, negative literal in monomorphic context +```haskell +x :: Word8 +x = -1 +``` + +```haskell +error: [GHC-64725] + • Negative literal -1 is out of bounds. + Word8 has bounds: [0 .. 255]. + Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check. + • In the expression: checkedNegativeIntegerLiteral @1 -1 + In an equation for ‘x’: + x = checkedNegativeIntegerLiteral @1 -1 + | +9 | x = -1 + | ^^ +``` + +### Inexact rational literal in monomorphic context +```haskell +x :: UFixed 0 1 +x = 0.75 +``` + +``` +error: [GHC-64725] + • Literal 0.75 cannot be represented exactly by Fixed + CheckedLiterals.Nums.Unsigned.Unsigned 0 1. + The fractional part needs at least 2 bit(s). + Possible fix: add a constraint: 2 <= 1. + Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check. + • In the expression: + CheckedLiterals.Class.Rational.checkedPositiveRationalLiteral + @"0.75" @3 @4 0.75 + In an equation for ‘x’: + x = CheckedLiterals.Class.Rational.checkedPositiveRationalLiteral + @"0.75" @3 @4 0.75 + | +6 | x = 0.75 + | ^^^^ +``` + +### Polymorphic rational context with `UFixed 0 f` +```haskell +x :: (KnownNat f, 1 <= f) => UFixed 0 f +x = 0.75 +``` + +``` +error: [GHC-64725] + • Literal 0.75 cannot be represented exactly by Fixed + CheckedLiterals.Nums.Unsigned.Unsigned 0 f. + The fractional part needs at least 2 bit(s). + Possible fix: add a constraint: 2 <= f. + Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check. + • In the expression: + CheckedLiterals.Class.Rational.checkedPositiveRationalLiteral + @"0.75" @3 @4 0.75 + In an equation for ‘x’: + x = CheckedLiterals.Class.Rational.checkedPositiveRationalLiteral + @"0.75" @3 @4 0.75 + | +6 | x = 0.75 + | ^^^^ +``` + +### Polymorphic context +```haskell +x :: Num a => a +x = -1 +``` + +``` +error: [GHC-39999] + • Could not deduce ‘CheckedNegativeIntegerLiteral 1 a’ + arising from a use of ‘checkedNegativeIntegerLiteral’ + from the context: Num a + bound by the type signature for: + x :: forall a. Num a => a + at examples.hs:8:1-15 + • In the expression: checkedNegativeIntegerLiteral @1 - 1 + In an equation for ‘x’: x = checkedNegativeIntegerLiteral @1 - 1 + | +9 | x = -1 + | ^^ +``` + +### Polymorphic context with `Unsigned n` +```haskell +x :: (4 <= n, KnownNat n) => Unsigned n +x = 255 +``` + +``` +error: [GHC-64725] + • Literal 255 is out of bounds. + Unsigned n has bounds: [0 .. (2 ^ n) - 1]. + Possible fix: add '8 <= n' to the context. + Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check. + • In the expression: checkedPositiveIntegerLiteral @255 255 + In an equation for ‘x’: x = checkedPositiveIntegerLiteral @255 255 + | +9 | x = 255 + | ^^^ +``` + +# FAQ +## Why not rely on GHC's builtin warnings? +GHC's builtin warnings work fine for builtin types when they're monomorphic: + +```haskell +ghci> x = -5 :: Word +:1:6: warning: [GHC-97441] [-Woverflowed-literals] + Literal -5 is out of the Word range 0..18446744073709551615 +``` + +But it's easy to (accidentally) work around: + +```haskell +ghci> x = -5 :: Num a => a +ghci> x :: Word +18446744073709551611 +``` + +More importantly, it doesn't work with custom numeric types, such as Clash's `Signed`, +`Unsigned`, and `Index`. + +## Couldn't you only insert for types you recognize? +Maybe, but you'd encounter the same issues as GHC's builtin system does. (See previous question.) + +## Couldn't you write this as a core-to-core plugin? +You can't insert constraints anymore, as type checking has already run. Yes, you could access +types and write your own solvers, but this would balloon the size of the plugin. More +importantly, it would bypass GHC's usual type checking behavior and user plugins, which +is bound to cause issues where GHC would usually approve/reject constraints, but the plugin +doesn't. + +## Couldn't you write this as a type-checker plugin? +Maybe in combination with other passes, but _just_ the type checkers don't have access to +term level literals. + +## Why not a warning? +Because there is no `TypeWarning` :-). + +## What about `Float`/`Double`? +`Float` and `Double` are supported for rational literals (e.g., `3.14`), however, truncation +is expected for these types. diff --git a/checked-literals.cabal b/checked-literals.cabal new file mode 100644 --- /dev/null +++ b/checked-literals.cabal @@ -0,0 +1,144 @@ +cabal-version: 3.4 +name: checked-literals +version: 0.1.0.0 +synopsis: GHC plugin for checked numeric literals +description: + GHC plugin that rewrites numeric literals so out-of-bounds and inexact + literals fail at compile time. + See the GitHub README for usage and examples: + + +homepage: https://github.com/clash-lang/checked-literals +bug-reports: https://github.com/clash-lang/checked-literals/issues +license: BSD-2-Clause +license-file: LICENSE +author: Martijn Bastiaan +maintainer: martijn@hmbastiaan.nl +category: Development +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +common warnings + ghc-options: -Wall + +common typechecker-plugins + build-depends: + ghc-typelits-extra >=0.5 && <0.6, + ghc-typelits-knownnat >=0.8 && <0.9, + ghc-typelits-natnormalise >=0.9 && <0.10, + + ghc-options: + -fplugin=GHC.TypeLits.KnownNat.Solver + -fplugin=GHC.TypeLits.Normalise + -fplugin=GHC.TypeLits.Extra.Solver + +common sane-records + default-extensions: + DisambiguateRecordFields + DuplicateRecordFields + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + +source-repository head + type: git + location: https://github.com/clash-lang/checked-literals.git + +library + import: warnings, typechecker-plugins, sane-records + exposed-modules: + CheckedLiterals + CheckedLiterals.Class + CheckedLiterals.Class.Integer + CheckedLiterals.Class.Rational + CheckedLiterals.Class.Rational.TypeNats + CheckedLiterals.Class.TemplateHaskell + CheckedLiterals.Plugin + CheckedLiterals.Unchecked + + other-modules: + Data.Ratio.Extra + + build-depends: + base >=4.18 && <5, + ghc >=9.6 && <9.15, + mtl >=2.2.2 && <2.4, + syb >=0.7 && <0.8, + template-haskell >=2.20 && <2.25, + + hs-source-dirs: src + default-language: GHC2021 + default-extensions: + DataKinds + NoStarIsType + TypeOperators + +-- XXX: These modules are just here to provide convincing tests for Clash-like types. They're +-- not tested well in any way, are incomplete in their implementation, and are certainly +-- not translatable to RTL. +library clash-nums + import: warnings, typechecker-plugins, sane-records + visibility: private + exposed-modules: + CheckedLiterals.Nums.Fixed + CheckedLiterals.Nums.Signed + CheckedLiterals.Nums.Unsigned + + build-depends: + base, + checked-literals, + template-haskell, + + hs-source-dirs: src-nums + default-language: GHC2021 + default-extensions: + DataKinds + NoStarIsType + TypeOperators + +test-suite unittests + import: warnings, typechecker-plugins, sane-records + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Data.Ratio.Extra + Test.Tasty.AssertGhc + Tests.Common + Tests.Integer + Tests.Integer.Case + Tests.Integer.Fixed + Tests.Integer.FunctionPattern + Tests.Integer.Int + Tests.Integer.Signed + Tests.Integer.Unsigned + Tests.Integer.Word + Tests.Rational + Tests.Rational.Case + Tests.Rational.Fixed + Tests.Rational.FunctionPattern + Tests.Rational.Ratio + + default-extensions: + DataKinds + NoStarIsType + TypeOperators + + build-depends: + base, + checked-literals, + checked-literals:clash-nums, + directory, + filepath, + process, + string-interpolate >=0.3.4.0, + tasty >=0.10, + tasty-hunit >=0.9, + temporary, + + hs-source-dirs: + tests + src + + default-language: GHC2021 diff --git a/src-nums/CheckedLiterals/Nums/Fixed.hs b/src-nums/CheckedLiterals/Nums/Fixed.hs new file mode 100644 --- /dev/null +++ b/src-nums/CheckedLiterals/Nums/Fixed.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module CheckedLiterals.Nums.Fixed ( + Fixed (..), + SFixed, + UFixed, +) where + +import CheckedLiterals ( + CheckedNegativeIntegerLiteral, + CheckedNegativeRationalLiteral, + CheckedPositiveIntegerLiteral, + CheckedPositiveRationalLiteral, + ) +import CheckedLiterals.Class.Rational.TypeNats (IsPowerOfTwo) +import CheckedLiterals.Nums.Signed (Signed (..)) +import CheckedLiterals.Nums.Unsigned (Unsigned (..)) +import Data.Bits (Bits (..), shiftL, shiftR, (.&.)) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (..)) +import Data.Ratio (denominator, numerator, (%)) +import Data.Type.Bool (If) +import GHC.TypeError (Assert, ErrorMessage (ShowType, Text, (:$$:), (:<>:)), TypeError) +import GHC.TypeLits (KnownNat, Nat, natVal, type Div, type (+), type (-), type (<=?), type (^)) +import GHC.TypeLits.Extra (CLog) + +{- | Fixed-point number + +Where: + +* @rep@ is the underlying representation (Signed or Unsigned) +* @int@ is the number of bits used to represent the integer part +* @frac@ is the number of bits used to represent the fractional part +-} +newtype Fixed (rep :: Nat -> Type) (int :: Nat) (frac :: Nat) + = Fixed {unFixed :: rep (int + frac)} + +{- | Signed fixed-point number with @int@ integer bits (including sign bit) +and @frac@ fractional bits +-} +type SFixed = Fixed Signed + +-- | Unsigned fixed-point number with @int@ integer bits and @frac@ fractional bits +type UFixed = Fixed Unsigned + +type PositiveSignedRationalRequiredIntBits (num :: Nat) (den :: Nat) = + CLog 2 (num + 1) + 1 - CLog 2 den + +type NegativeSignedRationalRequiredIntBits (num :: Nat) (den :: Nat) = + CLog 2 num + 1 - CLog 2 den + +type family FitsPositiveSignedRational (num :: Nat) (den :: Nat) (int :: Nat) :: Bool where + FitsPositiveSignedRational 0 den int = 'True + FitsPositiveSignedRational num den int = + PositiveSignedRationalRequiredIntBits num den <=? int + +type family FitsNegativeSignedRational (num :: Nat) (den :: Nat) (int :: Nat) :: Bool where + FitsNegativeSignedRational num den int = + NegativeSignedRationalRequiredIntBits num den <=? int + +instance (KnownNat frac, Integral (rep (int + frac))) => Show (Fixed rep int frac) where + show (Fixed fRep) = i ++ "." ++ fracStr + where + nF = fromInteger (natVal (Proxy @frac)) :: Int + fRepI = toInteger fRep + fRepI_abs = abs fRepI + i = + if fRepI < 0 + then '-' : show (fRepI_abs `shiftR` nF) + else show (fRepI `shiftR` nF) + nom = + if fRepI < 0 + then fRepI_abs .&. ((2 ^ nF) - 1) + else fRepI .&. ((2 ^ nF) - 1) + denom = 2 ^ nF + fracStr = padZeros nF (show (numerator r')) + where + r = nom % denom + -- Multiply by 10^nF to get decimal representation + r' = + iterate + ( \x -> + let n = numerator x * 10 + d = denominator x + in n % d + ) + r + !! nF + padZeros n str = replicate (n - length str) '0' ++ str + +instance (KnownNat frac, Integral (rep (int + frac)), Eq (rep (int + frac))) => Eq (Fixed rep int frac) where + Fixed a == Fixed b = a == b + +instance (KnownNat frac, Integral (rep (int + frac)), Ord (rep (int + frac))) => Ord (Fixed rep int frac) where + Fixed a `compare` Fixed b = a `compare` b + +-- | Num instance for Fixed - operations saturate on overflow +instance + ( KnownNat frac + , KnownNat int + , Integral (rep (int + frac)) + , Bounded (rep (int + frac)) + , Bits (rep (int + frac)) + ) => + Num (Fixed rep int frac) + where + Fixed a + Fixed b = Fixed (fromInteger sat) + where + res = toInteger a + toInteger b + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + + Fixed a * Fixed b = Fixed (fromInteger sat) + where + nF = fromInteger (natVal (Proxy @frac)) :: Int + res = (toInteger a * toInteger b) `shiftR` nF + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + + Fixed a - Fixed b = Fixed (fromInteger sat) + where + res = toInteger a - toInteger b + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + + negate (Fixed a) = Fixed (negate a) + + abs (Fixed a) = Fixed (abs a) + + signum (Fixed a) + | a == 0 = 0 + | a < 0 = -1 + | otherwise = 1 + + fromInteger i = Fixed (fromInteger sat) + where + nF = fromInteger (natVal (Proxy @frac)) :: Int + res = i `shiftL` nF + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + +-- | Fractional instance for Fixed - division and rational conversion +instance + ( KnownNat frac + , KnownNat int + , Integral (rep (int + frac)) + , Bounded (rep (int + frac)) + , Bits (rep (int + frac)) + ) => + Fractional (Fixed rep int frac) + where + Fixed a / Fixed b = Fixed (fromInteger sat) + where + nF = fromInteger (natVal (Proxy @frac)) :: Int + -- Shift numerator left by frac bits before division for precision + num = toInteger a `shiftL` nF + res = num `quot` toInteger b + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + + recip (Fixed a) = Fixed (fromInteger sat) + where + nF = fromInteger (natVal (Proxy @frac)) :: Int + -- 1.0 in fixed point is 1 << frac + one = 1 `shiftL` nF :: Integer + -- (1 << frac) / a in fixed point needs another shift + num = one `shiftL` nF + res = num `quot` toInteger a + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + + fromRational r = Fixed (fromInteger sat) + where + nF = fromInteger (natVal (Proxy @frac)) :: Int + n = numerator r `shiftL` (2 * nF) + d = denominator r `shiftL` nF + res = n `quot` d + maxB = toInteger (maxBound :: rep (int + frac)) + minB = toInteger (minBound :: rep (int + frac)) + sat = max minB (min maxB res) + +type PositiveUnsignedError strLit lit int typ maxVal = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'Text "Note: integer part needs at least " + ':<>: 'ShowType (CLog 2 (lit + 1)) + ':<>: 'Text " bit(s)." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 (lit + 1)) + ':<>: 'Text " <= " + ':<>: 'ShowType int + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + ( Assert + (If (lit <=? 0) (lit <=? 0) (CLog 2 (lit + 1) <=? int)) + (PositiveUnsignedError (ShowType lit) lit int (UFixed int frac) ((2 ^ int) - 1)) + ) => + CheckedPositiveIntegerLiteral lit (UFixed int frac) + +type NegativeUnsignedError strLit typ maxVal = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " is out of bounds, because UFixed cannot represent negative numbers." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + (NegativeUnsignedError ('Text "-" ':<>: 'ShowType lit) (UFixed int frac) ((2 ^ int) - 1)) => + CheckedNegativeIntegerLiteral lit (UFixed int frac) + +type FixedPointNotPow2Error strLit den typ = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " cannot be represented exactly by " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'Text "The reduced denominator " + ':<>: 'ShowType den + ':<>: 'Text " is not a power of 2." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +type FixedPointNotEnoughFracError strLit den frac typ = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " cannot be represented exactly by " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'Text "The fractional part needs at least " + ':<>: 'ShowType (CLog 2 den) + ':<>: 'Text " bit(s)." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 den) + ':<>: 'Text " <= " + ':<>: 'ShowType frac + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +type family + CheckFrac (isPow2 :: Bool) (strLit :: ErrorMessage) (den :: Nat) (frac :: Nat) (typ :: Type) :: + Constraint + where + CheckFrac 'False strLit den frac typ = FixedPointNotPow2Error strLit den typ + CheckFrac 'True strLit den frac typ = + Assert + (CLog 2 den <=? frac) + (FixedPointNotEnoughFracError strLit den frac typ) + +instance + ( CheckFrac (IsPowerOfTwo den) ('Text str) den frac (UFixed int frac) + , Assert + (If (Div num den <=? 0) (Div num den <=? 0) (CLog 2 (Div num den + 1) <=? int)) + (PositiveUnsignedError ('Text str) (Div num den) int (UFixed int frac) ((2 ^ int) - 1)) + ) => + CheckedPositiveRationalLiteral str num den (UFixed int frac) + +instance + (NegativeUnsignedError ('Text str) (UFixed int frac) ((2 ^ int) - 1)) => + CheckedNegativeRationalLiteral str num den (UFixed int frac) + +type PositiveSignedError strLit lit int typ = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'Text "Note: integer part needs at least " + ':<>: 'ShowType (CLog 2 (lit + 1) + 1) + ':<>: 'Text " bit(s), including sign bit." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 (lit + 1) + 1) + ':<>: 'Text " <= " + ':<>: 'ShowType int + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +type PositiveSignedRationalRangeError strLit num den int = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'Text "Note: integer part needs at least " + ':<>: 'ShowType (PositiveSignedRationalRequiredIntBits num den) + ':<>: 'Text " bit(s), including sign bit." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (PositiveSignedRationalRequiredIntBits num den) + ':<>: 'Text " <= " + ':<>: 'ShowType int + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + ( Assert + (If (lit <=? 0) (lit <=? 0) (CLog 2 (lit + 1) + 1 <=? int)) + (PositiveSignedError (ShowType lit) lit int (SFixed int frac)) + ) => + CheckedPositiveIntegerLiteral lit (SFixed int frac) + +type NegativeSignedError strLit lit int typ = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'Text "Note: integer part needs at least " + ':<>: 'ShowType (CLog 2 lit + 1) + ':<>: 'Text " bit(s), including sign bit." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 lit + 1) + ':<>: 'Text " <= " + ':<>: 'ShowType int + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +type NegativeSignedRationalRangeError strLit num den int = + TypeError + ( 'Text "Literal " + ':<>: strLit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'Text "Note: integer part needs at least " + ':<>: 'ShowType (NegativeSignedRationalRequiredIntBits num den) + ':<>: 'Text " bit(s), including sign bit." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (NegativeSignedRationalRequiredIntBits num den) + ':<>: 'Text " <= " + ':<>: 'ShowType int + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + ( Assert + (If (lit <=? 0) (lit <=? 0) (CLog 2 lit + 1 <=? int)) + (NegativeSignedError ('Text "-" ':<>: 'ShowType lit) lit int (SFixed int frac)) + ) => + CheckedNegativeIntegerLiteral lit (SFixed int frac) + +instance + ( CheckFrac (IsPowerOfTwo den) ('Text str) den frac (SFixed int frac) + , Assert + (FitsPositiveSignedRational num den int) + (PositiveSignedRationalRangeError ('Text str) num den int) + ) => + CheckedPositiveRationalLiteral str num den (SFixed int frac) + +instance + ( CheckFrac (IsPowerOfTwo den) ('Text str) den frac (SFixed int frac) + , Assert + (FitsNegativeSignedRational num den int) + (NegativeSignedRationalRangeError ('Text str) num den int) + ) => + CheckedNegativeRationalLiteral str num den (SFixed int frac) diff --git a/src-nums/CheckedLiterals/Nums/Signed.hs b/src-nums/CheckedLiterals/Nums/Signed.hs new file mode 100644 --- /dev/null +++ b/src-nums/CheckedLiterals/Nums/Signed.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module CheckedLiterals.Nums.Signed ( + Signed (..), +) where + +import CheckedLiterals ( + CheckedNegativeIntegerLiteral, + CheckedPositiveIntegerLiteral, + ) +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Proxy (Proxy (..)) +import Data.Type.Bool (type If) +import GHC.TypeError (Assert, ErrorMessage (ShowType, Text, (:$$:), (:<>:)), TypeError) +import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (-), type (<=?), type (^)) +import GHC.TypeLits.Extra (CLog) + +-- | Signed integer with @n@ bits (including sign bit) +newtype Signed (n :: Nat) = Signed Integer + deriving (Eq, Ord) + +instance (KnownNat n) => Show (Signed n) where + show = show . toInteger + +instance (KnownNat n) => Bounded (Signed n) where + minBound = + let n = natVal (Proxy @n) + in Signed $ + if n == 0 + then 0 + else negate (2 ^ (n - 1)) + maxBound = + let n = natVal (Proxy @n) + in Signed $ + if n == 0 + then 0 + else 2 ^ (n - 1) - 1 + +instance (KnownNat n) => Num (Signed n) where + Signed a + Signed b = fromInteger (a + b) + Signed a * Signed b = fromInteger (a * b) + Signed a - Signed b = fromInteger (a - b) + negate (Signed a) = fromInteger (negate a) + abs (Signed a) = fromInteger (abs a) + signum (Signed a) = fromInteger (signum a) + fromInteger i = + let s = Signed i' + Signed minB = minBound `asTypeOf` s + Signed maxB = maxBound `asTypeOf` s + i' + | i < minB = minB + | i > maxB = maxB + | otherwise = i + in s + +instance (KnownNat n) => Real (Signed n) where + toRational (Signed i) = toRational i + +instance (KnownNat n) => Enum (Signed n) where + toEnum = fromInteger . toInteger + fromEnum (Signed i) = fromInteger i + +instance (KnownNat n) => Integral (Signed n) where + quot (Signed a) (Signed b) = Signed (quot a b) + rem (Signed a) (Signed b) = Signed (rem a b) + div (Signed a) (Signed b) = Signed (div a b) + mod (Signed a) (Signed b) = Signed (mod a b) + quotRem (Signed a) (Signed b) = let (q, r) = quotRem a b in (Signed q, Signed r) + divMod (Signed a) (Signed b) = let (q, r) = divMod a b in (Signed q, Signed r) + toInteger (Signed i) = i + +instance (KnownNat n) => Bits (Signed n) where + Signed a .&. Signed b = fromInteger (a .&. b) + Signed a .|. Signed b = fromInteger (a .|. b) + Signed a `xor` Signed b = fromInteger (a `xor` b) + complement (Signed a) = fromInteger (complement a) + shift (Signed a) i = fromInteger (shift a i) + rotate = error "rotate not implemented for Signed" + bitSize _s = fromInteger (natVal (Proxy @n)) + bitSizeMaybe _s = Just (fromInteger (natVal (Proxy @n))) + isSigned _ = True + testBit (Signed a) i = testBit a i + bit i = fromInteger (bit i) + popCount (Signed a) = popCount a + +instance (KnownNat n) => FiniteBits (Signed n) where + finiteBitSize _ = fromInteger (natVal (Proxy @n)) + +type PositiveSignedError lit n typ minVal maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'ShowType lit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [-" + ':<>: 'ShowType minVal + ':<>: 'Text " .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 (lit + 1) + 1) + ':<>: 'Text " <= " + ':<>: 'ShowType n + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + ( Assert + (If (lit <=? 0) (lit <=? 0) (CLog 2 (lit + 1) + 1 <=? n)) + (PositiveSignedError lit n (Signed n) (2 ^ (n - 1)) ((2 ^ (n - 1)) - 1)) + ) => + CheckedPositiveIntegerLiteral lit (Signed n) + +type NegativeSignedError lit n typ minVal maxVal = + TypeError + ( 'Text "Literal -" + ':<>: 'ShowType lit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [-" + ':<>: 'ShowType minVal + ':<>: 'Text " .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 lit + 1) + ':<>: 'Text " <= " + ':<>: 'ShowType n + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + ( Assert + (If (lit <=? 0) (lit <=? 0) (CLog 2 lit + 1 <=? n)) + (NegativeSignedError lit n (Signed n) (2 ^ (n - 1)) ((2 ^ (n - 1)) - 1)) + ) => + CheckedNegativeIntegerLiteral lit (Signed n) diff --git a/src-nums/CheckedLiterals/Nums/Unsigned.hs b/src-nums/CheckedLiterals/Nums/Unsigned.hs new file mode 100644 --- /dev/null +++ b/src-nums/CheckedLiterals/Nums/Unsigned.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE UndecidableInstances #-} + +module CheckedLiterals.Nums.Unsigned ( + Unsigned (..), +) where + +import CheckedLiterals ( + CheckedNegativeIntegerLiteral, + CheckedPositiveIntegerLiteral, + NegativeUnsignedError, + ) +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Proxy (Proxy (..)) +import Data.Type.Bool (If) +import GHC.TypeError (Assert, ErrorMessage (ShowType, Text, (:$$:), (:<>:)), TypeError) +import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (-), type (<=?), type (^)) +import GHC.TypeLits.Extra (CLog) + +-- | Unsigned integer with @n@ bits +newtype Unsigned (n :: Nat) = Unsigned Integer + deriving (Eq, Ord) + +instance (KnownNat n) => Show (Unsigned n) where + show (Unsigned i) = show i + +instance (KnownNat n) => Bounded (Unsigned n) where + minBound = Unsigned 0 + maxBound = + let n = natVal (Proxy @n) + in Unsigned (2 ^ n - 1) + +instance (KnownNat n) => Num (Unsigned n) where + Unsigned a + Unsigned b = fromInteger (a + b) + Unsigned a * Unsigned b = fromInteger (a * b) + Unsigned a - Unsigned b = fromInteger (a - b) + negate (Unsigned a) = fromInteger (negate a) + abs u = u + signum (Unsigned 0) = 0 + signum _ = 1 + fromInteger i = + let u = Unsigned i' + Unsigned maxB = maxBound `asTypeOf` u + i' + | i < 0 = 0 + | i > maxB = maxB + | otherwise = i + in u + +instance (KnownNat n) => Real (Unsigned n) where + toRational (Unsigned i) = toRational i + +instance (KnownNat n) => Enum (Unsigned n) where + toEnum = fromInteger . toInteger + fromEnum (Unsigned i) = fromInteger i + +instance (KnownNat n) => Integral (Unsigned n) where + quot (Unsigned a) (Unsigned b) = Unsigned (quot a b) + rem (Unsigned a) (Unsigned b) = Unsigned (rem a b) + div (Unsigned a) (Unsigned b) = Unsigned (div a b) + mod (Unsigned a) (Unsigned b) = Unsigned (mod a b) + quotRem (Unsigned a) (Unsigned b) = let (q, r) = quotRem a b in (Unsigned q, Unsigned r) + divMod (Unsigned a) (Unsigned b) = let (q, r) = divMod a b in (Unsigned q, Unsigned r) + toInteger (Unsigned i) = i + +instance (KnownNat n) => Bits (Unsigned n) where + Unsigned a .&. Unsigned b = fromInteger (a .&. b) + Unsigned a .|. Unsigned b = fromInteger (a .|. b) + Unsigned a `xor` Unsigned b = fromInteger (a `xor` b) + complement (Unsigned a) = fromInteger (complement a) + shift (Unsigned a) i = fromInteger (shift a i) + rotate = error "rotate not implemented for Unsigned" + bitSize _ = fromInteger (natVal (Proxy @n)) + bitSizeMaybe _ = Just (fromInteger (natVal (Proxy @n))) + isSigned _ = False + testBit (Unsigned a) i = testBit a i + bit i = fromInteger (bit i) + popCount (Unsigned a) = popCount a + +instance (KnownNat n) => FiniteBits (Unsigned n) where + finiteBitSize _ = fromInteger (natVal (Proxy @n)) + +type PositiveUnsignedError lit n typ maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'ShowType lit + ':<>: 'Text " is (potentially) out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [0 .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: add a constraint: " + ':<>: 'ShowType (CLog 2 (lit + 1)) + ':<>: 'Text " <= " + ':<>: 'ShowType n + ':<>: 'Text "." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + ( Assert + (If (lit <=? 0) (lit <=? 0) (CLog 2 (lit + 1) <=? n)) + (PositiveUnsignedError lit n (Unsigned n) ((2 ^ n) - 1)) + ) => + CheckedPositiveIntegerLiteral lit (Unsigned n) + +instance + (NegativeUnsignedError lit (Unsigned n) ((2 ^ n) - 1)) => + CheckedNegativeIntegerLiteral lit (Unsigned n) diff --git a/src/CheckedLiterals.hs b/src/CheckedLiterals.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals.hs @@ -0,0 +1,9 @@ +module CheckedLiterals ( + plugin, + uncheckedLiteral, + module CheckedLiterals.Class, +) where + +import CheckedLiterals.Class +import CheckedLiterals.Plugin (plugin) +import CheckedLiterals.Unchecked (uncheckedLiteral) diff --git a/src/CheckedLiterals/Class.hs b/src/CheckedLiterals/Class.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Class.hs @@ -0,0 +1,7 @@ +module CheckedLiterals.Class ( + module CheckedLiterals.Class.Integer, + module CheckedLiterals.Class.Rational, +) where + +import CheckedLiterals.Class.Integer +import CheckedLiterals.Class.Rational diff --git a/src/CheckedLiterals/Class/Integer.hs b/src/CheckedLiterals/Class/Integer.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Class/Integer.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Type classes and helper functions for checked integer literals. +module CheckedLiterals.Class.Integer where + +import CheckedLiterals.Class.TemplateHaskell (maxBoundAsNat, minBoundAsNat) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeError (Assert, ErrorMessage (ShowType, Text, (:$$:), (:<>:)), TypeError) +import GHC.TypeNats (Nat, type (<=?)) +import Numeric.Natural (Natural) + +-- | Constraint used by the plugin to validate positive integer literals. +class CheckedPositiveIntegerLiteral (lit :: Nat) (a :: Type) + +instance CheckedPositiveIntegerLiteral lit Natural + +type PositiveUnsignedError lit typ maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'ShowType lit + ':<>: 'Text " is out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [0 .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_POSITIVE_UNSIGNED_INTEGER_INSTANCE(T) \ +instance \ + (Assert (lit <=? $(maxBoundAsNat @T)) (PositiveUnsignedError lit T $(maxBoundAsNat @T))) => \ + CheckedPositiveIntegerLiteral lit T + +CHECKED_POSITIVE_UNSIGNED_INTEGER_INSTANCE (Word) +CHECKED_POSITIVE_UNSIGNED_INTEGER_INSTANCE (Word8) +CHECKED_POSITIVE_UNSIGNED_INTEGER_INSTANCE (Word16) +CHECKED_POSITIVE_UNSIGNED_INTEGER_INSTANCE (Word32) +CHECKED_POSITIVE_UNSIGNED_INTEGER_INSTANCE (Word64) + +instance CheckedPositiveIntegerLiteral lit Integer + +type PositiveSignedError lit typ minVal maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'ShowType lit + ':<>: 'Text " is out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [-" + ':<>: 'ShowType minVal + ':<>: 'Text " .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_POSITIVE_SIGNED_INTEGER_INSTANCE(T) \ +instance \ + ( Assert \ + (lit <=? $(maxBoundAsNat @T)) \ + (PositiveSignedError lit T $(minBoundAsNat @T) $(maxBoundAsNat @T)) \ + ) => \ + CheckedPositiveIntegerLiteral lit T + +CHECKED_POSITIVE_SIGNED_INTEGER_INSTANCE (Int) +CHECKED_POSITIVE_SIGNED_INTEGER_INSTANCE (Int8) +CHECKED_POSITIVE_SIGNED_INTEGER_INSTANCE (Int16) +CHECKED_POSITIVE_SIGNED_INTEGER_INSTANCE (Int32) +CHECKED_POSITIVE_SIGNED_INTEGER_INSTANCE (Int64) + +-- Float/Double always round (or clamp to infinity) +instance CheckedPositiveIntegerLiteral lit Float +instance CheckedPositiveIntegerLiteral lit Double + +-- | Identity helper that attaches a positive integer literal check. +checkedPositiveIntegerLiteral :: (CheckedPositiveIntegerLiteral lit a) => a -> a +checkedPositiveIntegerLiteral = id + +-- | Constraint used by the plugin to validate negative integer literals. +class CheckedNegativeIntegerLiteral (lit :: Nat) (a :: Type) + +type NegativeNaturalError lit typ = + TypeError + ( 'Text "Literal -" + ':<>: 'ShowType lit + ':<>: 'Text " is out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [0 .. ∞]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance (NegativeNaturalError lit Natural) => CheckedNegativeIntegerLiteral lit Natural + +#define CHECKED_NEGATIVE_UNSIGNED_INTEGER_INSTANCE(T) \ +instance (NegativeUnsignedError lit T $(maxBoundAsNat @T)) => CheckedNegativeIntegerLiteral lit T + +type NegativeUnsignedError lit typ maxVal = + TypeError + ( 'Text "Literal -" + ':<>: 'ShowType lit + ':<>: 'Text " is out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [0 .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +CHECKED_NEGATIVE_UNSIGNED_INTEGER_INSTANCE (Word) +CHECKED_NEGATIVE_UNSIGNED_INTEGER_INSTANCE (Word8) +CHECKED_NEGATIVE_UNSIGNED_INTEGER_INSTANCE (Word16) +CHECKED_NEGATIVE_UNSIGNED_INTEGER_INSTANCE (Word32) +CHECKED_NEGATIVE_UNSIGNED_INTEGER_INSTANCE (Word64) + +instance CheckedNegativeIntegerLiteral lit Integer + +type NegativeSignedError lit typ minVal maxVal = + TypeError + ( 'Text "Literal -" + ':<>: 'ShowType lit + ':<>: 'Text " is out of bounds." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [-" + ':<>: 'ShowType minVal + ':<>: 'Text " .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_NEGATIVE_SIGNED_INTEGER_INSTANCE(T) \ +instance \ + ( Assert \ + (lit <=? $(minBoundAsNat @T)) \ + (NegativeSignedError lit T $(minBoundAsNat @T) $(maxBoundAsNat @T)) \ + ) => \ + CheckedNegativeIntegerLiteral lit T + +CHECKED_NEGATIVE_SIGNED_INTEGER_INSTANCE (Int) +CHECKED_NEGATIVE_SIGNED_INTEGER_INSTANCE (Int8) +CHECKED_NEGATIVE_SIGNED_INTEGER_INSTANCE (Int16) +CHECKED_NEGATIVE_SIGNED_INTEGER_INSTANCE (Int32) +CHECKED_NEGATIVE_SIGNED_INTEGER_INSTANCE (Int64) + +-- Float/Double always round (or clamp to infinity) +instance CheckedNegativeIntegerLiteral lit Float +instance CheckedNegativeIntegerLiteral lit Double + +-- | Identity helper that attaches a negative integer literal check. +checkedNegativeIntegerLiteral :: (CheckedNegativeIntegerLiteral lit a) => a -> a +checkedNegativeIntegerLiteral = id diff --git a/src/CheckedLiterals/Class/Rational.hs b/src/CheckedLiterals/Class/Rational.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Class/Rational.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Type classes and helper functions for checked rational literals. +module CheckedLiterals.Class.Rational where + +import CheckedLiterals.Class.TemplateHaskell (maxBoundAsNat, minBoundAsNat) +import Data.Fixed (E0, E1, E2, E3, E6, E9, Fixed) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Ratio (Ratio) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeError (Assert, ErrorMessage (ShowType, Text, (:$$:), (:<>:)), TypeError) +import GHC.TypeLits (Nat, Symbol, type Mod, type (<=?)) +import GHC.TypeNats (type (*)) +import Numeric.Natural (Natural) + +-- | Constraint used by the plugin to validate positive rational literals. +class + CheckedPositiveRationalLiteral + (literalAsString :: Symbol) + (numerator :: Nat) + (denominator :: Nat) + (a :: Type) + +instance CheckedPositiveRationalLiteral str num den Rational +instance CheckedPositiveRationalLiteral str num den (Ratio Natural) +instance CheckedPositiveRationalLiteral str num den Float +instance CheckedPositiveRationalLiteral str num den Double + +type FixedRoundingError str fixedType resolution = + TypeError + ( 'Text "Literal " + ':<>: 'ShowType str + ':<>: 'Text " requires rounding for " + ':<>: 'ShowType fixedType + ':<>: 'Text " (resolution 1/" + ':<>: 'ShowType resolution + ':<>: 'Text ")." + ':$$: 'Text "The literal cannot be represented exactly without rounding." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE(E, RES) \ +instance \ + ( Assert \ + ((Mod (num * RES) den) <=? 0) \ + (FixedRoundingError str (Fixed E) RES) \ + ) => \ + CheckedPositiveRationalLiteral str num den (Fixed E) + +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE (E0, 1) +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE (E1, 10) +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE (E2, 100) +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE (E3, 1_000) +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE (E6, 1_000_000) +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE (E9, 1_000_000_000) +CHECKED_POSITIVE_FIXED_RATIONAL_INSTANCE ((res :: Nat), res) + +-- | Identity helper that attaches a positive rational literal check. +checkedPositiveRationalLiteral :: (CheckedPositiveRationalLiteral fixed num den a) => a -> a +checkedPositiveRationalLiteral = id + +-- | Constraint used by the plugin to validate negative rational literals. +class CheckedNegativeRationalLiteral (str :: Symbol) (numerator :: Nat) (denominator :: Nat) (a :: Type) + +instance CheckedNegativeRationalLiteral str num den Rational +instance CheckedNegativeRationalLiteral str num den Float +instance CheckedNegativeRationalLiteral str num den Double + +#define CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE(E, RES) \ +instance \ + ( Assert \ + ((Mod (num * RES) den) <=? 0) \ + (FixedRoundingError str (Fixed E) RES) \ + ) => \ + CheckedNegativeRationalLiteral str num den (Fixed E) + +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE (E0, 1) +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE (E1, 10) +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE (E2, 100) +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE (E3, 1_000) +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE (E6, 1_000_000) +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE (E9, 1_000_000_000) +CHECKED_NEGATIVE_FIXED_RATIONAL_INSTANCE ((res :: Nat), res) + +-- | Identity helper that attaches a negative rational literal check. +checkedNegativeRationalLiteral :: (CheckedNegativeRationalLiteral fixed num den a) => a -> a +checkedNegativeRationalLiteral = id + +type PositiveUnsignedRatioNotRepresentable str num den typ maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'Text str + ':<>: 'Text " (" + ':<>: 'ShowType num + ':<>: 'Text " % " + ':<>: 'ShowType den + ':<>: 'Text ")" + ':<>: 'Text " cannot be represented by " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'Text "Make sure both the numerator and the denominator fit " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [0 .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_POSITIVE_UNSIGNED_RATIONAL_INSTANCE(T) \ +instance \ + ( Assert \ + (num <=? $(maxBoundAsNat @T)) \ + (PositiveUnsignedRatioNotRepresentable str num den T $(maxBoundAsNat @T)) \ + \ + , Assert \ + (den <=? $(maxBoundAsNat @T)) \ + (PositiveUnsignedRatioNotRepresentable str num den T $(maxBoundAsNat @T)) \ + ) => \ + CheckedPositiveRationalLiteral str num den (Ratio T) + +CHECKED_POSITIVE_UNSIGNED_RATIONAL_INSTANCE (Word) +CHECKED_POSITIVE_UNSIGNED_RATIONAL_INSTANCE (Word64) +CHECKED_POSITIVE_UNSIGNED_RATIONAL_INSTANCE (Word32) +CHECKED_POSITIVE_UNSIGNED_RATIONAL_INSTANCE (Word16) +CHECKED_POSITIVE_UNSIGNED_RATIONAL_INSTANCE (Word8) + +type PositiveSignedRatioNotRepresentable str num den typ minVal maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'Text str + ':<>: 'Text " (" + ':<>: 'ShowType num + ':<>: 'Text " % " + ':<>: 'ShowType den + ':<>: 'Text ")" + ':<>: 'Text " cannot be represented by " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'Text "Make sure both the numerator and the denominator fit " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [-" + ':<>: 'ShowType minVal + ':<>: 'Text " .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_POSITIVE_SIGNED_RATIONAL_INSTANCE(T) \ +instance \ + ( Assert \ + (num <=? $(maxBoundAsNat @T)) \ + (PositiveSignedRatioNotRepresentable str num den T $(minBoundAsNat @T) $(maxBoundAsNat @T)) \ + \ + , Assert \ + (den <=? $(maxBoundAsNat @T)) \ + (PositiveSignedRatioNotRepresentable str num den T $(minBoundAsNat @T) $(maxBoundAsNat @T)) \ + ) => \ + CheckedPositiveRationalLiteral str num den (Ratio T) + +CHECKED_POSITIVE_SIGNED_RATIONAL_INSTANCE (Int) +CHECKED_POSITIVE_SIGNED_RATIONAL_INSTANCE (Int64) +CHECKED_POSITIVE_SIGNED_RATIONAL_INSTANCE (Int32) +CHECKED_POSITIVE_SIGNED_RATIONAL_INSTANCE (Int16) +CHECKED_POSITIVE_SIGNED_RATIONAL_INSTANCE (Int8) + +type NegativeNaturalRatioNotRepresentable str num den typ = + TypeError + ( 'Text "Literal " + ':<>: 'Text str + ':<>: 'Text " (-" + ':<>: 'ShowType num + ':<>: 'Text " % " + ':<>: 'ShowType den + ':<>: 'Text ")" + ':<>: 'Text " cannot be represented by " + ':<>: 'ShowType (Ratio typ) + ':<>: 'Text "." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [0 .. ∞]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +instance + (NegativeNaturalRatioNotRepresentable str num den Natural) => + CheckedNegativeRationalLiteral str num den (Ratio Natural) + +type NegativeUnsignedRatioNotRepresentable str num den typ maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'Text str + ':<>: 'Text " cannot be represented by " + ':<>: 'ShowType (Ratio typ) + ':<>: 'Text "." + ':$$: 'ShowType typ + ':<>: 'Text " cannot represent negative numbers." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_NEGATIVE_UNSIGNED_RATIONAL_INSTANCE(T) \ +instance \ + (NegativeUnsignedRatioNotRepresentable str num den T $(maxBoundAsNat @T)) => \ + CheckedNegativeRationalLiteral str num den (Ratio T) + +CHECKED_NEGATIVE_UNSIGNED_RATIONAL_INSTANCE (Word) +CHECKED_NEGATIVE_UNSIGNED_RATIONAL_INSTANCE (Word64) +CHECKED_NEGATIVE_UNSIGNED_RATIONAL_INSTANCE (Word32) +CHECKED_NEGATIVE_UNSIGNED_RATIONAL_INSTANCE (Word16) +CHECKED_NEGATIVE_UNSIGNED_RATIONAL_INSTANCE (Word8) + +type NegativeSignedRatioNotRepresentable str num den typ minVal maxVal = + TypeError + ( 'Text "Literal " + ':<>: 'Text str + ':<>: 'Text " (-" + ':<>: 'ShowType num + ':<>: 'Text " % " + ':<>: 'ShowType den + ':<>: 'Text ")" + ':<>: 'Text " cannot be represented by " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'Text "Make sure both the numerator and the denominator fit " + ':<>: 'ShowType typ + ':<>: 'Text "." + ':$$: 'ShowType typ + ':<>: 'Text " has bounds: [-" + ':<>: 'ShowType minVal + ':<>: 'Text " .. " + ':<>: 'ShowType maxVal + ':<>: 'Text "]." + ':$$: 'Text "Possible fix: use 'uncheckedLiteral' from 'CheckedLiterals' to bypass this check." + ) + +#define CHECKED_NEGATIVE_SIGNED_RATIONAL_INSTANCE(T) \ +instance \ + ( Assert \ + (num <=? $(minBoundAsNat @T)) \ + (NegativeSignedRatioNotRepresentable str num den T $(minBoundAsNat @T) $(maxBoundAsNat @T)) \ + \ + , Assert \ + (den <=? $(maxBoundAsNat @T)) \ + (NegativeSignedRatioNotRepresentable str num den T $(minBoundAsNat @T) $(maxBoundAsNat @T)) \ + ) => \ + CheckedNegativeRationalLiteral str num den (Ratio T) + +CHECKED_NEGATIVE_SIGNED_RATIONAL_INSTANCE (Int) +CHECKED_NEGATIVE_SIGNED_RATIONAL_INSTANCE (Int64) +CHECKED_NEGATIVE_SIGNED_RATIONAL_INSTANCE (Int32) +CHECKED_NEGATIVE_SIGNED_RATIONAL_INSTANCE (Int16) +CHECKED_NEGATIVE_SIGNED_RATIONAL_INSTANCE (Int8) diff --git a/src/CheckedLiterals/Class/Rational/TypeNats.hs b/src/CheckedLiterals/Class/Rational/TypeNats.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Class/Rational/TypeNats.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Small type-level helpers used by rational literal checks. +module CheckedLiterals.Class.Rational.TypeNats where + +import Data.Type.Bool (If) +import GHC.TypeLits + +-- | Type-level predicate that checks whether a natural is a power of two. +type family IsPowerOfTwo (n :: Nat) :: Bool where + IsPowerOfTwo 0 = 'False + IsPowerOfTwo 1 = 'True + IsPowerOfTwo n = If (Mod n 2 <=? 0) (IsPowerOfTwo (Div n 2)) 'False diff --git a/src/CheckedLiterals/Class/TemplateHaskell.hs b/src/CheckedLiterals/Class/TemplateHaskell.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Class/TemplateHaskell.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Template Haskell helpers used to derive type-level bounds. +module CheckedLiterals.Class.TemplateHaskell where + +import Data.Typeable (Proxy (Proxy), Typeable, typeRep) +import Language.Haskell.TH (Q, Type, litT, numTyLit) + +-- | Reify a type's @maxBound@ as a type-level natural. +maxBoundAsNat :: forall a. (Bounded a, Typeable a, Integral a) => Q Type +maxBoundAsNat + | theMaxBound >= 0 = litT (numTyLit theMaxBound) + | otherwise = + fail $ + "The type " + ++ show (typeRep (Proxy @a)) + ++ " has a negative maxBound, so it cannot be used with CheckedLiterals. The maxBound is " + ++ show theMaxBound + ++ "." + where + theMaxBound = toInteger (maxBound :: a) + +-- | Reify the absolute value of a type's non-positive @minBound@ as a type-level natural. +minBoundAsNat :: forall a. (Bounded a, Integral a, Typeable a) => Q Type +minBoundAsNat + | theMinBound <= 0 = litT (numTyLit (-theMinBound)) + | otherwise = + fail $ + "The type " + ++ show (typeRep (Proxy @a)) + ++ " has a positive, non-zero minBound, so it cannot be used with CheckedLiterals. The minBound is " + ++ show theMinBound + ++ "." + where + theMinBound = toInteger (minBound :: a) diff --git a/src/CheckedLiterals/Plugin.hs b/src/CheckedLiterals/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Plugin.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module CheckedLiterals.Plugin (plugin) where + +import GHC.Hs +import Prelude + +import Control.Monad.Reader (Reader, ask, runReader) +import Data.Generics (Data, extM, gmapM) +import Data.Ratio.Extra qualified as RatioExtra +import GHC.Iface.Env (lookupOrig) +import GHC.Plugins hiding (rational, (<>)) +import GHC.Tc.Types (TcGblEnv, TcM) +import GHC.Tc.Utils.Monad (getTopEnv) +import GHC.Types.SourceText ( + SourceText (NoSourceText, SourceText), + il_value, + ) + +import CheckedLiterals.Class.Integer ( + checkedNegativeIntegerLiteral, + checkedPositiveIntegerLiteral, + ) +import CheckedLiterals.Class.Rational ( + checkedNegativeRationalLiteral, + checkedPositiveRationalLiteral, + ) +import CheckedLiterals.Unchecked (uncheckedLiteral) +import Data.Ratio qualified as Ratio +import GHC.Types.SourceText qualified as SourceText +import Language.Haskell.TH qualified as TH + +data HelperNames = HelperNames + { checkedPositiveIntegerLiteralName :: Name + , checkedNegativeIntegerLiteralName :: Name + , checkedPositiveRationalLiteralName :: Name + , checkedNegativeRationalLiteralName :: Name + , uncheckedLiteralName :: Name + } + +type TransformM = Reader HelperNames + +-- | The GHC plugin entry point +plugin :: Plugin +plugin = + defaultPlugin + { renamedResultAction = renamedPlugin + , pluginRecompile = purePlugin + } + +-- | Rewrite numeric literals after renaming, using exact Names for helper detection. +renamedPlugin :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) +renamedPlugin _opts tcGblEnv hsGroup = do + helperNames <- loadHelperNames + let transformedGroup = runReader (transformHsGroup hsGroup) helperNames + pure (tcGblEnv, transformedGroup) + +-- | Top-down traversal of HsGroup, transforming expressions and patterns. +transformHsGroup :: HsGroup GhcRn -> TransformM (HsGroup GhcRn) +transformHsGroup hsGroup = gmapM transformData hsGroup + +transformData :: (Data a) => a -> TransformM a +transformData = + gmapM transformData + `extM` transformLHsExpr + `extM` transformLPat + +loadHelperNames :: TcM HelperNames +loadHelperNames = do + let lookupHelper quotedName = do + helperModule <- lookupHelperModule (quotedNameModuleName quotedName) + lookupOrig helperModule (mkVarOcc (TH.nameBase quotedName)) + HelperNames + <$> lookupHelper 'checkedPositiveIntegerLiteral + <*> lookupHelper 'checkedNegativeIntegerLiteral + <*> lookupHelper 'checkedPositiveRationalLiteral + <*> lookupHelper 'checkedNegativeRationalLiteral + <*> lookupHelper 'uncheckedLiteral + +lookupHelperModule :: ModuleName -> TcM Module +lookupHelperModule moduleName = do + hscEnv <- getTopEnv + case lookupModuleWithSuggestions (hsc_units hscEnv) moduleName NoPkgQual of + LookupFound foundModule _ -> pure foundModule + _ -> panic "CheckedLiterals.Plugin: failed to resolve helper module" + +quotedNameModuleName :: TH.Name -> ModuleName +quotedNameModuleName name = + case TH.nameModule name of + Just moduleName -> mkModuleName moduleName + Nothing -> + panic $ + "CheckedLiterals.Plugin: quoted helper name is missing a module: " + ++ TH.pprint name + +-- | Transform a located expression using top-down traversal. +transformLHsExpr :: LHsExpr GhcRn -> TransformM (LHsExpr GhcRn) +transformLHsExpr lexpr@(L loc expr) = do + helperNames <- ask + case expr of + -- Check if this is an application to our checked literal functions. If so, stop recursing + -- to avoid double transformation. + HsApp _ fun _ | isCheckedLiteralApp helperNames (unLoc fun) -> return lexpr + -- Handle negation of fractional literals: detect (negate 3.14) patterns + NegApp _ (L _ (HsOverLit _ OverLit{ol_val = HsFractional fracLit})) _ -> do + let + rational = negate (SourceText.rationalFromFractionalLit fracLit) + transformedExpr = + makeCheckedRationalLiteral + helperNames + expr + (fractionalLiteralDisplayText rational fracLit) + rational + return (L loc transformedExpr) + + -- Handle negation of integer literals: detect (negate literal) patterns + NegApp _ (L _ (HsOverLit _ OverLit{ol_val = HsIntegral intLit})) _ -> do + let + value = il_value intLit + transformedExpr = makeCheckedLiteral helperNames expr (negate value) + return (L loc transformedExpr) + + -- Transform positive fractional literals + HsOverLit _ OverLit{ol_val = HsFractional fracLit} -> do + let rational = SourceText.rationalFromFractionalLit fracLit + return $ + L loc $ + makeCheckedRationalLiteral + helperNames + expr + (fractionalLiteralDisplayText rational fracLit) + rational + + -- Transform positive integer literals + HsOverLit _ OverLit{ol_val = HsIntegral intLit} -> do + let value = il_value intLit + return $ L loc $ makeCheckedLiteral helperNames expr value + + -- For all other expressions, recurse into children (top-down) + _ -> L loc <$> gmapM transformData expr + +-- | Transform any located pattern, regardless of context. +transformLPat :: LPat GhcRn -> TransformM (LPat GhcRn) +transformLPat lpat@(L loc pat) = do + helperNames <- ask + case pat of + ViewPat _ viewExpr _ + | isCheckedLiteralApp helperNames (unLoc viewExpr) -> + pure lpat + NPat _ overLit negation _ + | Just viewExpr <- makeCheckedPatternViewExpr helperNames (unLoc overLit) negation -> + pure (L loc (ViewPat mkViewPatExt (noLocA viewExpr) lpat)) + _ -> L loc <$> gmapM transformPatData pat + +transformPatData :: (Data a) => a -> TransformM a +transformPatData = + gmapM transformPatData + `extM` transformLPat + `extM` transformLHsExpr + +makeCheckedPatternViewExpr :: + HelperNames -> + HsOverLit GhcRn -> + Maybe (SyntaxExpr GhcRn) -> + Maybe (HsExpr GhcRn) +makeCheckedPatternViewExpr helperNames overLit negation = + case overLit.ol_val of + HsIntegral intLit -> + let value = applyPatternNegation negation (il_value intLit) + in Just (makeCheckedLiteralFunction helperNames value) + HsFractional fracLit -> + let rational = applyPatternNegation negation (SourceText.rationalFromFractionalLit fracLit) + in Just + ( makeCheckedRationalLiteralFunction + helperNames + (fractionalLiteralDisplayText rational fracLit) + rational + ) + HsIsString _ _ -> Nothing + +applyPatternNegation :: (Num a) => Maybe b -> a -> a +applyPatternNegation Nothing value = value +applyPatternNegation (Just _) value = negate value + +mkViewPatExt :: XViewPat GhcRn +mkViewPatExt = Nothing + +#if MIN_VERSION_ghc(9,8,0) +unpackFSCompat :: FastString -> String +unpackFSCompat = unpackFS +#else +unpackFSCompat :: String -> String +unpackFSCompat = id +#endif + +fractionalLiteralDisplayText :: Rational -> SourceText.FractionalLit -> String +fractionalLiteralDisplayText rational fracLit = + case SourceText.fl_text fracLit of + SourceText sourceText -> + let sourceTextStr = unpackFSCompat sourceText + in case sourceTextStr of + '-' : _ -> sourceTextStr + _ | rational < 0 -> '-' : sourceTextStr + _ -> sourceTextStr + NoSourceText -> + RatioExtra.showFixedPoint rational + +{- FOURMOLU_DISABLE -} +-- | Check if an expression is an application to one of our checked literal functions +isCheckedLiteralApp :: HelperNames -> HsExpr GhcRn -> Bool +isCheckedLiteralApp helperNames expr = case expr of + -- Direct reference to checked literal function + HsVar _ name -> isCheckedLiteralName helperNames (getNameFromLocatedOcc name) + -- Parentheses do not change helper identity. +#if MIN_VERSION_ghc(9,10,0) + HsPar _ innerExpr -> isCheckedLiteralApp helperNames (unLoc innerExpr) +#else + HsPar _ _ innerExpr _ -> isCheckedLiteralApp helperNames (unLoc innerExpr) +#endif + -- Type application to checked literal function, e.g.: checkedPositiveIntegerLiteral @N +#if MIN_VERSION_ghc(9,10,0) + HsAppType _ funExpr _ -> isCheckedLiteralApp helperNames (unLoc funExpr) +#else + HsAppType _ funExpr _ _ -> isCheckedLiteralApp helperNames (unLoc funExpr) +#endif + _ -> False +{- FOURMOLU_ENABLE -} + +-- | Check if a name is one of our checked literal functions or uncheckedLiteral +isCheckedLiteralName :: HelperNames -> Name -> Bool +isCheckedLiteralName helperNames name = + name == helperNames.checkedPositiveIntegerLiteralName + || name == helperNames.checkedNegativeIntegerLiteralName + || name == helperNames.checkedPositiveRationalLiteralName + || name == helperNames.checkedNegativeRationalLiteralName + || name == helperNames.uncheckedLiteralName + +#if MIN_VERSION_ghc(9,14,0) +getNameFromLocatedOcc :: LIdOccP GhcRn -> Name +getNameFromLocatedOcc = unLocWithUserRdr +#else +getNameFromLocatedOcc :: LIdP GhcRn -> Name +getNameFromLocatedOcc = unLoc +#endif + +#if MIN_VERSION_ghc(9,14,0) +mkLocatedOcc :: Name -> LIdOccP GhcRn +mkLocatedOcc = noLocA . noUserRdr +#else +mkLocatedOcc :: Name -> LIdP GhcRn +mkLocatedOcc = noLocA +#endif + +-- | Build the expression, e.g.: checkedPositiveIntegerLiteral @N e +makeCheckedLiteral :: HelperNames -> HsExpr GhcRn -> Integer -> HsExpr GhcRn +makeCheckedLiteral helperNames expr value = fullApp + where + withTypeApp = makeCheckedLiteralFunction helperNames value +#if MIN_VERSION_ghc(9,10,0) + fullApp = HsApp noExtField (noLocA withTypeApp) (noLocA expr) +#else + fullApp = HsApp noAnn (noLocA withTypeApp) (noLocA expr) +#endif + +makeCheckedLiteralFunction :: HelperNames -> Integer -> HsExpr GhcRn +makeCheckedLiteralFunction helperNames value = withTypeApp + where + funcName + | value >= 0 = helperNames.checkedPositiveIntegerLiteralName + | otherwise = helperNames.checkedNegativeIntegerLiteralName + funcVar = noLocA (HsVar noExtField (mkLocatedOcc funcName)) + tyLit = HsNumTy NoSourceText (abs value) +#if MIN_VERSION_ghc(9,10,0) + typeArg = HsWC [] (noLocA (HsTyLit noExtField tyLit)) + withTypeApp = HsAppType noExtField funcVar typeArg +#else + typeArg = HsWC [] (noLocA (HsTyLit noExtField tyLit)) + atToken = L NoTokenLoc (HsTok @"@") + withTypeApp = HsAppType noExtField funcVar atToken typeArg +#endif + +{- | Build the expression for rational literals, e.g.: +checkedPositiveRationalLiteral @"3.14" @314 @100 (3.14) +-} +makeCheckedRationalLiteral :: HelperNames -> HsExpr GhcRn -> String -> Rational -> HsExpr GhcRn +makeCheckedRationalLiteral helperNames expr stringRepr rational = fullApp + where + withAllTypeApps = makeCheckedRationalLiteralFunction helperNames stringRepr rational +#if MIN_VERSION_ghc(9,10,0) + fullApp = HsApp noExtField (noLocA withAllTypeApps) (noLocA expr) +#else + fullApp = HsApp noAnn (noLocA withAllTypeApps) (noLocA expr) +#endif + +makeCheckedRationalLiteralFunction :: HelperNames -> String -> Rational -> HsExpr GhcRn +makeCheckedRationalLiteralFunction helperNames stringRepr rational = withAllTypeApps + where + funcName + | rational >= 0 = helperNames.checkedPositiveRationalLiteralName + | otherwise = helperNames.checkedNegativeRationalLiteralName + funcVar = noLocA (HsVar noExtField (mkLocatedOcc funcName)) + + -- Type-level literals + strTyLit = HsStrTy NoSourceText (mkFastString stringRepr) + numTyLit = HsNumTy NoSourceText (abs (Ratio.numerator rational)) + denTyLit = HsNumTy NoSourceText (abs (Ratio.denominator rational)) +#if MIN_VERSION_ghc(9,10,0) + strTypeArg = HsWC [] (noLocA (HsTyLit noExtField strTyLit)) + numTypeArg = HsWC [] (noLocA (HsTyLit noExtField numTyLit)) + denTypeArg = HsWC [] (noLocA (HsTyLit noExtField denTyLit)) + withStrTypeApp = HsAppType noExtField funcVar strTypeArg + withNumTypeApp = HsAppType noExtField (noLocA withStrTypeApp) numTypeArg + withAllTypeApps = HsAppType noExtField (noLocA withNumTypeApp) denTypeArg +#else + strTypeArg = HsWC [] (noLocA (HsTyLit noExtField strTyLit)) + numTypeArg = HsWC [] (noLocA (HsTyLit noExtField numTyLit)) + denTypeArg = HsWC [] (noLocA (HsTyLit noExtField denTyLit)) + atToken = L NoTokenLoc (HsTok @"@") + withStrTypeApp = HsAppType noExtField funcVar atToken strTypeArg + withNumTypeApp = HsAppType noExtField (noLocA withStrTypeApp) atToken numTypeArg + withAllTypeApps = HsAppType noExtField (noLocA withNumTypeApp) atToken denTypeArg +#endif diff --git a/src/CheckedLiterals/Unchecked.hs b/src/CheckedLiterals/Unchecked.hs new file mode 100644 --- /dev/null +++ b/src/CheckedLiterals/Unchecked.hs @@ -0,0 +1,5 @@ +module CheckedLiterals.Unchecked (uncheckedLiteral) where + +-- | Identity function used to opt a single literal out of checking. +uncheckedLiteral :: a -> a +uncheckedLiteral = id diff --git a/src/Data/Ratio/Extra.hs b/src/Data/Ratio/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ratio/Extra.hs @@ -0,0 +1,32 @@ +module Data.Ratio.Extra where + +import Data.Ratio qualified as Ratio + +{- | Show a 'Rational' in fixed-point notation, without using scientific notation. + +>>> showFixedPoint (1 % 2) +"0.5" +>>> showFixedPoint (-0.1) +"-0.1" +>>> showFixedPoint 10 +"10.0" +>>> showFixedPoint 1.154646000 +"1.154646" +-} +showFixedPoint :: Rational -> String +showFixedPoint rational + | numerator < 0 = "-" <> result + | otherwise = result + where + result = show whole <> "." <> concat (go0 fractional) + (whole, fractional) = abs numerator `quotRem` denominator + numerator = Ratio.numerator rational + denominator = Ratio.denominator rational + + go0 0 = ["0"] + go0 i = go1 i + + go1 0 = [] + go1 i = show w : go1 f + where + (w, f) = (10 * i) `quotRem` denominator diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,23 @@ +module Main where + +import Data.Proxy +import Test.Tasty +import Test.Tasty.AssertGhc (DebugGhc (..)) +import Test.Tasty.Options +import Prelude + +import Tests.Integer qualified +import Tests.Rational qualified + +tests :: TestTree +tests = + testGroup + "Tests" + [ Tests.Integer.tests + , Tests.Rational.tests + ] + +main :: IO () +main = defaultMainWithIngredients ingredients tests + where + ingredients = includingOptions [Option (Proxy :: Proxy DebugGhc)] : defaultIngredients diff --git a/tests/Test/Tasty/AssertGhc.hs b/tests/Test/Tasty/AssertGhc.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Tasty/AssertGhc.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP #-} + +module Test.Tasty.AssertGhc where + +import Prelude + +import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) +import System.Environment (lookupEnv) +import System.Exit +import System.IO +import System.IO.Temp +import System.Process +import Test.Tasty (TestTree, askOption) +import Test.Tasty.HUnit +import Test.Tasty.Options +import Text.Read (readMaybe) + +data Expected = ExpectFailure [String] | ExpectSuccess + +-- | Option to enable debug output of GHC error messages +newtype DebugGhc = DebugGhc Bool + deriving (Show, Read) + +instance IsOption DebugGhc where + defaultValue = DebugGhc False + parseValue = fmap DebugGhc . readMaybe + optionName = return "debug-ghc" + optionHelp = return "Print full GHC output for error test cases" + optionCLParser = flagCLParser Nothing (DebugGhc True) + +testCaseGhc :: String -> String -> Expected -> TestTree +testCaseGhc name source expected = + askOption $ \(DebugGhc debugGhc) -> + testCaseInfo name $ do + debugOutput <- assertGhc source expected + if debugGhc then return debugOutput else return "" + +{- | Assert that a Haskell code snippet fails to compile with expected error messages +Returns the GHC output for display in test results if debug flag is set +-} +assertGhc :: String -> Expected -> IO String +assertGhc source expected = do + -- XXX: This will pick the wrong GHC if the HC environment variable (as seen on CI) + -- isn't set and the test suite is compiled with a GHC compiler other than the + -- system's default. + hc <- fromMaybe "ghc" <$> lookupEnv "HC" + withSystemTempFile "ShouldError.hs" $ \tempFile tempHandle -> do + -- Write source with proper Main module structure + hPutStr tempHandle "module Main where\n" + hPutStr tempHandle source + hPutStr tempHandle "\nmain :: IO ()\nmain = return ()\n" + hClose tempHandle + (exitCode, _, stderrOutput) <- + readProcessWithExitCode + hc + [ "-XCPP" + , "-XDataKinds" + , "-XTypeOperators" + , "-XTypeApplications" + , "-XTypeFamilies" + , "-XUndecidableInstances" + , "-XNoStarIsType" + , "-XViewPatterns" + , "-XNoImplicitPrelude" + , "-fno-code" + , "-fplugin=GHC.TypeLits.KnownNat.Solver" + , "-fplugin=GHC.TypeLits.Normalise" + , "-fplugin=GHC.TypeLits.Extra.Solver" + , "-fplugin=CheckedLiterals" + , tempFile + ] + "" + case (exitCode, expected) of + (ExitSuccess, ExpectSuccess) -> + return "" + (ExitSuccess, ExpectFailure _) -> + assertFailure "Expected compilation to fail but it succeeded" >> return "" + (ExitFailure _, ExpectSuccess) -> + assertFailure ("Expected compilation to succeed but it failed with error:\n" ++ stderrOutput) + >> return "" + (ExitFailure _, ExpectFailure expectedErrors) -> + let cleanedStderr = removeProblemChars stderrOutput + cleanedExpected = map removeProblemChars expectedErrors + in if all (`isInfixOf` cleanedStderr) cleanedExpected + then return stderrOutput + else do + _ <- + assertFailure $ + "Error message mismatch:\n" + ++ "Expected substrings: " + ++ show expectedErrors + ++ "\n" + ++ "Actual output:\n" + ++ stderrOutput + return stderrOutput + +{- | Remove problematic characters that vary depending on locale +The kind and amount of quotes in GHC error messages changes depending on +whether or not our locale supports unicode. +-} +removeProblemChars :: String -> String +removeProblemChars = filter (`notElem` problemChars) + where + problemChars = "‘’`'" diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Common.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Tests.Common where + +import Data.String.Interpolate (__i) +import Test.Tasty (TestTree) +import Test.Tasty.AssertGhc (Expected (..), testCaseGhc) + +toTestCases :: [(String, String, String, [String])] -> [TestTree] +toTestCases = map toTestCase + +toTestCase :: (String, String, String, [String]) -> TestTree +toTestCase (moduleName, typeName, literal, expectedErrors) = + testCaseGhc + ((if null expectedErrors then "OK , " else "NOK, ") ++ typeName ++ ", " ++ literal) + [__i| + import Prelude + import #{moduleName} + import GHC.TypeNats + test :: #{typeName} + test = #{literal} + |] + ( if null expectedErrors + then ExpectSuccess + else ExpectFailure expectedErrors + ) + +toCaseTestCases :: [(String, String, String, [String])] -> [TestTree] +toCaseTestCases = map toCaseTestCase + +toCaseTestCase :: (String, String, String, [String]) -> TestTree +toCaseTestCase (moduleName, typeName, literal, expectedErrors) = + testCaseGhc + ((if null expectedErrors then "OK , " else "NOK, ") ++ typeName ++ ", case " ++ literal) + [__i| + import Prelude + import #{moduleName} + import GHC.TypeNats + import CheckedLiterals + test :: #{typeName} + test = case 0 of + (#{literal} :: (#{typeName})) -> 0 + _ -> 0 + |] + ( if null expectedErrors + then ExpectSuccess + else ExpectFailure expectedErrors + ) + +toFunctionPatternTestCases :: [(String, String, String, [String])] -> [TestTree] +toFunctionPatternTestCases = map toFunctionPatternTestCase + +toFunctionPatternTestCase :: (String, String, String, [String]) -> TestTree +toFunctionPatternTestCase (moduleName, typeName, literal, expectedErrors) = + testCaseGhc + ((if null expectedErrors then "OK , " else "NOK, ") ++ typeName ++ ", function " ++ literal) + [__i| + import Prelude + import #{moduleName} + import GHC.TypeNats + import CheckedLiterals + test :: Int + test = match 0 + where + match :: #{typeName} -> Int + match #{literal} = 0 + match _ = 1 + |] + ( if null expectedErrors + then ExpectSuccess + else ExpectFailure expectedErrors + ) diff --git a/tests/Tests/Integer.hs b/tests/Tests/Integer.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer.hs @@ -0,0 +1,24 @@ +module Tests.Integer (tests) where + +import Test.Tasty (TestTree, testGroup) + +import Tests.Integer.Case qualified +import Tests.Integer.Fixed qualified +import Tests.Integer.FunctionPattern qualified +import Tests.Integer.Int qualified +import Tests.Integer.Signed qualified +import Tests.Integer.Unsigned qualified +import Tests.Integer.Word qualified + +tests :: TestTree +tests = + testGroup + "Integer" + [ Tests.Integer.Int.tests + , Tests.Integer.Case.tests + , Tests.Integer.FunctionPattern.tests + , Tests.Integer.Signed.tests + , Tests.Integer.Fixed.tests + , Tests.Integer.Unsigned.tests + , Tests.Integer.Word.tests + ] diff --git a/tests/Tests/Integer/Case.hs b/tests/Tests/Integer/Case.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/Case.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Tests.Integer.Case (tests) where + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toCaseTestCases) + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Case" $ + toCaseTestCases + [ ("Data.Word", "Word8", "255", []) + , ("Data.Word", "Word8", "256", ["Literal 256 is out of bounds.", "Word8 has bounds: [0 .. 255]."]) + , ("Data.Word", "Word8", "-1", ["Literal -1 is out of bounds.", "Word8 has bounds: [0 .. 255]."]) + , ("Data.Word", "Word8", "(uncheckedLiteral -> 256)", []) + , ("Data.Int", "Int8", "127", []) + , ("Data.Int", "Int8", "128", ["Literal 128 is out of bounds.", "Int8 has bounds: [-128 .. 127]."]) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Integer/Fixed.hs b/tests/Tests/Integer/Fixed.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/Fixed.hs @@ -0,0 +1,61 @@ +module Tests.Integer.Fixed where + +import Prelude + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +fMod :: String +fMod = "CheckedLiterals.Nums.Fixed" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Fixed" $ toTestCases + [ (fMod, "(KnownNat f) => UFixed 0 f", "0", []) + , (fMod, "(KnownNat f) => UFixed 0 f", "-1", ["Literal -1 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f) => UFixed 0 f", "1", ["Literal 1 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s)."]) + , (fMod, "(KnownNat f) => UFixed 1 f", "0", []) + , (fMod, "(KnownNat f) => UFixed 1 f", "-1", ["Literal -1 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f) => UFixed 1 f", "1", []) + , (fMod, "(KnownNat f) => UFixed 1 f", "2", ["Literal 2 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s)."]) + , (fMod, "(KnownNat f) => UFixed 2 f", "0", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "-1", ["Literal -1 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f) => UFixed 2 f", "1", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "2", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "3", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "4", ["Literal 4 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s)."]) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "0", []) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "1", ["Literal 1 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s).", "Possible fix: add a constraint: 1 <= n."]) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "-1", ["Literal -1 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => UFixed n f", "0", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => UFixed n f", "1", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => UFixed n f", "-1", ["Literal -1 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => UFixed n f", "0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => UFixed n f", "1", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => UFixed n f", "-1", ["Literal -1 is out of bounds, because UFixed cannot represent negative numbers."]) + + , (fMod, "(KnownNat f) => SFixed 0 f", "0", []) + , (fMod, "(KnownNat f) => SFixed 0 f", "-1", ["Literal -1 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 0 f", "1", ["Literal 1 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 1 f", "0", []) + , (fMod, "(KnownNat f) => SFixed 1 f", "-1", []) + , (fMod, "(KnownNat f) => SFixed 1 f", "1", ["Literal 1 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 1 f", "2", ["Literal 2 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 2 f", "0", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "-1", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "-2", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "-3", ["Literal -3 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 2 f", "1", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "2", ["Literal 2 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 2 f", "4", ["Literal 4 is (potentially) out of bounds.", "Note: integer part needs at least 4 bit(s), including sign bit."]) + , (fMod, "(KnownNat f, KnownNat n) => SFixed n f", "0", []) + , (fMod, "(KnownNat f, KnownNat n) => SFixed n f", "1", ["Literal 1 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit.", "Possible fix: add a constraint: 2 <= n."]) + , (fMod, "(KnownNat f, KnownNat n) => SFixed n f", "-1", ["Literal -1 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= n."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => SFixed n f", "0", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => SFixed n f", "1", ["Literal 1 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit.", "Possible fix: add a constraint: 2 <= n."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => SFixed n f", "-1", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => SFixed n f", "0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => SFixed n f", "1", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => SFixed n f", "-1", []) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Integer/FunctionPattern.hs b/tests/Tests/Integer/FunctionPattern.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/FunctionPattern.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Tests.Integer.FunctionPattern (tests) where + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toFunctionPatternTestCases) + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "FunctionPattern" $ + toFunctionPatternTestCases + [ ("Data.Word", "Word8", "255", []) + , ("Data.Word", "Word8", "256", ["Literal 256 is out of bounds.", "Word8 has bounds: [0 .. 255]."]) + , ("Data.Word", "Word8", "(-1)", ["Literal -1 is out of bounds.", "Word8 has bounds: [0 .. 255]."]) + , ("Data.Word", "Word8", "(uncheckedLiteral -> 256)", []) + , ("Data.Int", "Int8", "127", []) + , ("Data.Int", "Int8", "128", ["Literal 128 is out of bounds.", "Int8 has bounds: [-128 .. 127]."]) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Integer/Int.hs b/tests/Tests/Integer/Int.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/Int.hs @@ -0,0 +1,38 @@ +module Tests.Integer.Int (tests) where + +import Prelude + +import Data.Int +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Int" $ toTestCases + [ ("Data.Int", "Int", "0", []) + , ("Data.Int", "Int", show (minBound :: Int), []) + , ("Data.Int", "Int", show $ pred $ toInteger (minBound @Int), ["Literal -9223372036854775809 is out of bounds.", "Int has bounds: [-9223372036854775808 .. 9223372036854775807]"]) + , ("Data.Int", "Int", show (maxBound :: Int), []) + , ("Data.Int", "Int", show $ succ $ toInteger (maxBound @Int), ["Literal 9223372036854775808 is out of bounds.", "Int has bounds: [-9223372036854775808 .. 9223372036854775807]"]) + , ("Data.Int", "Int8", "0", []) + , ("Data.Int", "Int8", show (minBound :: Int8), []) + , ("Data.Int", "Int8", show $ pred $ toInteger (minBound @Int8), ["Literal -129 is out of bounds.", "Int8 has bounds: [-128 .. 127]"]) + , ("Data.Int", "Int8", show (maxBound :: Int8), []) + , ("Data.Int", "Int8", show $ succ $ toInteger (maxBound @Int8), ["Literal 128 is out of bounds.", "Int8 has bounds: [-128 .. 127]"]) + , ("Data.Int", "Int16", "0", []) + , ("Data.Int", "Int16", show (minBound :: Int16), []) + , ("Data.Int", "Int16", show $ pred $ toInteger (minBound @Int16), ["Literal -32769 is out of bounds.", "Int16 has bounds: [-32768 .. 32767]"]) + , ("Data.Int", "Int16", show (maxBound :: Int16), []) + , ("Data.Int", "Int16", show $ succ $ toInteger (maxBound @Int16), ["Literal 32768 is out of bounds.", "Int16 has bounds: [-32768 .. 32767]"]) + , ("Data.Int", "Int32", "0", []) + , ("Data.Int", "Int32", show (minBound :: Int32), []) + , ("Data.Int", "Int32", show $ pred $ toInteger (minBound @Int32), ["Literal -2147483649 is out of bounds.", "Int32 has bounds: [-2147483648 .. 2147483647]"]) + , ("Data.Int", "Int32", show (maxBound :: Int32), []) + , ("Data.Int", "Int32", show $ succ $ toInteger (maxBound @Int32), ["Literal 2147483648 is out of bounds.", "Int32 has bounds: [-2147483648 .. 2147483647]"]) + , ("Data.Int", "Int64", "0", []) + , ("Data.Int", "Int64", show (minBound :: Int64), []) + , ("Data.Int", "Int64", show $ pred $ toInteger (minBound @Int64), ["Literal -9223372036854775809 is out of bounds.", "Int64 has bounds: [-9223372036854775808 .. 9223372036854775807]"]) + , ("Data.Int", "Int64", show (maxBound :: Int64), []) + , ("Data.Int", "Int64", show $ succ $ toInteger (maxBound @Int64), ["Literal 9223372036854775808 is out of bounds.", "Int64 has bounds: [-9223372036854775808 .. 9223372036854775807]"]) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Integer/Signed.hs b/tests/Tests/Integer/Signed.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/Signed.hs @@ -0,0 +1,39 @@ +module Tests.Integer.Signed where + +import Prelude + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +sMod :: String +sMod = "CheckedLiterals.Nums.Signed" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Signed" $ toTestCases + [ (sMod, "Signed 0", "0", []) + , (sMod, "Signed 0", "-1", ["Literal -1 is (potentially) out of bounds."]) + , (sMod, "Signed 0", "1", ["Literal 1 is (potentially) out of bounds."]) + , (sMod, "Signed 1", "0", []) + , (sMod, "Signed 1", "-1", []) + , (sMod, "Signed 1", "1", ["Literal 1 is (potentially) out of bounds.", "Signed 1 has bounds: [-1 .. 0]"]) + , (sMod, "Signed 2", "0", []) + , (sMod, "Signed 2", "-1", []) + , (sMod, "Signed 2", "-2", []) + , (sMod, "Signed 2", "-3", ["Literal -3 is (potentially) out of bounds.", "Signed 2 has bounds: [-2 .. 1]"]) + , (sMod, "Signed 2", "1", []) + , (sMod, "Signed 2", "2", ["Signed 2 has bounds: [-2 .. 1]"]) + , (sMod, "(KnownNat n) => Signed n", "0", []) + , (sMod, "(KnownNat n) => Signed n", "1", ["Signed n has bounds: [-2 ^ (n - 1) .. (2 ^ (n - 1)) - 1]", "Possible fix: add a constraint: 2 <= n."]) + , (sMod, "(KnownNat n) => Signed n", "-1", ["Literal -1 is (potentially) out of bounds.", "Signed n has bounds: [-2 ^ (n - 1) .. (2 ^ (n - 1)) - 1]", "Possible fix: add a constraint: 1 <= n."]) + , (sMod, "(KnownNat n, 1 <= n) => Signed n", "0", []) + , (sMod, "(KnownNat n, 1 <= n) => Signed n", "1", ["Signed n has bounds: [-2 ^ (n - 1) .. (2 ^ (n - 1)) - 1]", "Possible fix: add a constraint: 2 <= n."]) + , (sMod, "(KnownNat n, 1 <= n) => Signed n", "-1", []) + , (sMod, "(KnownNat n, 2 <= n) => Signed n", "0", []) + , (sMod, "(KnownNat n, 2 <= n) => Signed n", "1", []) + , (sMod, "(KnownNat n, 2 <= n) => Signed n", "-1", []) + , (sMod, "(KnownNat n, 3 <= n) => Signed n", "0", []) + , (sMod, "(KnownNat n, 3 <= n) => Signed n", "1", []) + , (sMod, "(KnownNat n, 3 <= n) => Signed n", "-1", []) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Integer/Unsigned.hs b/tests/Tests/Integer/Unsigned.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/Unsigned.hs @@ -0,0 +1,39 @@ +module Tests.Integer.Unsigned where + +import Prelude + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +uMod :: String +uMod = "CheckedLiterals.Nums.Unsigned" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Unsigned" $ toTestCases + [ (uMod, "Unsigned 0", "0", []) + , (uMod, "Unsigned 0", "-1", ["Literal -1 is out of bounds.", "Unsigned 0 has bounds: [0 .. 0]."]) + , (uMod, "Unsigned 0", "1", ["Literal 1 is (potentially) out of bounds.", "Unsigned 0 has bounds: [0 .. 0]."]) + , (uMod, "Unsigned 1", "0", []) + , (uMod, "Unsigned 1", "-1", ["Literal -1 is out of bounds.", "Unsigned 1 has bounds: [0 .. 1]."]) + , (uMod, "Unsigned 1", "1", []) + , (uMod, "Unsigned 1", "2", ["Literal 2 is (potentially) out of bounds.", "Unsigned 1 has bounds: [0 .. 1]."]) + , (uMod, "Unsigned 2", "0", []) + , (uMod, "Unsigned 2", "-1", ["Literal -1 is out of bounds.", "Unsigned 2 has bounds: [0 .. 3]."]) + , (uMod, "Unsigned 2", "1", []) + , (uMod, "Unsigned 2", "2", []) + , (uMod, "Unsigned 2", "3", []) + , (uMod, "Unsigned 2", "4", ["Literal 4 is (potentially) out of bounds.", "Unsigned 2 has bounds: [0 .. 3]."]) + , (uMod, "(KnownNat n) => Unsigned n", "0", []) + , (uMod, "(KnownNat n) => Unsigned n", "1", ["Literal 1 is (potentially) out of bounds.", "Unsigned n has bounds: [0 .. (2 ^ n) - 1]", "Possible fix: add a constraint: 1 <= n."]) + , (uMod, "(KnownNat n) => Unsigned n", "-1", ["Literal -1 is out of bounds.", "Unsigned n has bounds: [0 .. (2 ^ n) - 1]."]) + , (uMod, "(KnownNat n, 1 <= n) => Unsigned n", "0", []) + , (uMod, "(KnownNat n, 1 <= n) => Unsigned n", "1", []) + , (uMod, "(KnownNat n, 1 <= n) => Unsigned n", "-1", ["Literal -1 is out of bounds.", "Unsigned n has bounds: [0 .. (2 ^ n) - 1]."]) + , (uMod, "(KnownNat n, 2 <= n) => Unsigned n", "0", []) + , (uMod, "(KnownNat n, 2 <= n) => Unsigned n", "1", []) + , (uMod, "(KnownNat n, 2 <= n) => Unsigned n", "-1", ["Literal -1 is out of bounds.", "Unsigned n has bounds: [0 .. (2 ^ n) - 1]."]) + , (uMod, "(KnownNat n, 7 <= n) => Unsigned n", "255", ["Literal 255 is (potentially) out of bounds.", "Unsigned n has bounds: [0 .. (2 ^ n) - 1].", "Possible fix: add a constraint: 8 <= n."]) + , (uMod, "(KnownNat n, 8 <= n) => Unsigned n", "256", ["Literal 256 is (potentially) out of bounds.", "Unsigned n has bounds: [0 .. (2 ^ n) - 1].", "Possible fix: add a constraint: 9 <= n."]) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Integer/Word.hs b/tests/Tests/Integer/Word.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Integer/Word.hs @@ -0,0 +1,33 @@ +module Tests.Integer.Word (tests) where + +import Prelude + +import Data.Word +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Word" $ toTestCases + [ ("Data.Word", "Word", show (minBound :: Word), []) + , ("Data.Word", "Word", show $ pred $ toInteger (minBound @Word), ["Literal -1 is out of bounds.","Word has bounds: [0 .. 18446744073709551615]"]) + , ("Data.Word", "Word", show (maxBound :: Word), []) + , ("Data.Word", "Word", show $ succ $ toInteger (maxBound @Word), ["Literal 18446744073709551616 is out of bounds.", "Word has bounds: [0 .. 18446744073709551615]"]) + , ("Data.Word", "Word8", show (minBound :: Word8), []) + , ("Data.Word", "Word8", show $ pred $ toInteger (minBound @Word8), ["Literal -1 is out of bounds.", "Word8 has bounds: [0 .. 255]"]) + , ("Data.Word", "Word8", show (maxBound :: Word8), []) + , ("Data.Word", "Word8", show $ succ $ toInteger (maxBound @Word8), ["Literal 256 is out of bounds.", "Word8 has bounds: [0 .. 255]"]) + , ("Data.Word", "Word16", show (minBound :: Word16), []) + , ("Data.Word", "Word16", show $ pred $ toInteger (minBound @Word16), ["Literal -1 is out of bounds.", "Word16 has bounds: [0 .. 65535]"]) + , ("Data.Word", "Word16", show (maxBound :: Word16), []) + , ("Data.Word", "Word16", show $ succ $ toInteger (maxBound @Word16), ["Literal 65536 is out of bounds.", "Word16 has bounds: [0 .. 65535]"]) + , ("Data.Word", "Word32", show (minBound :: Word32), []) + , ("Data.Word", "Word32", show $ pred $ toInteger (minBound @Word32), ["Literal -1 is out of bounds.", "Word32 has bounds: [0 .. 4294967295]"]) + , ("Data.Word", "Word32", show (maxBound :: Word32), []) + , ("Data.Word", "Word32", show $ succ $ toInteger (maxBound @Word32), ["Literal 4294967296 is out of bounds.", "Word32 has bounds: [0 .. 4294967295]"]) + , ("Data.Word", "Word64", show (minBound :: Word64), []) + , ("Data.Word", "Word64", show $ pred $ toInteger (minBound @Word64), ["Literal -1 is out of bounds.", "Word64 has bounds: [0 .. 18446744073709551615]"]) + , ("Data.Word", "Word64", show (maxBound :: Word64), []) + , ("Data.Word", "Word64", show $ succ $ toInteger (maxBound @Word64), ["Literal 18446744073709551616 is out of bounds.", "Word64 has bounds: [0 .. 18446744073709551615]"]) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Rational.hs b/tests/Tests/Rational.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Rational.hs @@ -0,0 +1,18 @@ +module Tests.Rational (tests) where + +import Test.Tasty (TestTree, testGroup) + +import Tests.Rational.Case qualified +import Tests.Rational.Fixed qualified +import Tests.Rational.FunctionPattern qualified +import Tests.Rational.Ratio qualified + +tests :: TestTree +tests = + testGroup + "Rational" + [ Tests.Rational.Fixed.tests + , Tests.Rational.Case.tests + , Tests.Rational.FunctionPattern.tests + , Tests.Rational.Ratio.tests + ] diff --git a/tests/Tests/Rational/Case.hs b/tests/Tests/Rational/Case.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Rational/Case.hs @@ -0,0 +1,17 @@ +module Tests.Rational.Case (tests) where + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toCaseTestCases) + +fMod :: String +fMod = "CheckedLiterals.Nums.Fixed" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Case" $ toCaseTestCases + [ (fMod, "UFixed 0 1", "0.5", []) + , (fMod, "UFixed 0 1", "0.75", ["Literal 0.75 cannot be represented exactly by Fixed", "The fractional part needs at least 2 bit(s)."]) + , (fMod, "UFixed 0 1", "-0.5", ["Literal -0.5 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "UFixed 0 1", "(uncheckedLiteral -> 0.75)", []) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Rational/Fixed.hs b/tests/Tests/Rational/Fixed.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Rational/Fixed.hs @@ -0,0 +1,86 @@ +module Tests.Rational.Fixed where + +import Prelude + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +fMod :: String +fMod = "CheckedLiterals.Nums.Fixed" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Fixed" $ toTestCases + [ (fMod, "(KnownNat f) => UFixed 0 f", "0.0", []) + , (fMod, "(KnownNat f) => UFixed 0 f", "-1.0", ["Literal -1.0 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f) => UFixed 0 f", "1.0", ["Literal 1.0 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s)."]) + , (fMod, "(KnownNat f) => UFixed 1 f", "0.0", []) + , (fMod, "(KnownNat f) => UFixed 1 f", "-1.0", ["Literal -1.0 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f) => UFixed 1 f", "1.0", []) + , (fMod, "(KnownNat f) => UFixed 1 f", "2.0", ["Literal 2.0 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s)."]) + , (fMod, "(KnownNat f) => UFixed 2 f", "0.0", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "-1.0", ["Literal -1.0 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f) => UFixed 2 f", "1.0", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "2.0", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "3.0", []) + , (fMod, "(KnownNat f) => UFixed 2 f", "4.0", ["Literal 4.0 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s)."]) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "0.0", []) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "1.0", ["Literal 1.0 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s).", "Possible fix: add a constraint: 1 <= n."]) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "-1.0", ["Literal -1.0 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => UFixed n f", "0.0", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => UFixed n f", "1.0", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => UFixed n f", "-1.0", ["Literal -1.0 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => UFixed n f", "0.0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => UFixed n f", "1.0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => UFixed n f", "-1.0", ["Literal -1.0 is out of bounds, because UFixed cannot represent negative numbers."]) + + , (fMod, "(KnownNat f) => SFixed 0 f", "0.0", []) + , (fMod, "(KnownNat f) => SFixed 0 f", "-1.0", ["Literal -1.0 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 0 f", "1.0", ["Literal 1.0 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 1 f", "0.0", []) + , (fMod, "(KnownNat f) => SFixed 1 f", "-1.0", []) + , (fMod, "(KnownNat f) => SFixed 1 f", "1.0", ["Literal 1.0 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 1 f", "2.0", ["Literal 2.0 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 2 f", "0.0", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "-1.0", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "-2.0", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "-3.0", ["Literal -3.0 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 2 f", "1.0", []) + , (fMod, "(KnownNat f) => SFixed 2 f", "2.0", ["Literal 2.0 is (potentially) out of bounds.", "Note: integer part needs at least 3 bit(s), including sign bit."]) + , (fMod, "(KnownNat f) => SFixed 2 f", "4.0", ["Literal 4.0 is (potentially) out of bounds.", "Note: integer part needs at least 4 bit(s), including sign bit."]) + , (fMod, "(KnownNat f, KnownNat n) => SFixed n f", "0.0", []) + , (fMod, "(KnownNat f, KnownNat n) => SFixed n f", "1.0", ["Literal 1.0 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit.", "Possible fix: add a constraint: 2 <= n."]) + , (fMod, "(KnownNat f, KnownNat n) => SFixed n f", "-1.0", ["Literal -1.0 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= n."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => SFixed n f", "0.0", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => SFixed n f", "1.0", ["Literal 1.0 is (potentially) out of bounds.", "Note: integer part needs at least 2 bit(s), including sign bit.", "Possible fix: add a constraint: 2 <= n."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n) => SFixed n f", "-1.0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => SFixed n f", "0.0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => SFixed n f", "1.0", []) + , (fMod, "(KnownNat f, KnownNat n, 2 <= n) => SFixed n f", "-1.0", []) + + , (fMod, "UFixed 0 0", "0.5", ["Literal 0.5 cannot be represented exactly by Fixed", "The fractional part needs at least 1 bit(s)."]) + , (fMod, "UFixed 0 1", "0.5", []) + , (fMod, "UFixed 0 1", "0.75", ["Literal 0.75 cannot be represented exactly by Fixed", "The fractional part needs at least 2 bit(s)."]) + , (fMod, "UFixed 0 1", "0.1", ["Literal 0.1 cannot be represented exactly by", "The reduced denominator 10 is not a power of 2."]) + , (fMod, "(KnownNat f, 1 <= f) => UFixed 0 f", "0.5", []) + , (fMod, "(KnownNat f, 1 <= f) => UFixed 0 f", "0.75", ["Literal 0.75 cannot be represented exactly by Fixed", "The fractional part needs at least 2 bit(s).", "Possible fix: add a constraint: 2 <= f."]) + , (fMod, "(KnownNat f, 2 <= f) => UFixed 0 f", "0.75", []) + , (fMod, "(KnownNat f, 3 <= f) => UFixed 0 f", "0.75", []) + + , (fMod, "SFixed 0 0", "0.5", ["Literal 0.5 cannot be represented exactly by Fixed", "The fractional part needs at least 1 bit(s)."]) + , (fMod, "SFixed 0 1", "0.5", ["Literal 0.5 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= 0."]) + , (fMod, "SFixed 0 1", "0.75", ["Literal 0.75 cannot be represented exactly by Fixed", "The fractional part needs at least 2 bit(s)."]) + , (fMod, "SFixed 0 1", "0.1", ["Literal 0.1 cannot be represented exactly by", "The reduced denominator 10 is not a power of 2."]) + , (fMod, "(KnownNat f, 1 <= f) => SFixed 0 f", "0.5", ["Literal 0.5 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= 0."]) + , (fMod, "(KnownNat f, 1 <= f) => SFixed 0 f", "0.75", ["Literal 0.75 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= 0."]) + , (fMod, "(KnownNat f, 2 <= f) => SFixed 0 f", "0.75", ["Literal 0.75 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= 0."]) + , (fMod, "(KnownNat f, 3 <= f) => SFixed 0 f", "0.75", ["Literal 0.75 is (potentially) out of bounds.", "Note: integer part needs at least 1 bit(s), including sign bit.", "Possible fix: add a constraint: 1 <= 0."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n, 1 <= f) => SFixed n f", "0.5", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n, 1 <= f) => SFixed n f", "0.75", ["Literal 0.75 cannot be represented exactly by Fixed", "The fractional part needs at least 2 bit(s).", "Possible fix: add a constraint: 2 <= f."]) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n, 2 <= f) => SFixed n f", "0.75", []) + , (fMod, "(KnownNat f, KnownNat n, 1 <= n, 3 <= f) => SFixed n f", "0.75", []) + + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "255.0", ["Literal 255.0 is (potentially) out of bounds.", "Note: integer part needs at least 8 bit(s).", "Possible fix: add a constraint: 8 <= n."]) + , (fMod, "(KnownNat f, KnownNat n) => UFixed n f", "256.0", ["Literal 256.0 is (potentially) out of bounds.", "Note: integer part needs at least 9 bit(s).", "Possible fix: add a constraint: 9 <= n."]) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Rational/FunctionPattern.hs b/tests/Tests/Rational/FunctionPattern.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Rational/FunctionPattern.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Tests.Rational.FunctionPattern (tests) where + +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toFunctionPatternTestCases) + +fMod :: String +fMod = "CheckedLiterals.Nums.Fixed" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "FunctionPattern" $ toFunctionPatternTestCases + [ (fMod, "UFixed 0 1", "0.5", []) + , (fMod, "UFixed 0 1", "0.75", ["Literal 0.75 cannot be represented exactly by Fixed", "The fractional part needs at least 2 bit(s)."]) + , (fMod, "UFixed 0 1", "(-0.5)", ["Literal -0.5 is out of bounds, because UFixed cannot represent negative numbers."]) + , (fMod, "UFixed 0 1", "(uncheckedLiteral -> 0.75)", []) + ] +{- FOURMOLU_ENABLE -} diff --git a/tests/Tests/Rational/Ratio.hs b/tests/Tests/Rational/Ratio.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Rational/Ratio.hs @@ -0,0 +1,32 @@ +module Tests.Rational.Ratio (tests) where + +import Prelude + +import Data.Ratio ((%)) +import Data.Ratio.Extra (showFixedPoint) +import Test.Tasty (TestTree, testGroup) +import Tests.Common (toTestCases) + +rMod :: String +rMod = "Data.Ratio; import Data.Word; import Data.Int" + +{- FOURMOLU_DISABLE -} +tests :: TestTree +tests = testGroup "Ratio" $ toTestCases + [ (rMod, "Ratio Word8", "0.0", []) + , (rMod, "Ratio Word8", "1.0", []) + , (rMod, "Ratio Word8", "-1.0", ["Literal -1.0 cannot be represented by Ratio Word8.", "Word8 cannot represent negative numbers."]) + , (rMod, "Ratio Word8", showFixedPoint (1 % 256), ["Literal 0.00390625 (1 % 256) cannot be represented by Word8.", "Word8 has bounds: [0 .. 255]."]) + , (rMod, "Ratio Word8", "0.1", []) + , (rMod, "Ratio Word8", "0.01", []) + , (rMod, "Ratio Word8", "0.001", ["Literal 0.001 (1 % 1000) cannot be represented by Word8."]) + , (rMod, "Ratio Int8", "0.0", []) + , (rMod, "Ratio Int8", "1.0", []) + , (rMod, "Ratio Int8", "-1.0", []) + , (rMod, "Ratio Int8", "-129.0", ["Literal -129.0 (-129 % 1) cannot be represented by Int8.", "Int8 has bounds: [-128 .. 127]."]) + , (rMod, "Ratio Int8", showFixedPoint (1 % 128), ["Literal 0.0078125 (1 % 128) cannot be represented by Int8.", "Int8 has bounds: [-128 .. 127]."]) + , (rMod, "Ratio Int8", "0.1", []) + , (rMod, "Ratio Int8", "0.01", []) + , (rMod, "Ratio Int8", "0.001", ["Literal 0.001 (1 % 1000) cannot be represented by Int8."]) + ] +{- FOURMOLU_ENABLE -}